0.pre8.4
[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   "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
33    following:
34      (:NICKNAMES {package-name}*)
35      (:SIZE <integer>)
36      (:SHADOW {symbol-name}*)
37      (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
38      (:USE {package-name}*)
39      (:IMPORT-FROM <package-name> {symbol-name}*)
40      (:INTERN {symbol-name}*)
41      (:EXPORT {symbol-name}*)
42      (:DOCUMENTATION doc-string)
43    All options except :SIZE and :DOCUMENTATION can be used multiple times."
44   (let ((nicknames nil)
45         (size nil)
46         (shadows nil)
47         (shadowing-imports nil)
48         (use nil)
49         (use-p nil)
50         (imports nil)
51         (interns nil)
52         (exports nil)
53         (doc nil))
54     (dolist (option options)
55       (unless (consp option)
56         (error 'simple-program-error
57                :format-control "bogus DEFPACKAGE option: ~S"
58                :format-arguments (list option)))
59       (case (car option)
60         (:nicknames
61          (setf nicknames (stringify-names (cdr option) "package")))
62         (:size
63          (cond (size
64                 (error 'simple-program-error
65                        :format-control "can't specify :SIZE twice."))
66                ((and (consp (cdr option))
67                      (typep (second option) 'unsigned-byte))
68                 (setf size (second option)))
69                (t
70                 (error
71                  'simple-program-error
72                  :format-control ":SIZE is not a positive integer: ~S"
73                  :format-arguments (list (second option))))))
74         (:shadow
75          (let ((new (stringify-names (cdr option) "symbol")))
76            (setf shadows (append shadows new))))
77         (:shadowing-import-from
78          (let ((package-name (stringify-name (second option) "package"))
79                (names (stringify-names (cddr option) "symbol")))
80            (let ((assoc (assoc package-name shadowing-imports
81                                :test #'string=)))
82              (if assoc
83                  (setf (cdr assoc) (append (cdr assoc) names))
84                  (setf shadowing-imports
85                        (acons package-name names shadowing-imports))))))
86         (:use
87          (setf use (append use (stringify-names (cdr option) "package") )
88                use-p t))
89         (:import-from
90          (let ((package-name (stringify-name (second option) "package"))
91                (names (stringify-names (cddr option) "symbol")))
92            (let ((assoc (assoc package-name imports
93                                :test #'string=)))
94              (if assoc
95                  (setf (cdr assoc) (append (cdr assoc) names))
96                  (setf imports (acons package-name names imports))))))
97         (:intern
98          (let ((new (stringify-names (cdr option) "symbol")))
99            (setf interns (append interns new))))
100         (:export
101          (let ((new (stringify-names (cdr option) "symbol")))
102            (setf exports (append exports new))))
103         (:documentation
104          (when doc
105            (error 'simple-program-error
106                   :format-control "multiple :DOCUMENTATION options"))
107          (setf doc (coerce (second option) 'simple-string)))
108         (t
109          (error 'simple-program-error
110                 :format-control "bogus DEFPACKAGE option: ~S"
111                 :format-arguments (list option)))))
112     (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
113     (check-disjoint `(:intern ,@interns)
114                     `(:import-from
115                       ,@(apply #'append (mapcar #'rest imports)))
116                     `(:shadow ,@shadows)
117                     `(:shadowing-import-from
118                       ,@(apply #'append (mapcar #'rest shadowing-imports))))
119     `(eval-when (:compile-toplevel :load-toplevel :execute)
120        (%defpackage ,(stringify-name package "package") ',nicknames ',size
121                     ',shadows ',shadowing-imports ',(if use-p use :default)
122                     ',imports ',interns ',exports ',doc))))
123
124 (defun check-disjoint (&rest args)
125   ;; An arg is (:key . set)
126   (do ((list args (cdr list)))
127       ((endp list))
128     (loop
129       with x = (car list)
130       for y in (rest list)
131       for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
132       when z do (error 'simple-program-error
133                        :format-control "Parameters ~S and ~S must be disjoint ~
134                                         but have common elements ~%   ~S"
135                        :format-arguments (list (car x)(car y) z)))))
136
137 (defun stringify-name (name kind)
138   (typecase name
139     (simple-string name)
140     (string (coerce name 'simple-string))
141     (symbol (symbol-name name))
142     (base-char (string name))
143     (t
144      (error "bogus ~A name: ~S" kind name))))
145
146 (defun stringify-names (names kind)
147   (mapcar (lambda (name)
148             (stringify-name name kind))
149           names))
150
151 (defun %defpackage (name nicknames size shadows shadowing-imports
152                          use imports interns exports doc-string)
153   (declare (type simple-base-string name)
154            (type list nicknames shadows shadowing-imports
155                  imports interns exports)
156            (type (or list (member :default)) use)
157            (type (or simple-base-string null) doc-string))
158   (let ((package (or (find-package name)
159                      (progn
160                        (when (eq use :default)
161                          (setf use '#.*default-package-use-list*))
162                        (make-package name
163                                      :use nil
164                                      :internal-symbols (or size 10)
165                                      :external-symbols (length exports))))))
166     (unless (string= (the string (package-name package)) name)
167       (error 'simple-package-error
168              :package name
169              :format-control "~A is a nickname for the package ~A"
170              :format-arguments (list name (package-name name))))
171     (enter-new-nicknames package nicknames)
172     ;; Handle shadows and shadowing-imports.
173     (let ((old-shadows (package-%shadowing-symbols package)))
174       (shadow shadows package)
175       (dolist (sym-name shadows)
176         (setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
177       (dolist (simports-from shadowing-imports)
178         (let ((other-package (find-undeleted-package-or-lose
179                               (car simports-from))))
180           (dolist (sym-name (cdr simports-from))
181             (let ((sym (find-or-make-symbol sym-name other-package)))
182               (shadowing-import sym package)
183               (setf old-shadows (remove sym old-shadows))))))
184       (when old-shadows
185         (warn "~A also shadows the following symbols:~%  ~S"
186               name old-shadows)))
187     ;; Handle USE.
188     (unless (eq use :default)
189       (let ((old-use-list (package-use-list package))
190             (new-use-list (mapcar #'find-undeleted-package-or-lose use)))
191         (use-package (set-difference new-use-list old-use-list) package)
192         (let ((laterize (set-difference old-use-list new-use-list)))
193           (when laterize
194             (unuse-package laterize package)
195             (warn "~A used to use the following packages:~%  ~S"
196                   name
197                   laterize)))))
198     ;; Handle IMPORT and INTERN.
199     (dolist (sym-name interns)
200       (intern sym-name package))
201     (dolist (imports-from imports)
202       (let ((other-package (find-undeleted-package-or-lose (car
203                                                             imports-from))))
204         (dolist (sym-name (cdr imports-from))
205           (import (list (find-or-make-symbol sym-name other-package))
206                   package))))
207     ;; Handle exports.
208     (let ((old-exports nil)
209           (exports (mapcar (lambda (sym-name) (intern sym-name package))
210                            exports)))
211       (do-external-symbols (sym package)
212         (push sym old-exports))
213       (export exports package)
214       (let ((diff (set-difference old-exports exports)))
215         (when diff
216           (warn "~A also exports the following symbols:~%  ~S" name diff))))
217     ;; Handle documentation.
218     (setf (package-doc-string package) doc-string)
219     package))
220
221 (defun find-or-make-symbol (name package)
222   (multiple-value-bind (symbol how) (find-symbol name package)
223     (cond (how
224            symbol)
225           (t
226            (with-simple-restart (continue "INTERN it.")
227              (error 'simple-package-error
228                     :package package
229                     :format-control "no symbol named ~S in ~S"
230                     :format-arguments (list name (package-name package))))
231            (intern name package)))))