/[gcl]/gcl/lsp/defpackage.lsp
ViewVC logotype

Diff of /gcl/lsp/defpackage.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by camm, Mon Oct 14 05:24:43 2002 UTC revision 1.7 by camm, Tue Oct 15 14:51:51 2002 UTC
# Line 136  Line 136 
136    (sloop for option in options    (sloop for option in options
137           unless (member           unless (member
138                   (first option)                   (first option)
139                   '(:documentation :size :nicknames :shadow :shadowing-import-from :use :import-from :intern :export :export-from))                   '(:documentation :size :nicknames :shadow
140                                      :shadowing-import-from :use :import-from
141                                      :intern :export :export-from))
142           do (cerror "Proceed, ignoring this option." "~s is not a valid option." option))           do (cerror "Proceed, ignoring this option." "~s is not a valid option." option))
143    (labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1)))    (labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1)))
144             (option-values-list (option options)             (option-values-list (option options)
145               (sloop for result = (member option options ':test #'option-test)                                 (sloop for result = (member option options
146                                then (member option (rest result) ':test #'option-test)                                                             ':test #'option-test)
147                     until (null result) when result collect (rest (first result))))                                        then (member option (rest result)
148                                                       ':test #'option-test)
149                                          until (null result) when result collect
150                                          (rest (first result))))
151             (option-values (option options)             (option-values (option options)
152               (sloop for result  = (member option options ':test #'option-test)                            (sloop for result  = (member option options ':test #'option-test)
153                                then (member option (rest result) ':test #'option-test)                                   then (member option (rest result) ':test #'option-test)
154                     until (null result) when result append (rest (first result)))))                                   until (null result) when result append
155      (sloop for option in '(:size :documentation)                                   (rest (first result)))))
156            when (<= 2 (count option options ':key #'car))            (sloop for option in '(:size :documentation)
157              do (warn "DEFPACKAGE option ~s specified more than once.  The first value \"~a\" will be used." option (first (option-values option options))))                   when (<= 2 (count option options ':key #'car))
158      (setq name (string name))                   do (specific-error :invalid-form
159      (let ((nicknames (mapcar #'string (option-values ':nicknames options)))                                      "DEFPACKAGE option ~s specified more than once."
160            (documentation (first (option-values ':documentation options)))                                      option))
161            (size (first (option-values ':size options)))            (setq name (string name))
162            (shadowed-symbol-names (mapcar #'string (option-values ':shadow options)))            (let ((nicknames (mapcar #'string (option-values ':nicknames options)))
163            (interned-symbol-names (mapcar #'string (option-values ':intern options)))                  (documentation (first (option-values ':documentation options)))
164            (exported-symbol-names (mapcar #'string (option-values ':export options)))                  (size (first (option-values ':size options)))
165            (shadowing-imported-from-symbol-names-list (sloop for list in (option-values-list ':shadowing-import-from options)                  (shadowed-symbol-names (mapcar #'string (option-values ':shadow options)))
166                                                             collect (cons (string (first list)) (mapcar #'string (rest list)))))                  (interned-symbol-names (mapcar #'string (option-values ':intern options)))
167            (imported-from-symbol-names-list (sloop for list in (option-values-list ':import-from options)                  (exported-symbol-names (mapcar #'string (option-values ':export options)))
168                                                   collect (cons (string (first list)) (mapcar #'string (rest list)))))                  (shadowing-imported-from-symbol-names-list
169            (exported-from-package-names (mapcar #'string (option-values ':export-from options))))                   (sloop for list in (option-values-list ':shadowing-import-from options)
170          (flet ((find-duplicates (&rest lists)                          collect (cons (string (first list)) (mapcar #'string (rest list)))))
171                   (let (results)                  (imported-from-symbol-names-list
172                     (sloop for list in lists                   (sloop for list in (option-values-list ':import-from options)
173                           for more on (cdr lists)                          collect (cons (string (first list)) (mapcar #'string (rest list)))))
174                           for i from 1                  (exported-from-package-names
175                           do                   (mapcar #'string (option-values ':export-from options))))
176                       (sloop for elt in list              (flet ((find-duplicates
177                             as entry = (find elt results :key #'car :test #'string=)                      (&rest lists)
178                             unless (member i entry)                      (let (results)
179                          (sloop for list in lists
180                                 for more on (cdr lists)
181                                 for i from 1
182                               do                               do
183                                 (sloop for l2 in more                               (sloop for elt in list
184                                       for j from (1+ i)                                      as entry = (find elt results :key #'car :test #'string=)
185                                       do                                      unless (member i entry)
186                                   (if (member elt l2 :test #'string=)                                      do
187                                       (if entry                                      (sloop for l2 in more
188                                           (nconc entry (list j))                                             for j from (1+ i)
189                                           (setq entry (car (push (list elt i j) results))))))))                                             do
190                     results)))                                             (if (member elt l2 :test #'string=)
191            (sloop for duplicate in (find-duplicates shadowed-symbol-names interned-symbol-names                                                 (if entry
192                                                    (sloop for list in shadowing-imported-from-symbol-names-list append (rest list))                                                     (nconc entry (list j))
193                                                    (sloop for list in imported-from-symbol-names-list append (rest list)))                                                   (setq entry
194                  do                                                         (car (push
195              (error "The symbol ~s cannot coexist in these lists:~{ ~s~}" (first duplicate)                                                               (list elt i j) results))))))))
196                     (sloop for num in (rest duplicate)                        results)))
197                           collect (case num (1 ':SHADOW)(2 ':INTERN)(3 ':SHADOWING-IMPORT-FROM)(4 ':IMPORT-FROM)))))                    (sloop for duplicate in
198            (sloop for duplicate in (find-duplicates exported-symbol-names interned-symbol-names)                           (find-duplicates
199                  do                            shadowed-symbol-names
200              (error "The symbol ~s cannot coexist in these lists:~{ ~s~}" (first duplicate)                            interned-symbol-names
201                     (sloop for num in (rest duplicate) collect (case num (1 ':EXPORT)(2 ':INTERN))))))                            (sloop for list in shadowing-imported-from-symbol-names-list
202        `(eval-when (load eval compile)                                   append (rest list))
203           (if (find-package ,name)                            (sloop for list in imported-from-symbol-names-list
204               (progn (rename-package ,name ,name)                                   append (rest list)))
205                      ,@(when nicknames `((rename-package ,name ,name ',nicknames)))                           do
206                      #+(or symbolics excl)                           (specific-error
207                      ,@(when size                            :invalid-form
208                          #+symbolics `((when (> ,size (pkg-max-number-of-symbols (find-package ,name)))                            "The symbol ~s cannot coexist in these lists:~{ ~s~}"
209                                          (pkg-rehash (find-package ,name) ,size)))                            (first duplicate)
210                          #+excl `((let ((tab (excl::package-internal-symbols (find-package ,name))))                            (sloop for num in (rest duplicate)
211                                     (when (hash-table-p tab)                                   collect
212                                       (setf (excl::ha_rehash-size tab) ,size)))))                                   (case num
213                      ,@(when (not (null (member ':use options ':key #'car)))                                         (1 ':SHADOW)
214                          `((unuse-package (package-use-list (find-package ,name)) ,name))))                                         (2 ':INTERN)
215             (make-package ,name ':use 'nil ':nicknames ',nicknames ,@(when size #+lispm `(:size ,size) #+excl `(:internal-symbols ,size))))                                         (3 ':SHADOWING-IMPORT-FROM)
216           ,@(when documentation `((setf (get ',(intern name :keyword) #+excl 'excl::%package-documentation #-excl ':package-documentation) ,documentation)))                                         (4 ':IMPORT-FROM)))))
217           (let ((*package* (find-package ,name)))                    (sloop for duplicate in
218             ,@(when SHADOWed-symbol-names `((SHADOW (mapcar #'intern ',SHADOWed-symbol-names))))                           (find-duplicates exported-symbol-names interned-symbol-names)
219             ,@(when SHADOWING-IMPORTed-from-symbol-names-list                           do
220                 (mapcar #'(lambda (list)                           (specific-error
221                             `(SHADOWING-IMPORT (mapcar #'(lambda (symbol) (intern symbol ,(first list))) ',(rest list))))                            :invalid-form
222                         SHADOWING-IMPORTed-from-symbol-names-list))                            "The symbol ~s cannot coexist in these lists:~{ ~s~}"
223             (USE-PACKAGE ',(if (member ':USE options ':test #'option-test)                            (first duplicate)
224                                (mapcar #'string (option-values ':USE options))                            (sloop for num in
225                              "LISP"))                                   (rest duplicate)
226             ,@(when IMPORTed-from-symbol-names-list                                   collect (case num
227                 (mapcar #'(lambda (list) `(IMPORT (mapcar #'(lambda (symbol) (intern symbol ,(first list))) ',(rest list))))                                                 (1 ':EXPORT)
228                         IMPORTed-from-symbol-names-list))                                                 (2 ':INTERN))))))
229             ,@(when INTERNed-symbol-names `((mapcar #'INTERN ',INTERNed-symbol-names)))              `(eval-when (load eval compile)
230             ,@(when EXPORTed-symbol-names `((EXPORT (mapcar #'intern ',EXPORTed-symbol-names))))                          (if (find-package ,name)
231             ,@(when EXPORTed-from-package-names                              (progn (rename-package ,name ,name)
232                 `((dolist (package ',EXPORTed-from-package-names)                                     ,@(when nicknames
233                     (do-external-symbols (symbol (find-package package))                                         `((rename-package ,name ,name ',nicknames)))
234                       (when (nth 1 (multiple-value-list (find-symbol (string symbol))))                                     #+(or symbolics excl)
235                         (EXPORT (list (intern (string symbol)))))))))                                     ,@(when size
236             )                                         #+symbolics
237           (find-package ,name)))))                                         `((when (> ,size (pkg-max-number-of-symbols
238                                                             (find-package ,name)))
239                                               (pkg-rehash (find-package ,name) ,size)))
240                                           #+excl `((let
241                                                        ((tab (excl::package-internal-symbols
242                                                               (find-package ,name))))
243                                                      (when (hash-table-p tab)
244                                                        (setf (excl::ha_rehash-size tab) ,size)))))
245                                       ,@(when (not (null (member ':use options ':key #'car)))
246                                           `((unuse-package
247                                              (package-use-list (find-package ,name)) ,name))))
248                              (make-package
249                               ,name
250                               ':use 'nil
251                               ':nicknames
252                               ',nicknames
253                               ,@(when size
254                                   #+lispm `(:size ,size)
255                                   #+excl `(:internal-symbols ,size))))
256                            ,@(progn
257                                `((setf (get ',(intern name :keyword)
258                                             'si::package-documentation)
259                                        ,documentation))
260                                )
261                            (let ((*package* (find-package ,name)))
262                              ,@(when SHADOWed-symbol-names
263                                  `((SHADOW (mapcar #'intern ',SHADOWed-symbol-names))))
264                              ,@(when SHADOWING-IMPORTed-from-symbol-names-list
265                                  (mapcar #'(lambda (list)
266                                              `(SHADOWING-IMPORT
267                                                (mapcar #'(lambda (symbol)
268                                                            (intern symbol
269                                                                    ,(first list)))
270                                                        ',(rest list))))
271                                          SHADOWING-IMPORTed-from-symbol-names-list))
272                              (USE-PACKAGE ',(if (member ':USE options ':test #'option-test)
273                                                 (mapcar #'string (option-values ':USE options))
274                                               "LISP"))
275                              ,@(when IMPORTed-from-symbol-names-list
276                                  (mapcar #'(lambda (list)
277                                              `(IMPORT (mapcar #'(lambda (symbol)
278                                                                   (intern symbol
279                                                                           ,(first list)))
280                                                               ',(rest list))))
281                                          IMPORTed-from-symbol-names-list))
282                              ,@(when INTERNed-symbol-names
283                                  `((mapcar #'INTERN ',INTERNed-symbol-names)))
284                              ,@(when EXPORTed-symbol-names
285                                  `((EXPORT (mapcar #'intern ',EXPORTed-symbol-names))))
286                              ,@(when EXPORTed-from-package-names
287                                  `((dolist (package ',EXPORTed-from-package-names)
288                                            (do-external-symbols
289                                             (symbol (find-package package))
290                                             (when (nth 1 (multiple-value-list
291                                                           (find-symbol (string symbol))))
292                                               (EXPORT (list (intern (string symbol)))))))))
293                              )
294                            (find-package ,name)))))
295    
296  ;#+excl  ;#+excl
297  ;(excl::defadvice cl:documentation (look-for-package-type :around)  ;(excl::defadvice cl:documentation (look-for-package-type :around)

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26