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