1.0.5.56: conditionally re-enable interrupts interrupting current thread
[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-names (list package) "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-names (cdr option) "package")))
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-names (cdr option) "symbol")))
86            (setf shadows (append shadows new))))
87         (:shadowing-import-from
88          (let ((package-name (stringify-name (second option) "package"))
89                (names (stringify-names (cddr option) "symbol")))
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-names (cdr option) "package") )
98                use-p t))
99         (:import-from
100          (let ((package-name (stringify-name (second option) "package"))
101                (names (stringify-names (cddr option) "symbol")))
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-names (cdr option) "symbol")))
109            (setf interns (append interns new))))
110         (:export
111          (let ((new (stringify-names (cdr option) "symbol")))
112            (setf exports (append exports new))))
113         #!+sb-package-locks
114         (:implement
115          (unless implement-p
116            (setf implement nil))
117          (let ((new (stringify-names (cdr option) "package")))
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-name package "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-name (name kind)
162   (typecase name
163     (simple-string name)
164     (string (coerce name 'simple-string))
165     (symbol (symbol-name name))
166     (character (string name))
167     (t
168      (error "bogus ~A name: ~S" kind name))))
169
170 (defun stringify-names (names kind)
171   (mapcar (lambda (name)
172             (stringify-name name kind))
173           names))
174
175 (defun %defpackage (name nicknames size shadows shadowing-imports
176                     use imports interns exports implement lock doc-string
177                     source-location)
178   (declare (type simple-string name)
179            (type list nicknames shadows shadowing-imports
180                  imports interns exports)
181            (type (or list (member :default)) use)
182            (type (or simple-string null) doc-string)
183            #!-sb-package-locks
184            (ignore implement lock))
185   (let ((package (or (find-package name)
186                      (progn
187                        (when (eq use :default)
188                          (setf use '#.*default-package-use-list*))
189                        (make-package name
190                                      :use nil
191                                      :internal-symbols (or size 10)
192                                      :external-symbols (length exports))))))
193     (sb!c:with-source-location (source-location)
194       (setf (package-source-location package) source-location))
195     (unless (string= (the string (package-name package)) name)
196       (error 'simple-package-error
197              :package name
198              :format-control "~A is a nickname for the package ~A"
199              :format-arguments (list name (package-name name))))
200     (enter-new-nicknames package nicknames)
201     ;; Handle shadows and shadowing-imports.
202     (let ((old-shadows (package-%shadowing-symbols package)))
203       (shadow shadows package)
204       (dolist (sym-name shadows)
205         (setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
206       (dolist (simports-from shadowing-imports)
207         (let ((other-package (find-undeleted-package-or-lose
208                               (car simports-from))))
209           (dolist (sym-name (cdr simports-from))
210             (let ((sym (find-or-make-symbol sym-name other-package)))
211               (shadowing-import sym package)
212               (setf old-shadows (remove sym old-shadows))))))
213       (when old-shadows
214         (warn 'package-at-variance
215               :format-control "~A also shadows the following symbols:~%  ~S"
216               :format-arguments (list name old-shadows))))
217     ;; Handle USE.
218     (unless (eq use :default)
219       (let ((old-use-list (package-use-list package))
220             (new-use-list (mapcar #'find-undeleted-package-or-lose use)))
221         (use-package (set-difference new-use-list old-use-list) package)
222         (let ((laterize (set-difference old-use-list new-use-list)))
223           (when laterize
224             (unuse-package laterize package)
225             (warn 'package-at-variance
226                   :format-control "~A used to use the following packages:~%  ~S"
227                   :format-arguments (list name laterize))))))
228     ;; Handle IMPORT and INTERN.
229     (dolist (sym-name interns)
230       (intern sym-name package))
231     (dolist (imports-from imports)
232       (let ((other-package (find-undeleted-package-or-lose (car
233                                                             imports-from))))
234         (dolist (sym-name (cdr imports-from))
235           (import (list (find-or-make-symbol sym-name other-package))
236                   package))))
237     ;; Handle exports.
238     (let ((old-exports nil)
239           (exports (mapcar (lambda (sym-name) (intern sym-name package))
240                            exports)))
241       (do-external-symbols (sym package)
242         (push sym old-exports))
243       (export exports package)
244       (let ((diff (set-difference old-exports exports)))
245         (when diff
246           (warn 'package-at-variance
247                 :format-control "~A also exports the following symbols:~%  ~S"
248                 :format-arguments (list name diff)))))
249     #!+sb-package-locks
250     (progn
251       ;; Handle packages this is an implementation package of
252       (dolist (p implement)
253         (add-implementation-package package p))
254       ;; Handle lock
255       (setf (package-lock package) lock))
256     ;; Handle documentation.
257     (setf (package-doc-string package) doc-string)
258     package))
259
260 (defun find-or-make-symbol (name package)
261   (multiple-value-bind (symbol how) (find-symbol name package)
262     (cond (how
263            symbol)
264           (t
265            (with-simple-restart (continue "INTERN it.")
266              (error 'simple-package-error
267                     :package package
268                     :format-control "no symbol named ~S in ~S"
269                     :format-arguments (list name (package-name package))))
270            (intern name package)))))