1.0.21.14: fix CHECK-FASL-HEADER buglet
[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   '((:nicknames "{package-name}*")
38     (:size "<integer>")
39     (:shadow "{symbol-name}*")
40     (:shadowing-import-from "<package-name> {symbol-name}*")
41     (:use "{package-name}*")
42     (:import-from "<package-name> {symbol-name}*")
43     (:intern "{symbol-name}*")
44     (:export "{symbol-name}*")
45     #!+sb-package-locks (:implement "{package-name}*")
46     #!+sb-package-locks (:lock "boolean")
47     (:documentation "doc-string"))
48   '(:size #!+sb-package-locks :lock))
49   (let ((nicknames nil)
50         (size nil)
51         (shadows nil)
52         (shadowing-imports nil)
53         (use nil)
54         (use-p nil)
55         (imports nil)
56         (interns nil)
57         (exports nil)
58         (implement (stringify-package-designators (list package)))
59         (implement-p nil)
60         (lock nil)
61         (doc nil))
62     #!-sb-package-locks
63     (declare (ignore implement-p))
64     (dolist (option options)
65       (unless (consp option)
66         (error 'simple-program-error
67                :format-control "bogus DEFPACKAGE option: ~S"
68                :format-arguments (list option)))
69       (case (car option)
70         (:nicknames
71          (setf nicknames (stringify-package-designators (cdr option))))
72         (:size
73          (cond (size
74                 (error 'simple-program-error
75                        :format-control "can't specify :SIZE twice."))
76                ((and (consp (cdr option))
77                      (typep (second option) 'unsigned-byte))
78                 (setf size (second option)))
79                (t
80                 (error
81                  'simple-program-error
82                  :format-control ":SIZE is not a positive integer: ~S"
83                  :format-arguments (list (second option))))))
84         (:shadow
85          (let ((new (stringify-string-designators (cdr option))))
86            (setf shadows (append shadows new))))
87         (:shadowing-import-from
88          (let ((package-name (stringify-package-designator (second option)))
89                (names (stringify-string-designators (cddr option))))
90            (let ((assoc (assoc package-name shadowing-imports
91                                :test #'string=)))
92              (if assoc
93                  (setf (cdr assoc) (append (cdr assoc) names))
94                  (setf shadowing-imports
95                        (acons package-name names shadowing-imports))))))
96         (:use
97          (setf use (append use (stringify-package-designators (cdr option)) )
98                use-p t))
99         (:import-from
100          (let ((package-name (stringify-package-designator (second option)))
101                (names (stringify-string-designators (cddr option))))
102            (let ((assoc (assoc package-name imports
103                                :test #'string=)))
104              (if assoc
105                  (setf (cdr assoc) (append (cdr assoc) names))
106                  (setf imports (acons package-name names imports))))))
107         (:intern
108          (let ((new (stringify-string-designators (cdr option))))
109            (setf interns (append interns new))))
110         (:export
111          (let ((new (stringify-string-designators (cdr option))))
112            (setf exports (append exports new))))
113         #!+sb-package-locks
114         (:implement
115          (unless implement-p
116            (setf implement nil))
117          (let ((new (stringify-package-designators (cdr option))))
118            (setf implement (append implement new)
119                  implement-p t)))
120         #!+sb-package-locks
121         (:lock
122          (when lock
123            (error 'simple-program-error
124                   :format-control "multiple :LOCK options"))
125          (setf lock (coerce (second option) 'boolean)))
126         (:documentation
127          (when doc
128            (error 'simple-program-error
129                   :format-control "multiple :DOCUMENTATION options"))
130          (setf doc (coerce (second option) 'simple-string)))
131         (t
132          (error 'simple-program-error
133                 :format-control "bogus DEFPACKAGE option: ~S"
134                 :format-arguments (list option)))))
135     (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
136     (check-disjoint `(:intern ,@interns)
137                     `(:import-from
138                       ,@(apply #'append (mapcar #'rest imports)))
139                     `(:shadow ,@shadows)
140                     `(:shadowing-import-from
141                       ,@(apply #'append (mapcar #'rest shadowing-imports))))
142     `(eval-when (:compile-toplevel :load-toplevel :execute)
143        (%defpackage ,(stringify-string-designator package) ',nicknames ',size
144                     ',shadows ',shadowing-imports ',(if use-p use :default)
145                     ',imports ',interns ',exports ',implement ',lock ',doc
146                     (sb!c:source-location)))))
147
148 (defun check-disjoint (&rest args)
149   ;; An arg is (:key . set)
150   (do ((list args (cdr list)))
151       ((endp list))
152     (loop
153       with x = (car list)
154       for y in (rest list)
155       for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
156       when z do (error 'simple-program-error
157                        :format-control "Parameters ~S and ~S must be disjoint ~
158                                         but have common elements ~%   ~S"
159                        :format-arguments (list (car x)(car y) z)))))
160
161 (defun stringify-string-designator (string-designator)
162   (typecase string-designator
163     (simple-string string-designator)
164     (string (coerce string-designator 'simple-string))
165     (symbol (symbol-name string-designator))
166     (character (string string-designator))
167     (t
168      (error "~S does not designate a string" string-designator))))
169
170 (defun stringify-string-designators (string-designators)
171   (mapcar #'stringify-string-designator string-designators))
172
173 (defun stringify-package-designator (package-designator)
174   (typecase package-designator
175     (simple-string package-designator)
176     (string (coerce package-designator 'simple-string))
177     (symbol (symbol-name package-designator))
178     (character (string package-designator))
179     (package (package-name package-designator))
180     (t
181      (error "~S does not designate a package" package-designator))))
182
183 (defun stringify-package-designators (package-designators)
184   (mapcar #'stringify-package-designator package-designators))
185
186 (defun import-list-symbols (import-list)
187   (let ((symbols nil))
188     (dolist (import import-list symbols)
189       (destructuring-bind (package-name &rest symbol-names)
190           import
191         (let ((package (find-undeleted-package-or-lose package-name)))
192           (mapcar (lambda (name)
193                     (push (find-or-make-symbol name package) symbols))
194                   symbol-names))))))
195
196 (defun use-list-packages (package package-designators)
197   (cond ((listp package-designators)
198          (mapcar #'find-undeleted-package-or-lose package-designators))
199         (package
200          ;; :default for an existing package means preserve the
201          ;; existing use list
202          (package-use-list package))
203         (t
204          ;; :default for a new package is the *default-package-use-list*
205          '#.*default-package-use-list*)))
206
207 (defun update-package (package nicknames source-location
208                        shadows shadowing-imports
209                        use
210                        imports interns
211                        exports
212                        implement lock doc-string)
213   (declare #!-sb-package-locks
214            (ignore implement lock))
215   (enter-new-nicknames package nicknames)
216   ;; 1. :shadow and :shadowing-import-from
217   ;;
218   ;; shadows is a list of strings, shadowing-imports is a list of symbols.
219   (shadow shadows package)
220   (shadowing-import shadowing-imports package)
221   ;; 2. :use
222   ;;
223   ;; use is a list of package objects.
224   (use-package use package)
225   ;; 3. :import-from and :intern
226   ;;
227   ;; imports is a list of symbols. interns is a list of strings.
228   (import imports package)
229   (dolist (intern interns)
230     (intern intern package))
231   ;; 4. :export
232   ;;
233   ;; exports is a list of strings
234   (export (mapcar (lambda (symbol-name) (intern symbol-name package))
235                   exports)
236           package)
237   ;; Everything was created: update metadata
238   (sb!c:with-source-location (source-location)
239     (setf (package-source-location package) source-location))
240   (setf (package-doc-string package) doc-string)
241   #!+sb-package-locks
242   (progn
243     ;; Handle packages this is an implementation package of
244     (dolist (p implement)
245       (add-implementation-package package p))
246     ;; Handle lock
247     (setf (package-lock package) lock))
248   package)
249
250 (defun update-package-with-variance (package name nicknames source-location
251                                      shadows shadowing-imports
252                                      use
253                                      imports interns
254                                      exports
255                                      implement lock doc-string)
256   (let ((old-exports nil)
257         (old-shadows (package-%shadowing-symbols package))
258         (old-use (package-use-list package))
259         (no-longer-used nil))
260     (unless (string= (the string (package-name package)) name)
261       (error 'simple-package-error
262              :package name
263              :format-control "~A is a nickname for the package ~A"
264              :format-arguments (list name (package-name name))))
265     (do-external-symbols (symbol package)
266       (push symbol old-exports))
267     (setf old-shadows (set-difference old-shadows (append shadows
268                                                           shadowing-imports)
269                                       :test #'string=))
270     (setf no-longer-used (set-difference old-use use))
271     (setf use (set-difference use old-use))
272     (setf old-exports (set-difference old-exports exports :test #'string=))
273     (when old-shadows
274       (warn 'package-at-variance
275             :format-control "~A also shadows the following symbols:~%  ~S"
276             :format-arguments (list name old-shadows)))
277     (when no-longer-used
278       (dolist (unused-package no-longer-used)
279         (unuse-package unused-package package))
280       (warn 'package-at-variance
281             :format-control "~A used to use the following packages:~%  ~S"
282             :format-arguments (list name no-longer-used)))
283     (when old-exports
284       (warn 'package-at-variance
285             :format-control "~A also exports the following symbols:~%  ~S"
286             :format-arguments (list name old-exports)))
287     (update-package package nicknames source-location
288                     shadows shadowing-imports
289                     use imports interns exports
290                     implement lock doc-string)))
291
292 (defun %defpackage (name nicknames size shadows shadowing-imports
293                     use imports interns exports implement lock doc-string
294                     source-location)
295   (declare (type simple-string name)
296            (type list nicknames shadows shadowing-imports
297                  imports interns exports)
298            (type (or list (member :default)) use)
299            (type (or simple-string null) doc-string)
300            #!-sb-package-locks
301            (ignore implement lock))
302   (let* ((existing-package (find-package name))
303          (use (use-list-packages existing-package use))
304          (shadowing-imports (import-list-symbols shadowing-imports))
305          (imports (import-list-symbols imports)))
306     (if existing-package
307         (update-package-with-variance existing-package name
308                                       nicknames source-location
309                                       shadows shadowing-imports
310                                       use imports interns exports
311                                       implement lock doc-string)
312         (let ((package (make-package name
313                                      :use nil
314                                      :internal-symbols (or size 10)
315                                      :external-symbols (length exports))))
316           (update-package package
317                           nicknames source-location
318                           shadows shadowing-imports
319                           use imports interns exports
320                           implement lock doc-string)))))
321
322 (defun find-or-make-symbol (name package)
323   (multiple-value-bind (symbol how) (find-symbol name package)
324     (cond (how
325            symbol)
326           (t
327            (with-simple-restart (continue "INTERN it.")
328              (error 'simple-package-error
329                     :package package
330                     :format-control "no symbol named ~S in ~S"
331                     :format-arguments (list name (package-name package))))
332            (intern name package)))))