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 '((:nicknames "{package-name}*")
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))
52 (shadowing-imports nil)
58 (implement (stringify-package-designators (list package)))
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)))
71 (setf nicknames (stringify-package-designators (cdr option))))
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)))
82 :format-control ":SIZE is not a positive integer: ~S"
83 :format-arguments (list (second option))))))
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
93 (setf (cdr assoc) (append (cdr assoc) names))
94 (setf shadowing-imports
95 (acons package-name names shadowing-imports))))))
97 (setf use (append use (stringify-package-designators (cdr option)) )
100 (let ((package-name (stringify-package-designator (second option)))
101 (names (stringify-string-designators (cddr option))))
102 (let ((assoc (assoc package-name imports
105 (setf (cdr assoc) (append (cdr assoc) names))
106 (setf imports (acons package-name names imports))))))
108 (let ((new (stringify-string-designators (cdr option))))
109 (setf interns (append interns new))))
111 (let ((new (stringify-string-designators (cdr option))))
112 (setf exports (append exports new))))
116 (setf implement nil))
117 (let ((new (stringify-package-designators (cdr option))))
118 (setf implement (append implement new)
123 (error 'simple-program-error
124 :format-control "multiple :LOCK options"))
125 (setf lock (coerce (second option) 'boolean)))
128 (error 'simple-program-error
129 :format-control "multiple :DOCUMENTATION options"))
130 (setf doc (coerce (second option) 'simple-string)))
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)
138 ,@(apply #'append (mapcar #'rest imports)))
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)))))
148 (defun check-disjoint (&rest args)
149 ;; An arg is (:key . set)
150 (do ((list args (cdr 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)))))
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))
168 (error "~S does not designate a string" string-designator))))
170 (defun stringify-string-designators (string-designators)
171 (mapcar #'stringify-string-designator string-designators))
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))
181 (error "~S does not designate a package" package-designator))))
183 (defun stringify-package-designators (package-designators)
184 (mapcar #'stringify-package-designator package-designators))
186 (defun import-list-symbols (import-list)
188 (dolist (import import-list symbols)
189 (destructuring-bind (package-name &rest symbol-names)
191 (let ((package (find-undeleted-package-or-lose package-name)))
192 (mapcar (lambda (name)
193 (push (find-or-make-symbol name package) symbols))
196 (defun use-list-packages (package package-designators)
197 (cond ((listp package-designators)
198 (mapcar #'find-undeleted-package-or-lose package-designators))
200 ;; :default for an existing package means preserve the
202 (package-use-list package))
204 ;; :default for a new package is the *default-package-use-list*
205 '#.*default-package-use-list*)))
207 (defun update-package (package nicknames source-location
208 shadows shadowing-imports
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
218 ;; shadows is a list of strings, shadowing-imports is a list of symbols.
219 (shadow shadows package)
220 (shadowing-import shadowing-imports package)
223 ;; use is a list of package objects.
224 (use-package use package)
225 ;; 3. :import-from and :intern
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))
233 ;; exports is a list of strings
234 (export (mapcar (lambda (symbol-name) (intern symbol-name 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)
243 ;; Handle packages this is an implementation package of
244 (dolist (p implement)
245 (add-implementation-package package p))
247 (setf (package-lock package) lock))
250 (defun update-package-with-variance (package name nicknames source-location
251 shadows shadowing-imports
255 implement lock doc-string)
256 (unless (string= (the string (package-name package)) name)
257 (error 'simple-package-error
259 :format-control "~A is a nickname for the package ~A"
260 :format-arguments (list name (package-name name))))
261 (let ((no-longer-shadowed
262 (set-difference (package-%shadowing-symbols package)
263 (append shadows shadowing-imports)
265 (when no-longer-shadowed
267 (let ((*package* (find-package :keyword)))
268 (error 'sb!kernel::package-at-variance-error
269 :format-control "~A also shadows the following symbols:~% ~S"
270 :format-arguments (list name no-longer-shadowed)
273 :report "Stop shadowing them by uninterning them."
274 (dolist (sym no-longer-shadowed)
275 (unintern sym package)))
277 :report "Keep shadowing them."))))
278 (let ((no-longer-used (set-difference (package-use-list package) use)))
281 (error 'sb!kernel::package-at-variance-error
282 :format-control "~A also uses the following packages:~% ~A"
283 :format-arguments (list name (mapcar #'package-name no-longer-used))
286 :report "Stop using them."
287 (unuse-package no-longer-used package))
289 :report "Keep using them."))))
291 (do-external-symbols (s package)
292 (push s old-exports))
293 (let ((no-longer-exported (set-difference old-exports exports :test #'string=)))
294 (when no-longer-exported
296 (error 'sb!kernel::package-at-variance-error
297 :format-control "~A also exports the following symbols:~% ~S"
298 :format-arguments (list name no-longer-exported)
301 :report "Unexport them."
302 (unexport no-longer-exported package))
304 :report "Keep exporting them.")))))
305 (let ((old-implements
306 (set-difference (package-implements-list package)
307 (mapcar #'find-undeleted-package-or-lose implement))))
310 (error 'sb!kernel::package-at-variance-error
311 :format-control "~A is also an implementation package for:~% ~{~S~^~% ~}"
312 :format-arguments (list name old-implements)
315 :report "Stop being an implementation package for them."
316 (dolist (p old-implements)
317 (remove-implementation-package package p)))
319 :report "Keep exporting them."))))
320 (update-package package nicknames source-location
321 shadows shadowing-imports
322 use imports interns exports
323 implement lock doc-string))
325 (defun %defpackage (name nicknames size shadows shadowing-imports
326 use imports interns exports implement lock doc-string
328 (declare (type simple-string name)
329 (type list nicknames shadows shadowing-imports
330 imports interns exports)
331 (type (or list (member :default)) use)
332 (type (or simple-string null) doc-string)
334 (ignore implement lock))
335 (with-package-graph ()
336 (let* ((existing-package (find-package name))
337 (use (use-list-packages existing-package use))
338 (shadowing-imports (import-list-symbols shadowing-imports))
339 (imports (import-list-symbols imports)))
341 (update-package-with-variance existing-package name
342 nicknames source-location
343 shadows shadowing-imports
344 use imports interns exports
345 implement lock doc-string)
346 (let ((package (make-package name
348 :internal-symbols (or size 10)
349 :external-symbols (length exports))))
350 (update-package package
351 nicknames source-location
352 shadows shadowing-imports
353 use imports interns exports
354 implement lock doc-string))))))
356 (defun find-or-make-symbol (name package)
357 (multiple-value-bind (symbol how) (find-symbol name package)
361 (with-simple-restart (continue "INTERN it.")
362 (error 'simple-package-error
364 :format-control "no symbol named ~S in ~S"
365 :format-arguments (list name (package-name package))))
366 (intern name package)))))