Coverage report: /home/ellis/comp/core/std/defpkg.lisp

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