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) |
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 |
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) |
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) |
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) |
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)))) |
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*) |