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 ;;; the list of packages to use by default when no :USE argument is
15 ;;; supplied to MAKE-PACKAGE or other package creation forms
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
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.:-|
30 (defmacro defpackage (package &rest options)
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
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}*")
48 (:nicknames "{package-name}*"))
49 '(:size #!+sb-package-locks :lock))
54 (shadowing-imports nil)
60 (implement (stringify-package-designators (list package)))
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)))
73 (setf nicknames (stringify-package-designators (cdr option))))
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))))
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)))
92 :format-control ":SIZE is not a positive integer: ~S"
93 :format-arguments (list (second option))))))
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
103 (setf (cdr assoc) (append (cdr assoc) names))
104 (setf shadowing-imports
105 (acons package-name names shadowing-imports))))))
107 (setf use (append use (stringify-package-designators (cdr option)) )
110 (let ((package-name (stringify-package-designator (second option)))
111 (names (stringify-string-designators (cddr option))))
112 (let ((assoc (assoc package-name imports
115 (setf (cdr assoc) (append (cdr assoc) names))
116 (setf imports (acons package-name names imports))))))
118 (let ((new (stringify-string-designators (cdr option))))
119 (setf interns (append interns new))))
121 (let ((new (stringify-string-designators (cdr option))))
122 (setf exports (append exports new))))
126 (setf implement nil))
127 (let ((new (stringify-package-designators (cdr option))))
128 (setf implement (append implement new)
133 (error 'simple-program-error
134 :format-control "multiple :LOCK options"))
135 (setf lock (coerce (second option) 'boolean)))
138 (error 'simple-program-error
139 :format-control "multiple :DOCUMENTATION options"))
140 (setf doc (coerce (second option) 'simple-string)))
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)
148 ,@(apply #'append (mapcar #'rest imports)))
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
157 (sb!c:source-location)))))
159 (defun check-disjoint (&rest args)
160 ;; An arg is (:key . set)
161 (do ((list args (cdr 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)))))
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))
179 (error "~S does not designate a string" string-designator))))
181 (defun stringify-string-designators (string-designators)
182 (mapcar #'stringify-string-designator string-designators))
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))
192 (error "~S does not designate a package" package-designator))))
194 (defun stringify-package-designators (package-designators)
195 (mapcar #'stringify-package-designator package-designators))
197 (defun import-list-symbols (import-list)
199 (dolist (import import-list symbols)
200 (destructuring-bind (package-name &rest symbol-names)
202 (let ((package (find-undeleted-package-or-lose package-name)))
203 (mapcar (lambda (name)
204 (push (find-or-make-symbol name package) symbols))
207 (defun use-list-packages (package package-designators)
208 (cond ((listp package-designators)
209 (mapcar #'find-undeleted-package-or-lose package-designators))
211 ;; :default for an existing package means preserve the
213 (package-use-list package))
215 ;; :default for a new package is the *default-package-use-list*
216 '#.*default-package-use-list*)))
218 (defun update-package (package nicknames source-location
219 shadows shadowing-imports
222 exports implement local-nicknames
224 (declare #!-sb-package-locks
225 (ignore implement lock))
226 (%enter-new-nicknames package nicknames)
227 ;; 1. :shadow and :shadowing-import-from
229 ;; shadows is a list of strings, shadowing-imports is a list of symbols.
230 (shadow shadows package)
231 (shadowing-import shadowing-imports package)
234 ;; use is a list of package objects.
235 (use-package use package)
236 ;; 3. :import-from and :intern
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))
244 ;; exports is a list of strings
245 (export (mapcar (lambda (symbol-name) (intern symbol-name 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)
254 ;; Handle packages this is an implementation package of
255 (dolist (p implement)
256 (add-implementation-package package p))
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))
265 (defun update-package-with-variance (package name nicknames source-location
266 shadows shadowing-imports
270 implement local-nicknames
272 (unless (string= (the string (package-name package)) name)
273 (error 'simple-package-error
275 :format-control "~A is a nickname for the package ~A"
276 :format-arguments (list name (package-name name))))
277 (let ((no-longer-shadowed
278 (set-difference (package-%shadowing-symbols package)
279 (append shadows shadowing-imports)
281 (when no-longer-shadowed
283 (let ((*package* (find-package :keyword)))
284 (error 'sb!kernel::package-at-variance-error
285 :format-control "~A also shadows the following symbols:~% ~S"
286 :format-arguments (list name no-longer-shadowed)
289 :report "Stop shadowing them by uninterning them."
290 (dolist (sym no-longer-shadowed)
291 (unintern sym package)))
293 :report "Keep shadowing them."))))
294 (let ((no-longer-used (set-difference (package-use-list package) use)))
297 (error 'sb!kernel::package-at-variance-error
298 :format-control "~A also uses the following packages:~% ~A"
299 :format-arguments (list name (mapcar #'package-name no-longer-used))
302 :report "Stop using them."
303 (unuse-package no-longer-used package))
305 :report "Keep using them."))))
307 (do-external-symbols (s package)
308 (push s old-exports))
309 (let ((no-longer-exported (set-difference old-exports exports :test #'string=)))
310 (when no-longer-exported
312 (error 'sb!kernel::package-at-variance-error
313 :format-control "~A also exports the following symbols:~% ~S"
314 :format-arguments (list name no-longer-exported)
317 :report "Unexport them."
318 (unexport no-longer-exported package))
320 :report "Keep exporting them.")))))
321 (let ((old-implements
322 (set-difference (package-implements-list package)
323 (mapcar #'find-undeleted-package-or-lose implement))))
326 (error 'sb!kernel::package-at-variance-error
327 :format-control "~A is also an implementation package for:~% ~{~S~^~% ~}"
328 :format-arguments (list name old-implements)
331 :report "Stop being an implementation package for them."
332 (dolist (p old-implements)
333 (remove-implementation-package package p)))
335 :report "Keep exporting them."))))
336 (update-package package nicknames source-location
337 shadows shadowing-imports
338 use imports interns exports
339 implement local-nicknames
342 (defun %defpackage (name nicknames size shadows shadowing-imports
343 use imports interns exports implement local-nicknames
346 (declare (type simple-string name)
347 (type list nicknames shadows shadowing-imports
348 imports interns exports)
349 (type (or list (member :default)) use)
350 (type (or simple-string null) doc-string)
352 (ignore implement lock))
353 (with-package-graph ()
354 (let* ((existing-package (find-package name))
355 (use (use-list-packages existing-package use))
356 (shadowing-imports (import-list-symbols shadowing-imports))
357 (imports (import-list-symbols imports)))
359 (update-package-with-variance existing-package name
360 nicknames source-location
361 shadows shadowing-imports
362 use imports interns exports
363 implement local-nicknames
365 (let ((package (make-package name
367 :internal-symbols (or size 10)
368 :external-symbols (length exports))))
369 (update-package package
372 shadows shadowing-imports
373 use imports interns exports
374 implement local-nicknames
375 lock doc-string))))))
377 (defun find-or-make-symbol (name package)
378 (multiple-value-bind (symbol how) (find-symbol name package)
382 (with-simple-restart (continue "INTERN it.")
383 (error 'simple-package-error
385 :format-control "no symbol named ~S in ~S"
386 :format-arguments (list name (package-name package))))
387 (intern name package)))))