package.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
package.lisp (37546B) | |
--- | |
1 ;;;; -------------------------------------------------------------------… | |
2 ;;;; Handle ASDF package upgrade, including implementation-dependent mag… | |
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-up… | |
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 … | |
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 diffe… | |
14 (:use :common-lisp) | |
15 (:export | |
16 #:find-package* #:find-symbol* #:symbol-call | |
17 #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-sy… | |
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-p… | |
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… | |
49 (cond | |
50 (status (return (values symbol status))) | |
51 (error (error "There is no symbol ~S in package ~S" name (… | |
52 (values nil nil)))) | |
53 (defun symbol-call (package name &rest args) | |
54 "Call a function associated with symbol of given name in given packa… | |
55 with given ARGS. Useful when the call is read before the package is load… | |
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-d… | |
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 packag… | |
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 … | |
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-con… | |
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%) symbo… | |
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 it… | |
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 o… | |
202 (shadowing (and old-package (symbol-shadowing-p symbol old-pa… | |
203 (multiple-value-bind (overwritten-symbol overwritten-symbol-status… | |
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 (a… | |
211 (package-name package) overwritten-symbol-status overwritte… | |
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 sym… | |
232 (note-package-fishiness | |
233 :setf-function | |
234 name (package-name package) | |
235 (symbol-name setf-symbol) (symbol-package-name setf-s… | |
236 (symbol-name new-setf-symbol) (symbol-package-name ne… | |
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-sy… | |
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-… | |
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 s… | |
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… | |
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 (err… | |
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 :collec… | |
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 tab… | |
328 `(defpackage ,name | |
329 ,@(when-relevant :nicknames (and nicknamesp (sort-names nic… | |
330 (:use ,@(and usep (sort-names use))) | |
331 ,@(when-relevant :shadow (and shadowp (sort-names shadow))) | |
332 ,@(import-options :shadowing-import-from (and shadowing-imp… | |
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 … | |
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-packag… | |
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-packag… | |
363 (package-name to-package) status | |
364 (and status (or (home-package-p existing to-package) (symb… | |
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-pack… | |
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-packag… | |
382 (package-name into-package) | |
383 status | |
384 (and status (or (home-package-p existing into-package) (sy… | |
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 fro… | |
400 (when (null import-status) | |
401 (note-package-fishiness | |
402 :import-uninterned name (package-name from-package) (package-na… | |
403 (setf import-me (intern* name from-package))) | |
404 (multiple-value-bind (existing status) (find-symbol name to-packag… | |
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)) (packa… | |
410 ((gethash name shadowed) | |
411 (error "Can't both shadow ~S and import it from ~S" name (pac… | |
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 shad… | |
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) sh… | |
440 (error "Can't inherit ~S from ~S, it is inherited from … | |
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… | |
454 (package-name to-package) | |
455 (or (home-package-p existing to-package) (symbol-package… | |
456 (if shadowing (ensure-shadowing-import name to-package fr… | |
457 (unintern* existing to-package))))))))) | |
458 (defun ensure-mix (name symbol to-package from-package shadowed import… | |
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-packag… | |
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 sha… | |
476 (in | |
477 (remhash name inherited) | |
478 (ensure-shadowing-import name to-package (second in) shadow… | |
479 (im | |
480 (error "Symbol ~S import from ~S~:[~; actually ~:[uninterne… | |
481 name (package-name from-package) | |
482 (home-package-p symbol from-package) (symbol-package… | |
483 (package-name to-package) | |
484 (home-package-p existing to-package) (symbol-package… | |
485 (t | |
486 (ensure-inherited name symbol to-package from-package t sha… | |
487 | |
488 (defun recycle-symbol (name recycle exported) | |
489 ;; Takes a symbol NAME (a string), a list of package designators for… | |
490 ;; packages, and a hash-table of names (strings) of symbols schedule… | |
491 ;; EXPORTED from the package being defined. It returns two values, t… | |
492 ;; symbol found (if any, or else NIL), and a boolean flag indicating… | |
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 symb… | |
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 … | |
506 (note-package-fishiness :recycled-duplicate name (packa… | |
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 in… | |
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 re… | |
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 recyc… | |
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-pac… | |
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) (symbo… | |
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 :nic… | |
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) (appen… | |
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 'equ… | |
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-nam… | |
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 … | |
639 (let ((shadowing (and status (symbol-shadowing-p existing pa… | |
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) p… | |
657 (loop :for p :in mix | |
658 :for pp = (find-package* p) :do | |
659 (do-external-symbols (sym pp) (ensure-mix (symbol-name sym… | |
660 (loop :for (p . syms) :in import-from | |
661 :for pp = (find-package p) :do | |
662 (dolist (sym syms) (ensure-import (symbol-name sym) packag… | |
663 (dolist (p (append use mix)) | |
664 (do-external-symbols (sym p) (ensure-inherited (string sym) sym … | |
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 inherite… | |
668 (ensure-export name package recycle)) | |
669 (dolist (name intern) | |
670 (ensure-symbol name package t recycle shadowed imported inherite… | |
671 (do-symbols (sym package) | |
672 (ensure-symbol (symbol-name sym) package nil recycle shadowed im… | |
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 docume… | |
686 ((or (atom args) (cdr args)) (error "define-package: bad d… | |
687 (t (setf documentation (car args)))) :else | |
688 :when (eq kw :use) :append args :into use :and :do (setf use-p t) … | |
689 :when (eq kw :shadow) :append args :into shadow :else | |
690 :when (eq kw :shadowing-import-from) :collect args :into shadowing… | |
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 r… | |
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 ar… | |
698 :and :do (setf use-p t) :else | |
699 :when (eq kw :mix-reexport) :append args :into mix :and :append ar… | |
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 ',documen… | |
705 :use ',(if use-p use '(:common-lisp)) | |
706 :shadow ',shadow :shadowing-import-from ',shado… | |
707 :import-from ',import-from :export ',export :in… | |
708 :recycle ',(if recycle-p recycle (cons package … | |
709 :mix ',mix :reexport ',reexport :unintern ',uni… | |
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 pe… | |
716 RECYCLE -- Recycle the package's exported symbols from the specified pac… | |
717 in order. For every symbol scheduled to be exported by the DEFINE-PACKA… | |
718 either through an :EXPORT option or a :REEXPORT option, if the symbol ex… | |
719 one of the :RECYCLE packages, the first such symbol is re-homed to the p… | |
720 being defined. | |
721 For the sake of idempotence, it is important that the package being defi… | |
722 should appear in first position if it already exists, and even if it doe… | |
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 fi… | |
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… | |
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, i… | |
731 export symbols with the same name as those exported from p. Note that i… | |
732 of shadowing, etc. the symbols with the same name may not be the same sy… | |
733 UNINTERN -- Remove symbols here from PACKAGE." | |
734 (let ((ensure-form | |
735 `(prog1 | |
736 (funcall 'ensure-package ,@(parse-define-package-form pack… | |
737 #+sbcl (setf (sb-impl::package-source-location (find-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)))) |