Silence notes about being specialised EQ templates on x86oids
[sbcl.git] / src / code / defpackage.lisp
1 ;;;; the DEFPACKAGE macro
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!IMPL")
13
14 ;;; the list of packages to use by default when no :USE argument is
15 ;;; supplied to MAKE-PACKAGE or other package creation forms
16 ;;;
17 ;;; ANSI specifies (1) that MAKE-PACKAGE and DEFPACKAGE use the same
18 ;;; value, and (2) that it (as an implementation-defined value) should
19 ;;; be documented, which we do in the doc string. So for OAOO reasons
20 ;;; we represent this value as a variable only at compile time, and
21 ;;; then use #. readmacro hacks to splice it into the target code as a
22 ;;; constant.
23 (eval-when (:compile-toplevel)
24   (defparameter *default-package-use-list*
25     ;; ANSI says this is implementation-defined. So we make it NIL,
26     ;; the way God intended. Anyone who actually wants a random value
27     ;; is free to :USE (PACKAGE-USE-LIST :CL-USER) anyway.:-|
28     nil))
29
30 (defmacro defpackage (package &rest options)
31   #!+sb-doc
32   #.(format nil
33   "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
34    following: ~{~&~4T~A~}
35    All options except ~{~A, ~}and :DOCUMENTATION can be used multiple
36    times."
37   '((:use "{package-name}*")
38     (:export "{symbol-name}*")
39     (:import-from "<package-name> {symbol-name}*")
40     (:shadow "{symbol-name}*")
41     (:shadowing-import-from "<package-name> {symbol-name}*")
42     (:local-nicknames "{local-nickname actual-package-name}*")
43     #!+sb-package-locks (:lock "boolean")
44     #!+sb-package-locks (:implement "{package-name}*")
45     (:documentation "doc-string")
46     (:intern "{symbol-name}*")
47     (:size "<integer>")
48     (:nicknames "{package-name}*"))
49   '(:size #!+sb-package-locks :lock))
50   (let ((nicknames nil)
51         (local-nicknames nil)
52         (size nil)
53         (shadows nil)
54         (shadowing-imports nil)
55         (use nil)
56         (use-p nil)
57         (imports nil)
58         (interns nil)
59         (exports nil)
60         (implement (stringify-package-designators (list package)))
61         (implement-p nil)
62         (lock nil)
63         (doc nil))
64     #!-sb-package-locks
65     (declare (ignore implement-p))
66     (dolist (option options)
67       (unless (consp option)
68         (error 'simple-program-error
69                :format-control "bogus DEFPACKAGE option: ~S"
70                :format-arguments (list option)))
71       (case (car option)
72         (:nicknames
73          (setf nicknames (stringify-package-designators (cdr option))))
74         (:local-nicknames
75          (setf local-nicknames
76                (append local-nicknames
77                        (mapcar (lambda (spec)
78                                  (destructuring-bind (nick name) spec
79                                    (cons (stringify-package-designator nick)
80                                          (stringify-package-designator name))))
81                                (cdr option)))))
82         (:size
83          (cond (size
84                 (error 'simple-program-error
85                        :format-control "can't specify :SIZE twice."))
86                ((and (consp (cdr option))
87                      (typep (second option) 'unsigned-byte))
88                 (setf size (second option)))
89                (t
90                 (error
91                  'simple-program-error
92                  :format-control ":SIZE is not a positive integer: ~S"
93                  :format-arguments (list (second option))))))
94         (:shadow
95          (let ((new (stringify-string-designators (cdr option))))
96            (setf shadows (append shadows new))))
97         (:shadowing-import-from
98          (let ((package-name (stringify-package-designator (second option)))
99                (names (stringify-string-designators (cddr option))))
100            (let ((assoc (assoc package-name shadowing-imports
101                                :test #'string=)))
102              (if assoc
103                  (setf (cdr assoc) (append (cdr assoc) names))
104                  (setf shadowing-imports
105                        (acons package-name names shadowing-imports))))))
106         (:use
107          (setf use (append use (stringify-package-designators (cdr option)) )
108                use-p t))
109         (:import-from
110          (let ((package-name (stringify-package-designator (second option)))
111                (names (stringify-string-designators (cddr option))))
112            (let ((assoc (assoc package-name imports
113                                :test #'string=)))
114              (if assoc
115                  (setf (cdr assoc) (append (cdr assoc) names))
116                  (setf imports (acons package-name names imports))))))
117         (:intern
118          (let ((new (stringify-string-designators (cdr option))))
119            (setf interns (append interns new))))
120         (:export
121          (let ((new (stringify-string-designators (cdr option))))
122            (setf exports (append exports new))))
123         #!+sb-package-locks
124         (:implement
125          (unless implement-p
126            (setf implement nil))
127          (let ((new (stringify-package-designators (cdr option))))
128            (setf implement (append implement new)
129                  implement-p t)))
130         #!+sb-package-locks
131         (:lock
132          (when lock
133            (error 'simple-program-error
134                   :format-control "multiple :LOCK options"))
135          (setf lock (coerce (second option) 'boolean)))
136         (:documentation
137          (when doc
138            (error 'simple-program-error
139                   :format-control "multiple :DOCUMENTATION options"))
140          (setf doc (coerce (second option) 'simple-string)))
141         (t
142          (error 'simple-program-error
143                 :format-control "bogus DEFPACKAGE option: ~S"
144                 :format-arguments (list option)))))
145     (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
146     (check-disjoint `(:intern ,@interns)
147                     `(:import-from
148                       ,@(apply #'append (mapcar #'rest imports)))
149                     `(:shadow ,@shadows)
150                     `(:shadowing-import-from
151                       ,@(apply #'append (mapcar #'rest shadowing-imports))))
152     `(eval-when (:compile-toplevel :load-toplevel :execute)
153        (%defpackage ,(stringify-string-designator package) ',nicknames ',size
154                     ',shadows ',shadowing-imports ',(if use-p use :default)
155                     ',imports ',interns ',exports ',implement ',local-nicknames
156                     ',lock ',doc
157                     (sb!c:source-location)))))
158
159 (defun check-disjoint (&rest args)
160   ;; An arg is (:key . set)
161   (do ((list args (cdr list)))
162       ((endp list))
163     (loop
164       with x = (car list)
165       for y in (rest list)
166       for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
167       when z do (error 'simple-program-error
168                        :format-control "Parameters ~S and ~S must be disjoint ~
169                                         but have common elements ~%   ~S"
170                        :format-arguments (list (car x)(car y) z)))))
171
172 (defun stringify-string-designator (string-designator)
173   (typecase string-designator
174     (simple-string string-designator)
175     (string (coerce string-designator 'simple-string))
176     (symbol (symbol-name string-designator))
177     (character (string string-designator))
178     (t
179      (error "~S does not designate a string" string-designator))))
180
181 (defun stringify-string-designators (string-designators)
182   (mapcar #'stringify-string-designator string-designators))
183
184 (defun stringify-package-designator (package-designator)
185   (typecase package-designator
186     (simple-string package-designator)
187     (string (coerce package-designator 'simple-string))
188     (symbol (symbol-name package-designator))
189     (character (string package-designator))
190     (package (package-name package-designator))
191     (t
192      (error "~S does not designate a package" package-designator))))
193
194 (defun stringify-package-designators (package-designators)
195   (mapcar #'stringify-package-designator package-designators))
196
197 (defun import-list-symbols (import-list)
198   (let ((symbols nil))
199     (dolist (import import-list symbols)
200       (destructuring-bind (package-name &rest symbol-names)
201           import
202         (let ((package (find-undeleted-package-or-lose package-name)))
203           (mapcar (lambda (name)
204                     (push (find-or-make-symbol name package) symbols))
205                   symbol-names))))))
206
207 (defun use-list-packages (package package-designators)
208   (cond ((listp package-designators)
209          (mapcar #'find-undeleted-package-or-lose package-designators))
210         (package
211          ;; :default for an existing package means preserve the
212          ;; existing use list
213          (package-use-list package))
214         (t
215          ;; :default for a new package is the *default-package-use-list*
216          '#.*default-package-use-list*)))
217
218 (defun update-package (package nicknames source-location
219                        shadows shadowing-imports
220                        use
221                        imports interns
222                        exports implement local-nicknames
223                        lock doc-string)
224   (declare #!-sb-package-locks
225            (ignore implement lock))
226   (%enter-new-nicknames package nicknames)
227   ;; 1. :shadow and :shadowing-import-from
228   ;;
229   ;; shadows is a list of strings, shadowing-imports is a list of symbols.
230   (shadow shadows package)
231   (shadowing-import shadowing-imports package)
232   ;; 2. :use
233   ;;
234   ;; use is a list of package objects.
235   (use-package use package)
236   ;; 3. :import-from and :intern
237   ;;
238   ;; imports is a list of symbols. interns is a list of strings.
239   (import imports package)
240   (dolist (intern interns)
241     (intern intern package))
242   ;; 4. :export
243   ;;
244   ;; exports is a list of strings
245   (export (mapcar (lambda (symbol-name) (intern symbol-name package))
246                   exports)
247           package)
248   ;; Everything was created: update metadata
249   (sb!c:with-source-location (source-location)
250     (setf (package-source-location package) source-location))
251   (setf (package-doc-string package) doc-string)
252   #!+sb-package-locks
253   (progn
254     ;; Handle packages this is an implementation package of
255     (dolist (p implement)
256       (add-implementation-package package p))
257     ;; Handle lock
258     (setf (package-lock package) lock))
259   ;; Local nicknames. Throw out the old ones.
260   (setf (package-%local-nicknames package) nil)
261   (dolist (spec local-nicknames)
262     (add-package-local-nickname (car spec) (cdr spec) package))
263   package)
264
265 (declaim (type list *on-package-variance*))
266 (defvar *on-package-variance* '(:warn t)
267   "Specifies behavior when redefining a package using DEFPACKAGE and the
268 definition is in variance with the current state of the package.
269
270 The value should be of the form:
271
272   (:WARN [T | packages-names] :ERROR [T | package-names])
273
274 specifying which packages get which behaviour -- with T signifying the default unless
275 otherwise specified. If default is not specified, :WARN is used.
276
277 :WARN keeps as much state as possible and causes SBCL to signal a full warning.
278
279 :ERROR causes SBCL to signal an error when the variant DEFPACKAGE form is executed,
280 with restarts provided for user to specify what action should be taken.
281
282 Example:
283
284   (setf *on-package-variance* '(:warn (:swank :swank-backend) :error t))
285
286 specifies to signal a warning if SWANK package is in variance, and an error otherwise.")
287
288 (defun note-package-variance (&rest args &key package &allow-other-keys)
289   (let ((pname (package-name package)))
290     (destructuring-bind (&key warn error) *on-package-variance*
291       (let ((what (cond ((and (listp error) (member pname error :test #'string=))
292                          :error)
293                         ((and (listp warn) (member pname warn :test #'string=))
294                          :warn)
295                         ((eq t error)
296                          :error)
297                         (t
298                          :warn))))
299         (ecase what
300           (:error
301            (apply #'error 'sb!kernel::package-at-variance-error args))
302           (:warn
303            (apply #'warn 'sb!kernel::package-at-variance args)))))))
304
305 (defun update-package-with-variance (package name nicknames source-location
306                                      shadows shadowing-imports
307                                      use
308                                      imports interns
309                                      exports
310                                      implement local-nicknames
311                                      lock doc-string)
312   (unless (string= (the string (package-name package)) name)
313     (error 'simple-package-error
314            :package name
315            :format-control "~A is a nickname for the package ~A"
316            :format-arguments (list name (package-name name))))
317   (let ((no-longer-shadowed
318           (set-difference (package-%shadowing-symbols package)
319                           (append shadows shadowing-imports)
320                           :test #'string=)))
321     (when no-longer-shadowed
322       (restart-case
323           (let ((*package* (find-package :keyword)))
324             (note-package-variance
325              :format-control "~A also shadows the following symbols:~%  ~S"
326              :format-arguments (list name no-longer-shadowed)
327              :package package))
328         (drop-them ()
329           :report "Stop shadowing them by uninterning them."
330           (dolist (sym no-longer-shadowed)
331             (unintern sym package)))
332         (keep-them ()
333           :report "Keep shadowing them."))))
334   (let ((no-longer-used (set-difference (package-use-list package) use)))
335     (when no-longer-used
336       (restart-case
337           (note-package-variance
338            :format-control "~A also uses the following packages:~%  ~A"
339            :format-arguments (list name (mapcar #'package-name no-longer-used))
340            :package package)
341         (drop-them ()
342           :report "Stop using them."
343           (unuse-package no-longer-used package))
344         (keep-them ()
345           :report "Keep using them."))))
346   (let (old-exports)
347     (do-external-symbols (s package)
348       (push s old-exports))
349     (let ((no-longer-exported (set-difference old-exports exports :test #'string=)))
350      (when no-longer-exported
351        (restart-case
352            (note-package-variance
353             :format-control "~A also exports the following symbols:~%  ~S"
354             :format-arguments (list name no-longer-exported)
355             :package package)
356          (drop-them ()
357            :report "Unexport them."
358            (unexport no-longer-exported package))
359          (keep-them ()
360            :report "Keep exporting them.")))))
361   (let ((old-implements
362           (set-difference (package-implements-list package)
363                           (mapcar #'find-undeleted-package-or-lose implement))))
364     (when old-implements
365       (restart-case
366           (note-package-variance
367            :format-control "~A is also an implementation package for:~% ~{~S~^~%  ~}"
368            :format-arguments (list name old-implements)
369            :package package)
370         (drop-them ()
371           :report "Stop being an implementation package for them."
372           (dolist (p old-implements)
373             (remove-implementation-package package p)))
374         (keep-them ()
375           :report "Keep exporting them."))))
376   (update-package package nicknames source-location
377                   shadows shadowing-imports
378                   use imports interns exports
379                   implement local-nicknames
380                   lock doc-string))
381
382 (defun %defpackage (name nicknames size shadows shadowing-imports
383                     use imports interns exports implement local-nicknames
384                     lock doc-string
385                     source-location)
386   (declare (type simple-string name)
387            (type list nicknames shadows shadowing-imports
388                  imports interns exports)
389            (type (or list (member :default)) use)
390            (type (or simple-string null) doc-string)
391            #!-sb-package-locks
392            (ignore implement lock))
393   (with-package-graph ()
394     (let* ((existing-package (find-package name))
395            (use (use-list-packages existing-package use))
396            (shadowing-imports (import-list-symbols shadowing-imports))
397            (imports (import-list-symbols imports)))
398       (if existing-package
399           (update-package-with-variance existing-package name
400                                         nicknames source-location
401                                         shadows shadowing-imports
402                                         use imports interns exports
403                                         implement local-nicknames
404                                         lock doc-string)
405           (let ((package (make-package name
406                                        :use nil
407                                        :internal-symbols (or size 10)
408                                        :external-symbols (length exports))))
409             (update-package package
410                             nicknames
411                             source-location
412                             shadows shadowing-imports
413                             use imports interns exports
414                             implement local-nicknames
415                             lock doc-string))))))
416
417 (defun find-or-make-symbol (name package)
418   (multiple-value-bind (symbol how) (find-symbol name package)
419     (cond (how
420            symbol)
421           (t
422            (with-simple-restart (continue "INTERN it.")
423              (error 'simple-package-error
424                     :package package
425                     :format-control "no symbol named ~S in ~S"
426                     :format-arguments (list name (package-name package))))
427            (intern name package)))))