/[gcl]/gcl/mod/gcl_defpackage.lsp
ViewVC logotype

Diff of /gcl/mod/gcl_defpackage.lsp

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

revision 1.3 by camm, Mon Mar 7 18:32:26 2005 UTC revision 1.4 by camm, Wed Jun 29 04:24:11 2005 UTC
# Line 145  Line 145 
145    (labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1)))    (labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1)))
146             (option-values-list (option options)             (option-values-list (option options)
147                                 (sloop for result = (member option options                                 (sloop for result = (member option options
148                                                             ':test #'option-test)                                                             :test #'option-test)
149                                        then (member option (rest result)                                        then (member option (rest result)
150                                                     ':test #'option-test)                                                     :test #'option-test)
151                                        until (null result) when result collect                                        until (null result) when result collect
152                                        (rest (first result))))                                        (rest (first result))))
153             (option-values (option options)             (option-values (option options)
154                            (sloop for result  = (member option options ':test #'option-test)                            (sloop for result  = (member option options :test #'option-test)
155                                   then (member option (rest result) ':test #'option-test)                                   then (member option (rest result) :test #'option-test)
156                                   until (null result) when result append                                   until (null result) when result append
157                                   (rest (first result)))))                                   (rest (first result)))))
158            (sloop for option in '(:size :documentation)            (sloop for option in '(:size :documentation)
159                   when (<= 2 (count option options ':key #'car))                   when (<= 2 (count option options :key #'car))
160                   do (specific-error :invalid-form                   do (specific-error :invalid-form
161                                      "DEFPACKAGE option ~s specified more than once."                                      "DEFPACKAGE option ~s specified more than once."
162                                      option))                                      option))
163            (setq name (string name))            (setq name (string name))
164            (let ((nicknames (mapcar #'string (option-values ':nicknames options)))            (let ((nicknames (mapcar #'string (option-values :nicknames options)))
165                  (documentation (first (option-values ':documentation options)))                  (documentation (first (option-values :documentation options)))
166                  (size (first (option-values ':size options)))                  (size (first (option-values :size options)))
167                  (shadowed-symbol-names (mapcar #'string (option-values ':shadow options)))                  (shadowed-symbol-names (mapcar #'string (option-values :shadow options)))
168                  (interned-symbol-names (mapcar #'string (option-values ':intern options)))                  (interned-symbol-names (mapcar #'string (option-values :intern options)))
169                  (exported-symbol-names (mapcar #'string (option-values ':export options)))                  (exported-symbol-names (mapcar #'string (option-values :export options)))
170                  (shadowing-imported-from-symbol-names-list                  (shadowing-imported-from-symbol-names-list
171                   (sloop for list in (option-values-list ':shadowing-import-from options)                   (sloop for list in (option-values-list :shadowing-import-from options)
172                          collect (cons (string (first list)) (mapcar #'string (rest list)))))                          collect (cons (string (first list)) (mapcar #'string (rest list)))))
173                  (imported-from-symbol-names-list                  (imported-from-symbol-names-list
174                   (sloop for list in (option-values-list ':import-from options)                   (sloop for list in (option-values-list :import-from options)
175                          collect (cons (string (first list)) (mapcar #'string (rest list)))))                          collect (cons (string (first list)) (mapcar #'string (rest list)))))
176                  (exported-from-package-names                  (exported-from-package-names
177                   (mapcar #'string (option-values ':export-from options))))                   (mapcar #'string (option-values :export-from options))))
178              (flet ((find-duplicates              (flet ((find-duplicates
179                      (&rest lists)                      (&rest lists)
180                      (let (results)                      (let (results)
# Line 212  Line 212 
212                            (sloop for num in (rest duplicate)                            (sloop for num in (rest duplicate)
213                                   collect                                   collect
214                                   (case num                                   (case num
215                                         (1 ':SHADOW)                                         (1 :SHADOW)
216                                         (2 ':INTERN)                                         (2 :INTERN)
217                                         (3 ':SHADOWING-IMPORT-FROM)                                         (3 :SHADOWING-IMPORT-FROM)
218                                         (4 ':IMPORT-FROM)))))                                         (4 :IMPORT-FROM)))))
219                    (sloop for duplicate in                    (sloop for duplicate in
220                           (find-duplicates exported-symbol-names interned-symbol-names)                           (find-duplicates exported-symbol-names interned-symbol-names)
221                           do                           do
# Line 226  Line 226 
226                            (sloop for num in                            (sloop for num in
227                                   (rest duplicate)                                   (rest duplicate)
228                                   collect (case num                                   collect (case num
229                                                 (1 ':EXPORT)                                                 (1 :EXPORT)
230                                                 (2 ':INTERN))))))                                                 (2 :INTERN))))))
231              `(eval-when (load eval compile)              `(eval-when (load eval compile)
232                          (if (find-package ,name)                          (if (find-package ,name)
233                              (progn (rename-package ,name ,name)                              (progn (rename-package ,name ,name)
# Line 244  Line 244 
244                                                             (find-package ,name))))                                                             (find-package ,name))))
245                                                    (when (hash-table-p tab)                                                    (when (hash-table-p tab)
246                                                      (setf (excl::ha_rehash-size tab) ,size)))))                                                      (setf (excl::ha_rehash-size tab) ,size)))))
247                                     ,@(when (not (null (member ':use options ':key #'car)))                                     ,@(when (not (null (member :use options :key 'car)))
248                                         `((unuse-package                                         `((unuse-package
249                                            (package-use-list (find-package ,name)) ,name))))                                            (package-use-list (find-package ,name)) ,name))))
250                            (make-package                            (make-package
251                             ,name                             ,name
252                             ':use 'nil                             :use 'nil
253                             ':nicknames                             :nicknames
254                             ',nicknames                             ',nicknames
255                             ,@(when size                             ,@(when size
256                                 #+lispm `(:size ,size)                                 #+lispm `(:size ,size)
# Line 278  Line 278 
278    
279                                                      ',(rest list))))                                                      ',(rest list))))
280                                        SHADOWING-IMPORTed-from-symbol-names-list))                                        SHADOWING-IMPORTed-from-symbol-names-list))
281                            (USE-PACKAGE ',(if (member ':USE options ':test #'option-test)                            (USE-PACKAGE ',(if (member :USE options :test #'option-test)
282                                               (mapcar #'string (option-values ':USE options))                                               (mapcar #'string (option-values :USE options))
283                                             "LISP"))                                             "LISP"))
284                            ,@(when IMPORTed-from-symbol-names-list                            ,@(when IMPORTed-from-symbol-names-list
285                                (mapcar #'(lambda (list)                                (mapcar #'(lambda (list)
# Line 312  Line 312 
312  ;(excl::defadvice cl:documentation (look-for-package-type :around)  ;(excl::defadvice cl:documentation (look-for-package-type :around)
313  ;    (let ((symbol (first excl::arglist))  ;    (let ((symbol (first excl::arglist))
314  ;          (type (second excl::arglist)))  ;          (type (second excl::arglist)))
315  ;       (if (or (eq ':package (intern (string type) :keyword))  ;       (if (or (eq :package (intern (string type) :keyword))
316  ;              (eq ':defpackage (intern (string type) :keyword)))  ;              (eq :defpackage (intern (string type) :keyword)))
317  ;          (or (get symbol 'excl::%package-documentation)  ;          (or (get symbol 'excl::%package-documentation)
318  ;              (get (intern (string symbol) :keyword) 'excl::%package-documentation))  ;              (get (intern (string symbol) :keyword) 'excl::%package-documentation))
319  ;        (values :do-it))))  ;        (values :do-it))))
# Line 322  Line 322 
322  ;(scl::advise cl:documentation :around look-for-package-type nil  ;(scl::advise cl:documentation :around look-for-package-type nil
323  ;   (let ((symbol (first scl::arglist))  ;   (let ((symbol (first scl::arglist))
324  ;        (type (second scl::arglist)))  ;        (type (second scl::arglist)))
325  ;     (if (or (eq ':package (intern (string type) :keyword))  ;     (if (or (eq :package (intern (string type) :keyword))
326  ;            (eq ':defpackage (intern (string type) :keyword)))  ;            (eq :defpackage (intern (string type) :keyword)))
327  ;        (or (get symbol ':package-documentation)  ;        (or (get symbol :package-documentation)
328  ;            (get (intern (string symbol) :keyword) ':package-documentation))  ;            (get (intern (string symbol) :keyword) :package-documentation))
329  ;       (values :do-it))))  ;       (values :do-it))))
330    
331  ;(pushnew :defpackage *features*)  ;(pushnew :defpackage *features*)

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

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