1 ;;;; the DEFPACKAGE macro
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 (defmacro defpackage (package &rest options)
16 "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
18 (:NICKNAMES {package-name}*)
20 (:SHADOW {symbol-name}*)
21 (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
22 (:USE {package-name}*)
23 (:IMPORT-FROM <package-name> {symbol-name}*)
24 (:INTERN {symbol-name}*)
25 (:EXPORT {symbol-name}*)
26 (:DOCUMENTATION doc-string)
27 All options except :SIZE and :DOCUMENTATION can be used multiple times."
31 (shadowing-imports nil)
38 (dolist (option options)
39 (unless (consp option)
40 (error 'simple-program-error
41 :format-control "bogus DEFPACKAGE option: ~S"
42 :format-arguments (list option)))
45 (setf nicknames (stringify-names (cdr option) "package")))
48 (error 'simple-program-error
49 :format-control "can't specify :SIZE twice."))
50 ((and (consp (cdr option))
51 (typep (second option) 'unsigned-byte))
52 (setf size (second option)))
56 :format-control ":SIZE is not a positive integer: ~S"
57 :format-arguments (list (second option))))))
59 (let ((new (stringify-names (cdr option) "symbol")))
60 (setf shadows (append shadows new))))
61 (:shadowing-import-from
62 (let ((package-name (stringify-name (second option) "package"))
63 (names (stringify-names (cddr option) "symbol")))
64 (let ((assoc (assoc package-name shadowing-imports
67 (setf (cdr assoc) (append (cdr assoc) names))
68 (setf shadowing-imports
69 (acons package-name names shadowing-imports))))))
71 (setf use (append use (stringify-names (cdr option) "package") )
74 (let ((package-name (stringify-name (second option) "package"))
75 (names (stringify-names (cddr option) "symbol")))
76 (let ((assoc (assoc package-name imports
79 (setf (cdr assoc) (append (cdr assoc) names))
80 (setf imports (acons package-name names imports))))))
82 (let ((new (stringify-names (cdr option) "symbol")))
83 (setf interns (append interns new))))
85 (let ((new (stringify-names (cdr option) "symbol")))
86 (setf exports (append exports new))))
89 (error 'simple-program-error
90 :format-control "multiple :DOCUMENTATION options"))
91 (setf doc (coerce (second option) 'simple-string)))
93 (error 'simple-program-error
94 :format-control "bogus DEFPACKAGE option: ~S"
95 :format-arguments (list option)))))
96 (check-disjoint `(:intern ,@interns) `(:export ,@exports))
97 (check-disjoint `(:intern ,@interns)
99 ,@(apply #'append (mapcar #'rest imports)))
101 `(:shadowing-import-from
102 ,@(apply #'append (mapcar #'rest shadowing-imports))))
103 `(eval-when (:compile-toplevel :load-toplevel :execute)
104 (%defpackage ,(stringify-name package "package") ',nicknames ',size
105 ',shadows ',shadowing-imports ',(if use-p use :default)
106 ',imports ',interns ',exports ',doc))))
108 (defun check-disjoint (&rest args)
109 ;; An arg is (:key . set)
110 (do ((list args (cdr list)))
115 for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
116 when z do (error 'simple-program-error
117 :format-control "Parameters ~S and ~S must be disjoint ~
118 but have common elements ~% ~S"
119 :format-arguments (list (car x)(car y) z)))))
121 (defun stringify-name (name kind)
124 (string (coerce name 'simple-string))
125 (symbol (symbol-name name))
126 (base-char (string name))
128 (error "bogus ~A name: ~S" kind name))))
130 (defun stringify-names (names kind)
131 (mapcar #'(lambda (name)
132 (stringify-name name kind))
135 (defun %defpackage (name nicknames size shadows shadowing-imports
136 use imports interns exports doc-string)
137 (declare (type simple-base-string name)
138 (type list nicknames shadows shadowing-imports
139 imports interns exports)
140 (type (or list (member :default)) use)
141 (type (or simple-base-string null) doc-string))
142 (let ((package (or (find-package name)
144 (when (eq use :default)
145 (setf use *default-package-use-list*))
148 :internal-symbols (or size 10)
149 :external-symbols (length exports))))))
150 (unless (string= (the string (package-name package)) name)
151 (error 'simple-package-error
153 :format-control "~A is a nickname for the package ~A"
154 :format-arguments (list name (package-name name))))
155 (enter-new-nicknames package nicknames)
156 ;; Handle shadows and shadowing-imports.
157 (let ((old-shadows (package-%shadowing-symbols package)))
158 (shadow shadows package)
159 (dolist (sym-name shadows)
160 (setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
161 (dolist (simports-from shadowing-imports)
162 (let ((other-package (find-undeleted-package-or-lose
163 (car simports-from))))
164 (dolist (sym-name (cdr simports-from))
165 (let ((sym (find-or-make-symbol sym-name other-package)))
166 (shadowing-import sym package)
167 (setf old-shadows (remove sym old-shadows))))))
169 (warn "~A also shadows the following symbols:~% ~S"
172 (unless (eq use :default)
173 (let ((old-use-list (package-use-list package))
174 (new-use-list (mapcar #'find-undeleted-package-or-lose use)))
175 (use-package (set-difference new-use-list old-use-list) package)
176 (let ((laterize (set-difference old-use-list new-use-list)))
178 (unuse-package laterize package)
179 (warn "~A used to use the following packages:~% ~S"
182 ;; Handle IMPORT and INTERN.
183 (dolist (sym-name interns)
184 (intern sym-name package))
185 (dolist (imports-from imports)
186 (let ((other-package (find-undeleted-package-or-lose (car
188 (dolist (sym-name (cdr imports-from))
189 (import (list (find-or-make-symbol sym-name other-package))
192 (let ((old-exports nil)
193 (exports (mapcar #'(lambda (sym-name) (intern sym-name package))
195 (do-external-symbols (sym package)
196 (push sym old-exports))
197 (export exports package)
198 (let ((diff (set-difference old-exports exports)))
200 (warn "~A also exports the following symbols:~% ~S" name diff))))
201 ;; Handle documentation.
202 (setf (package-doc-string package) doc-string)
205 (defun find-or-make-symbol (name package)
206 (multiple-value-bind (symbol how) (find-symbol name package)
210 (with-simple-restart (continue "INTERN it.")
211 (error 'simple-package-error
213 :format-control "no symbol named ~S in ~S"
214 :format-arguments (list name (package-name package))))
215 (intern name package)))))