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