package.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
package.lisp (37546B)
---
1 ;;;; ---------------------------------------------------------------------------
2 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.
3 ;;
4 ;; See https://bugs.launchpad.net/asdf/+bug/485687
5 ;;
6
7 (defpackage :uiop/package
8 ;; CAUTION: we must handle the first few packages specially for hot-upgrade.
9 ;; This package definition MUST NOT change unless its name too changes;
10 ;; if/when it changes, don't forget to add new functions missing from below.
11 ;; Until then, uiop/package is frozen to forever
12 ;; import and export the same exact symbols as for ASDF 2.27.
13 ;; Any other symbol must be import-from'ed and re-export'ed in a different package.
14 (:use :common-lisp)
15 (:export
16 #:find-package* #:find-symbol* #:symbol-call
17 #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
18 #:symbol-shadowing-p #:home-package-p
19 #:symbol-package-name #:standard-common-lisp-symbol-p
20 #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
21 #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
22 #:ensure-package-unused #:delete-package*
23 #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
24 #:package-definition-form #:parse-define-package-form
25 #:ensure-package #:define-package))
26
27 (in-package :uiop/package)
28
29 ;;;; General purpose package utilities
30
31 (eval-when (:load-toplevel :compile-toplevel :execute)
32 (defun find-package* (package-designator &optional (error t))
33 (let ((package (find-package package-designator)))
34 (cond
35 (package package)
36 (error (error "No package named ~S" (string package-designator)))
37 (t nil))))
38 (defun find-symbol* (name package-designator &optional (error t))
39 "Find a symbol in a package of given string'ified NAME;
40 unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
41 by letting you supply a symbol or keyword for the name;
42 also works well when the package is not present.
43 If optional ERROR argument is NIL, return NIL instead of an error
44 when the symbol is not found."
45 (block nil
46 (let ((package (find-package* package-designator error)))
47 (when package ;; package error handled by find-package* already
48 (multiple-value-bind (symbol status) (find-symbol (string name) package)
49 (cond
50 (status (return (values symbol status)))
51 (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
52 (values nil nil))))
53 (defun symbol-call (package name &rest args)
54 "Call a function associated with symbol of given name in given package,
55 with given ARGS. Useful when the call is read before the package is loaded,
56 or when loading the package is optional."
57 (apply (find-symbol* name package) args))
58 (defun intern* (name package-designator &optional (error t))
59 (intern (string name) (find-package* package-designator error)))
60 (defun export* (name package-designator)
61 (let* ((package (find-package* package-designator))
62 (symbol (intern* name package)))
63 (export (or symbol (list symbol)) package)))
64 (defun import* (symbol package-designator)
65 (import (or symbol (list symbol)) (find-package* package-designator)))
66 (defun shadowing-import* (symbol package-designator)
67 (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
68 (defun shadow* (name package-designator)
69 (shadow (list (string name)) (find-package* package-designator)))
70 (defun make-symbol* (name)
71 (etypecase name
72 (string (make-symbol name))
73 (symbol (copy-symbol name))))
74 (defun unintern* (name package-designator &optional (error t))
75 (block nil
76 (let ((package (find-package* package-designator error)))
77 (when package
78 (multiple-value-bind (symbol status) (find-symbol* name package error)
79 (cond
80 (status (unintern symbol package)
81 (return (values symbol status)))
82 (error (error "symbol ~A not present in package ~A"
83 (string symbol) (package-name package))))))
84 (values nil nil))))
85 (defun symbol-shadowing-p (symbol package)
86 (and (member symbol (package-shadowing-symbols package)) t))
87 (defun home-package-p (symbol package)
88 (and package (let ((sp (symbol-package symbol)))
89 (and sp (let ((pp (find-package* package)))
90 (and pp (eq sp pp))))))))
91
92
93 (eval-when (:load-toplevel :compile-toplevel :execute)
94 (defun symbol-package-name (symbol)
95 (let ((package (symbol-package symbol)))
96 (and package (package-name package))))
97 (defun standard-common-lisp-symbol-p (symbol)
98 (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
99 (and (eq sym symbol) (eq status :external))))
100 (defun reify-package (package &optional package-context)
101 (if (eq package package-context) t
102 (etypecase package
103 (null nil)
104 ((eql (find-package :cl)) :cl)
105 (package (package-name package)))))
106 (defun unreify-package (package &optional package-context)
107 (etypecase package
108 (null nil)
109 ((eql t) package-context)
110 ((or symbol string) (find-package package))))
111 (defun reify-symbol (symbol &optional package-context)
112 (etypecase symbol
113 ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
114 (symbol (vector (symbol-name symbol)
115 (reify-package (symbol-package symbol) package-context)))))
116 (defun unreify-symbol (symbol &optional package-context)
117 (etypecase symbol
118 (symbol symbol)
119 ((simple-vector 2)
120 (let* ((symbol-name (svref symbol 0))
121 (package-foo (svref symbol 1))
122 (package (unreify-package package-foo package-context)))
123 (if package (intern* symbol-name package)
124 (make-symbol* symbol-name)))))))
125
126 (eval-when (:load-toplevel :compile-toplevel :execute)
127 (defvar *all-package-happiness* '())
128 (defvar *all-package-fishiness* (list t))
129 (defun record-fishy (info)
130 ;;(format t "~&FISHY: ~S~%" info)
131 (push info *all-package-fishiness*))
132 (defmacro when-package-fishiness (&body body)
133 `(when *all-package-fishiness* ,@body))
134 (defmacro note-package-fishiness (&rest info)
135 `(when-package-fishiness (record-fishy (list ,@info)))))
136
137 (eval-when (:load-toplevel :compile-toplevel :execute)
138 #+(or clisp clozure)
139 (defun get-setf-function-symbol (symbol)
140 #+clisp (let ((sym (get symbol 'system::setf-function)))
141 (if sym (values sym :setf-function)
142 (let ((sym (get symbol 'system::setf-expander)))
143 (if sym (values sym :setf-expander)
144 (values nil nil)))))
145 #+clozure (gethash symbol ccl::%setf-function-names%))
146 #+(or clisp clozure)
147 (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
148 #+clisp (assert (member kind '(:setf-function :setf-expander)))
149 #+clozure (assert (eq kind t))
150 #+clisp
151 (cond
152 ((null new-setf-symbol)
153 (remprop symbol 'system::setf-function)
154 (remprop symbol 'system::setf-expander))
155 ((eq kind :setf-function)
156 (setf (get symbol 'system::setf-function) new-setf-symbol))
157 ((eq kind :setf-expander)
158 (setf (get symbol 'system::setf-expander) new-setf-symbol))
159 (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
160 kind symbol new-setf-symbol)))
161 #+clozure
162 (progn
163 (gethash symbol ccl::%setf-function-names%) new-setf-symbol
164 (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
165 #+(or clisp clozure)
166 (defun create-setf-function-symbol (symbol)
167 #+clisp (system::setf-symbol symbol)
168 #+clozure (ccl::construct-setf-function-name symbol))
169 (defun set-dummy-symbol (symbol reason other-symbol)
170 (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
171 (defun make-dummy-symbol (symbol)
172 (let ((dummy (copy-symbol symbol)))
173 (set-dummy-symbol dummy 'replacing symbol)
174 (set-dummy-symbol symbol 'replaced-by dummy)
175 dummy))
176 (defun dummy-symbol (symbol)
177 (get symbol 'dummy-symbol))
178 (defun get-dummy-symbol (symbol)
179 (let ((existing (dummy-symbol symbol)))
180 (if existing (values (cdr existing) (car existing))
181 (make-dummy-symbol symbol))))
182 (defun nuke-symbol-in-package (symbol package-designator)
183 (let ((package (find-package* package-designator))
184 (name (symbol-name symbol)))
185 (multiple-value-bind (sym stat) (find-symbol name package)
186 (when (and (member stat '(:internal :external)) (eq symbol sym))
187 (if (symbol-shadowing-p symbol package)
188 (shadowing-import* (get-dummy-symbol symbol) package)
189 (unintern* symbol package))))))
190 (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
191 #+(or clisp clozure)
192 (multiple-value-bind (setf-symbol kind)
193 (get-setf-function-symbol symbol)
194 (when kind (nuke-symbol setf-symbol)))
195 (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
196 (defun rehome-symbol (symbol package-designator)
197 "Changes the home package of a symbol, also leaving it present in its old home if any"
198 (let* ((name (symbol-name symbol))
199 (package (find-package* package-designator))
200 (old-package (symbol-package symbol))
201 (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
202 (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
203 (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
204 (unless (eq package old-package)
205 (let ((overwritten-symbol-shadowing-p
206 (and overwritten-symbol-status
207 (symbol-shadowing-p overwritten-symbol package))))
208 (note-package-fishiness
209 :rehome-symbol name
210 (when old-package (package-name old-package)) old-status (and shadowing t)
211 (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
212 (when old-package
213 (if shadowing
214 (shadowing-import* shadowing old-package))
215 (unintern* symbol old-package))
216 (cond
217 (overwritten-symbol-shadowing-p
218 (shadowing-import* symbol package))
219 (t
220 (when overwritten-symbol-status
221 (unintern* overwritten-symbol package))
222 (import* symbol package)))
223 (if shadowing
224 (shadowing-import* symbol old-package)
225 (import* symbol old-package))
226 #+(or clisp clozure)
227 (multiple-value-bind (setf-symbol kind)
228 (get-setf-function-symbol symbol)
229 (when kind
230 (let* ((setf-function (fdefinition setf-symbol))
231 (new-setf-symbol (create-setf-function-symbol symbol)))
232 (note-package-fishiness
233 :setf-function
234 name (package-name package)
235 (symbol-name setf-symbol) (symbol-package-name setf-symbol)
236 (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
237 (when (symbol-package setf-symbol)
238 (unintern* setf-symbol (symbol-package setf-symbol)))
239 (setf (fdefinition new-setf-symbol) setf-function)
240 (set-setf-function-symbol new-setf-symbol symbol kind))))
241 #+(or clisp clozure)
242 (multiple-value-bind (overwritten-setf foundp)
243 (get-setf-function-symbol overwritten-symbol)
244 (when foundp
245 (unintern overwritten-setf)))
246 (when (eq old-status :external)
247 (export* symbol old-package))
248 (when (eq overwritten-symbol-status :external)
249 (export* symbol package))))
250 (values overwritten-symbol overwritten-symbol-status))))
251 (defun ensure-package-unused (package)
252 (loop :for p :in (package-used-by-list package) :do
253 (unuse-package package p)))
254 (defun delete-package* (package &key nuke)
255 (let ((p (find-package package)))
256 (when p
257 (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
258 (ensure-package-unused p)
259 (delete-package package))))
260 (defun package-names (package)
261 (cons (package-name package) (package-nicknames package)))
262 (defun packages-from-names (names)
263 (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
264 (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
265 separator
266 (index (random most-positive-fixnum)))
267 (loop :for i :from index
268 :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
269 :thereis (and (not (find-package n)) n)))
270 (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
271 (let ((new-name
272 (apply 'fresh-package-name
273 :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
274 (record-fishy (list :rename-away (package-names p) new-name))
275 (rename-package p new-name))))
276
277
278 ;;; Communicable representation of symbol and package information
279
280 (eval-when (:load-toplevel :compile-toplevel :execute)
281 (defun package-definition-form (package-designator
282 &key (nicknamesp t) (usep t)
283 (shadowp t) (shadowing-import-p t)
284 (exportp t) (importp t) internp (error t))
285 (let* ((package (or (find-package* package-designator error)
286 (return-from package-definition-form nil)))
287 (name (package-name package))
288 (nicknames (package-nicknames package))
289 (use (mapcar #'package-name (package-use-list package)))
290 (shadow ())
291 (shadowing-import (make-hash-table :test 'equal))
292 (import (make-hash-table :test 'equal))
293 (export ())
294 (intern ()))
295 (when package
296 (loop :for sym :being :the :symbols :in package
297 :for status = (nth-value 1 (find-symbol* sym package)) :do
298 (ecase status
299 ((nil :inherited))
300 ((:internal :external)
301 (let* ((name (symbol-name sym))
302 (external (eq status :external))
303 (home (symbol-package sym))
304 (home-name (package-name home))
305 (imported (not (eq home package)))
306 (shadowing (symbol-shadowing-p sym package)))
307 (cond
308 ((and shadowing imported)
309 (push name (gethash home-name shadowing-import)))
310 (shadowing
311 (push name shadow))
312 (imported
313 (push name (gethash home-name import))))
314 (cond
315 (external
316 (push name export))
317 (imported)
318 (t (push name intern)))))))
319 (labels ((sort-names (names)
320 (sort (copy-list names) #'string<))
321 (table-keys (table)
322 (loop :for k :being :the :hash-keys :of table :collect k))
323 (when-relevant (key value)
324 (when value (list (cons key value))))
325 (import-options (key table)
326 (loop :for i :in (sort-names (table-keys table))
327 :collect `(,key ,i ,@(sort-names (gethash i table))))))
328 `(defpackage ,name
329 ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
330 (:use ,@(and usep (sort-names use)))
331 ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
332 ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
333 ,@(import-options :import-from (and importp import))
334 ,@(when-relevant :export (and exportp (sort-names export)))
335 ,@(when-relevant :intern (and internp (sort-names intern)))))))))
336
337
338 ;;; ensure-package, define-package
339 (eval-when (:load-toplevel :compile-toplevel :execute)
340 (defun ensure-shadowing-import (name to-package from-package shadowed imported)
341 (check-type name string)
342 (check-type to-package package)
343 (check-type from-package package)
344 (check-type shadowed hash-table)
345 (check-type imported hash-table)
346 (let ((import-me (find-symbol* name from-package)))
347 (multiple-value-bind (existing status) (find-symbol name to-package)
348 (cond
349 ((gethash name shadowed)
350 (unless (eq import-me existing)
351 (error "Conflicting shadowings for ~A" name)))
352 (t
353 (setf (gethash name shadowed) t)
354 (setf (gethash name imported) t)
355 (unless (or (null status)
356 (and (member status '(:internal :external))
357 (eq existing import-me)
358 (symbol-shadowing-p existing to-package)))
359 (note-package-fishiness
360 :shadowing-import name
361 (package-name from-package)
362 (or (home-package-p import-me from-package) (symbol-package-name import-me))
363 (package-name to-package) status
364 (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
365 (shadowing-import* import-me to-package))))))
366 (defun ensure-imported (import-me into-package &optional from-package)
367 (check-type import-me symbol)
368 (check-type into-package package)
369 (check-type from-package (or null package))
370 (let ((name (symbol-name import-me)))
371 (multiple-value-bind (existing status) (find-symbol name into-package)
372 (cond
373 ((not status)
374 (import* import-me into-package))
375 ((eq import-me existing))
376 (t
377 (let ((shadowing-p (symbol-shadowing-p existing into-package)))
378 (note-package-fishiness
379 :ensure-imported name
380 (and from-package (package-name from-package))
381 (or (home-package-p import-me from-package) (symbol-package-name import-me))
382 (package-name into-package)
383 status
384 (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
385 shadowing-p)
386 (cond
387 ((or shadowing-p (eq status :inherited))
388 (shadowing-import* import-me into-package))
389 (t
390 (unintern* existing into-package)
391 (import* import-me into-package))))))))
392 (values))
393 (defun ensure-import (name to-package from-package shadowed imported)
394 (check-type name string)
395 (check-type to-package package)
396 (check-type from-package package)
397 (check-type shadowed hash-table)
398 (check-type imported hash-table)
399 (multiple-value-bind (import-me import-status) (find-symbol name from-package)
400 (when (null import-status)
401 (note-package-fishiness
402 :import-uninterned name (package-name from-package) (package-name to-package))
403 (setf import-me (intern* name from-package)))
404 (multiple-value-bind (existing status) (find-symbol name to-package)
405 (cond
406 ((and imported (gethash name imported))
407 (unless (and status (eq import-me existing))
408 (error "Can't import ~S from both ~S and ~S"
409 name (package-name (symbol-package existing)) (package-name from-package))))
410 ((gethash name shadowed)
411 (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
412 (t
413 (setf (gethash name imported) t))))
414 (ensure-imported import-me to-package from-package)))
415 (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
416 (check-type name string)
417 (check-type symbol symbol)
418 (check-type to-package package)
419 (check-type from-package package)
420 (check-type mixp (member nil t)) ; no cl:boolean on Genera
421 (check-type shadowed hash-table)
422 (check-type imported hash-table)
423 (check-type inherited hash-table)
424 (multiple-value-bind (existing status) (find-symbol name to-package)
425 (let* ((sp (symbol-package symbol))
426 (in (gethash name inherited))
427 (xp (and status (symbol-package existing))))
428 (when (null sp)
429 (note-package-fishiness
430 :import-uninterned name
431 (package-name from-package) (package-name to-package) mixp)
432 (import* symbol from-package)
433 (setf sp (package-name from-package)))
434 (cond
435 ((gethash name shadowed))
436 (in
437 (unless (equal sp (first in))
438 (if mixp
439 (ensure-shadowing-import name to-package (second in) shadowed imported)
440 (error "Can't inherit ~S from ~S, it is inherited from ~S"
441 name (package-name sp) (package-name (first in))))))
442 ((gethash name imported)
443 (unless (eq symbol existing)
444 (error "Can't inherit ~S from ~S, it is imported from ~S"
445 name (package-name sp) (package-name xp))))
446 (t
447 (setf (gethash name inherited) (list sp from-package))
448 (when (and status (not (eq sp xp)))
449 (let ((shadowing (symbol-shadowing-p existing to-package)))
450 (note-package-fishiness
451 :inherited name
452 (package-name from-package)
453 (or (home-package-p symbol from-package) (symbol-package-name symbol))
454 (package-name to-package)
455 (or (home-package-p existing to-package) (symbol-package-name existing)))
456 (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
457 (unintern* existing to-package)))))))))
458 (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
459 (check-type name string)
460 (check-type symbol symbol)
461 (check-type to-package package)
462 (check-type from-package package)
463 (check-type shadowed hash-table)
464 (check-type imported hash-table)
465 (check-type inherited hash-table)
466 (unless (gethash name shadowed)
467 (multiple-value-bind (existing status) (find-symbol name to-package)
468 (let* ((sp (symbol-package symbol))
469 (im (gethash name imported))
470 (in (gethash name inherited)))
471 (cond
472 ((or (null status)
473 (and status (eq symbol existing))
474 (and in (eq sp (first in))))
475 (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
476 (in
477 (remhash name inherited)
478 (ensure-shadowing-import name to-package (second in) shadowed imported))
479 (im
480 (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
481 name (package-name from-package)
482 (home-package-p symbol from-package) (symbol-package-name symbol)
483 (package-name to-package)
484 (home-package-p existing to-package) (symbol-package-name existing)))
485 (t
486 (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
487
488 (defun recycle-symbol (name recycle exported)
489 ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
490 ;; packages, and a hash-table of names (strings) of symbols scheduled to be
491 ;; EXPORTED from the package being defined. It returns two values, the
492 ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
493 ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the
494 ;; re-homing of the symbol, etc.
495 (check-type name string)
496 (check-type recycle list)
497 (check-type exported hash-table)
498 (when (gethash name exported) ;; don't bother recycling private symbols
499 (let (recycled foundp)
500 (dolist (r recycle (values recycled foundp))
501 (multiple-value-bind (symbol status) (find-symbol name r)
502 (when (and status (home-package-p symbol r))
503 (cond
504 (foundp
505 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
506 (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
507 (t
508 (setf recycled symbol foundp r)))))))))
509 (defun symbol-recycled-p (sym recycle)
510 (check-type sym symbol)
511 (check-type recycle list)
512 (and (member (symbol-package sym) recycle) t))
513 (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
514 (check-type name string)
515 (check-type package package)
516 (check-type intern (member nil t)) ; no cl:boolean on Genera
517 (check-type shadowed hash-table)
518 (check-type imported hash-table)
519 (check-type inherited hash-table)
520 (unless (or (gethash name shadowed)
521 (gethash name imported)
522 (gethash name inherited))
523 (multiple-value-bind (existing status)
524 (find-symbol name package)
525 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
526 (cond
527 ((and status (eq existing recycled) (eq previous package)))
528 (previous
529 (rehome-symbol recycled package))
530 ((and status (eq package (symbol-package existing))))
531 (t
532 (when status
533 (note-package-fishiness
534 :ensure-symbol name
535 (reify-package (symbol-package existing) package)
536 status intern)
537 (unintern existing))
538 (when intern
539 (intern* name package))))))))
540 (declaim (ftype (function (t t t &optional t) t) ensure-exported))
541 (defun ensure-exported-to-user (name symbol to-package &optional recycle)
542 (check-type name string)
543 (check-type symbol symbol)
544 (check-type to-package package)
545 (check-type recycle list)
546 (assert (equal name (symbol-name symbol)))
547 (multiple-value-bind (existing status) (find-symbol name to-package)
548 (unless (and status (eq symbol existing))
549 (let ((accessible
550 (or (null status)
551 (let ((shadowing (symbol-shadowing-p existing to-package))
552 (recycled (symbol-recycled-p existing recycle)))
553 (unless (and shadowing (not recycled))
554 (note-package-fishiness
555 :ensure-export name (symbol-package-name symbol)
556 (package-name to-package)
557 (or (home-package-p existing to-package) (symbol-package-name existing))
558 status shadowing)
559 (if (or (eq status :inherited) shadowing)
560 (shadowing-import* symbol to-package)
561 (unintern existing to-package))
562 t)))))
563 (when (and accessible (eq status :external))
564 (ensure-exported name symbol to-package recycle))))))
565 (defun ensure-exported (name symbol from-package &optional recycle)
566 (dolist (to-package (package-used-by-list from-package))
567 (ensure-exported-to-user name symbol to-package recycle))
568 (unless (eq from-package (symbol-package symbol))
569 (ensure-imported symbol from-package))
570 (export* name from-package))
571 (defun ensure-export (name from-package &optional recycle)
572 (multiple-value-bind (symbol status) (find-symbol* name from-package)
573 (unless (eq status :external)
574 (ensure-exported name symbol from-package recycle))))
575 (defun ensure-package (name &key
576 nicknames documentation use
577 shadow shadowing-import-from
578 import-from export intern
579 recycle mix reexport
580 unintern)
581 #+genera (declare (ignore documentation))
582 (let* ((package-name (string name))
583 (nicknames (mapcar #'string nicknames))
584 (names (cons package-name nicknames))
585 (previous (packages-from-names names))
586 (discarded (cdr previous))
587 (to-delete ())
588 (package (or (first previous) (make-package package-name :nicknames nicknames)))
589 (recycle (packages-from-names recycle))
590 (use (mapcar 'find-package* use))
591 (mix (mapcar 'find-package* mix))
592 (reexport (mapcar 'find-package* reexport))
593 (shadow (mapcar 'string shadow))
594 (export (mapcar 'string export))
595 (intern (mapcar 'string intern))
596 (unintern (mapcar 'string unintern))
597 (shadowed (make-hash-table :test 'equal)) ; string to bool
598 (imported (make-hash-table :test 'equal)) ; string to bool
599 (exported (make-hash-table :test 'equal)) ; string to bool
600 ;; string to list home package and use package:
601 (inherited (make-hash-table :test 'equal)))
602 (when-package-fishiness (record-fishy package-name))
603 #-genera
604 (when documentation (setf (documentation package t) documentation))
605 (loop :for p :in (set-difference (package-use-list package) (append mix use))
606 :do (note-package-fishiness :over-use name (package-names p))
607 (unuse-package p package))
608 (loop :for p :in discarded
609 :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
610 (package-names p))
611 :do (note-package-fishiness :nickname name (package-names p))
612 (cond (n (rename-package p (first n) (rest n)))
613 (t (rename-package-away p)
614 (push p to-delete))))
615 (rename-package package package-name nicknames)
616 (dolist (name unintern)
617 (multiple-value-bind (existing status) (find-symbol name package)
618 (when status
619 (unless (eq status :inherited)
620 (note-package-fishiness
621 :unintern (package-name package) name (symbol-package-name existing) status)
622 (unintern* name package nil)))))
623 (dolist (name export)
624 (setf (gethash name exported) t))
625 (dolist (p reexport)
626 (do-external-symbols (sym p)
627 (setf (gethash (string sym) exported) t)))
628 (do-external-symbols (sym package)
629 (let ((name (symbol-name sym)))
630 (unless (gethash name exported)
631 (note-package-fishiness
632 :over-export (package-name package) name
633 (or (home-package-p sym package) (symbol-package-name sym)))
634 (unexport sym package))))
635 (dolist (name shadow)
636 (setf (gethash name shadowed) t)
637 (multiple-value-bind (existing status) (find-symbol name package)
638 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
639 (let ((shadowing (and status (symbol-shadowing-p existing package))))
640 (cond
641 ((eq previous package))
642 (previous
643 (rehome-symbol recycled package))
644 ((or (member status '(nil :inherited))
645 (home-package-p existing package)))
646 (t
647 (let ((dummy (make-symbol name)))
648 (note-package-fishiness
649 :shadow-imported (package-name package) name
650 (symbol-package-name existing) status shadowing)
651 (shadowing-import* dummy package)
652 (import* dummy package)))))))
653 (shadow* name package))
654 (loop :for (p . syms) :in shadowing-import-from
655 :for pp = (find-package* p) :do
656 (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
657 (loop :for p :in mix
658 :for pp = (find-package* p) :do
659 (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
660 (loop :for (p . syms) :in import-from
661 :for pp = (find-package p) :do
662 (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
663 (dolist (p (append use mix))
664 (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
665 (use-package p package))
666 (loop :for name :being :the :hash-keys :of exported :do
667 (ensure-symbol name package t recycle shadowed imported inherited exported)
668 (ensure-export name package recycle))
669 (dolist (name intern)
670 (ensure-symbol name package t recycle shadowed imported inherited exported))
671 (do-symbols (sym package)
672 (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
673 (map () 'delete-package* to-delete)
674 package)))
675
676 (eval-when (:load-toplevel :compile-toplevel :execute)
677 (defun parse-define-package-form (package clauses)
678 (loop
679 :with use-p = nil :with recycle-p = nil
680 :with documentation = nil
681 :for (kw . args) :in clauses
682 :when (eq kw :nicknames) :append args :into nicknames :else
683 :when (eq kw :documentation)
684 :do (cond
685 (documentation (error "define-package: can't define documentation twice"))
686 ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
687 (t (setf documentation (car args)))) :else
688 :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
689 :when (eq kw :shadow) :append args :into shadow :else
690 :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
691 :when (eq kw :import-from) :collect args :into import-from :else
692 :when (eq kw :export) :append args :into export :else
693 :when (eq kw :intern) :append args :into intern :else
694 :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
695 :when (eq kw :mix) :append args :into mix :else
696 :when (eq kw :reexport) :append args :into reexport :else
697 :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
698 :and :do (setf use-p t) :else
699 :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
700 :and :do (setf use-p t) :else
701 :when (eq kw :unintern) :append args :into unintern :else
702 :do (error "unrecognized define-package keyword ~S" kw)
703 :finally (return `(',package
704 :nicknames ',nicknames :documentation ',documentation
705 :use ',(if use-p use '(:common-lisp))
706 :shadow ',shadow :shadowing-import-from ',shadowing-import-from
707 :import-from ',import-from :export ',export :intern ',intern
708 :recycle ',(if recycle-p recycle (cons package nicknames))
709 :mix ',mix :reexport ',reexport :unintern ',unintern)))))
710
711 (defmacro define-package (package &rest clauses)
712 "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
713 \(KEYWORD . ARGS\).
714 DEFINE-PACKAGE supports the following keywords:
715 USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE.
716 RECYCLE -- Recycle the package's exported symbols from the specified packages,
717 in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE,
718 either through an :EXPORT option or a :REEXPORT option, if the symbol exists in
719 one of the :RECYCLE packages, the first such symbol is re-homed to the package
720 being defined.
721 For the sake of idempotence, it is important that the package being defined
722 should appear in first position if it already exists, and even if it doesn't,
723 ahead of any package that is not going to be deleted afterwards and never
724 created again. In short, except for special cases, always make it the first
725 package on the list if the list is not empty.
726 MIX -- Takes a list of package designators. MIX behaves like
727 \(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
728 resolve conflicts in favor of the first found symbol. It may still yield
729 an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
730 REEXPORT -- Takes a list of package designators. For each package, p, in the list,
731 export symbols with the same name as those exported from p. Note that in the case
732 of shadowing, etc. the symbols with the same name may not be the same symbols.
733 UNINTERN -- Remove symbols here from PACKAGE."
734 (let ((ensure-form
735 `(prog1
736 (funcall 'ensure-package ,@(parse-define-package-form package clauses))
737 #+sbcl (setf (sb-impl::package-source-location (find-package ',package))
738 (sb-c:source-location)))))
739 `(progn
740 #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
741 (eval-when (:compile-toplevel :load-toplevel :execute)
742 ,ensure-form))))