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 ;;; FIXME: figure out why a full call to FORMAT this early in warm load
15 ;;; says that CLASS is not a known type. (Obviously it needs to parse
16 ;;; a type spec, but then why it is only a style-warning and not an error?)
17 ;;; Weirder still, why does it depend on the target architecture?
19 (defmacro defpackage
(package &rest options
)
20 #.
(locally (declare (notinline format
))
22 "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
23 following: ~{~&~4T~A~}
24 All options except ~{~A, ~}and :DOCUMENTATION can be used multiple
26 '((:use
"{package-name}*")
27 (:export
"{symbol-name}*")
28 (:import-from
"<package-name> {symbol-name}*")
29 (:shadow
"{symbol-name}*")
30 (:shadowing-import-from
"<package-name> {symbol-name}*")
31 (:local-nicknames
"{local-nickname actual-package-name}*")
32 #+sb-package-locks
(:lock
"boolean")
33 #+sb-package-locks
(:implement
"{package-name}*")
34 (:documentation
"doc-string")
35 (:intern
"{symbol-name}*")
37 (:nicknames
"{package-name}*"))
38 '(:size
#+sb-package-locks
:lock
)))
43 (shadowing-imports nil
)
49 (package (stringify-string-designator package
))
57 (dolist (option options
)
58 (unless (consp option
)
59 (error 'simple-program-error
60 :format-control
"bogus DEFPACKAGE option: ~S"
61 :format-arguments
(list option
)))
62 (setq optname
(car option
) optval
(cdr option
))
64 ((:documentation
:size
#+sb-package-locks
:lock
)
65 (when (memq optname seen
)
66 (error 'simple-program-error
67 :format-control
"can't specify ~S more than once."
68 :format-arguments
(list optname
)))
69 (unless (typep optval
'(cons t null
))
70 (error 'simple-program-error
71 :format-control
"~S expects a single argument. Got ~S"
72 :format-arguments
(list (car option
) (cdr option
))))
74 (setq optval
(car optval
))))
78 (append nicknames
(stringify-string-designators optval
))))
81 (append local-nicknames
82 (mapcar (lambda (spec)
83 (destructuring-bind (nick name
) spec
84 (cons (stringify-package-designator nick
)
85 (stringify-package-designator name
))))
88 (if (typep optval
'unsigned-byte
)
90 (error 'simple-program-error
91 :format-control
":SIZE is not a positive integer: ~S"
92 :format-arguments
(cdr option
))))
94 (setf shadows
(append shadows
(stringify-string-designators optval
))))
95 (:shadowing-import-from
96 (let ((package-name (stringify-package-designator (car optval
)))
97 (names (stringify-string-designators (cdr optval
))))
98 (let ((assoc (assoc package-name shadowing-imports
:test
#'string
=)))
100 (setf (cdr assoc
) (append (cdr assoc
) names
))
101 (setf shadowing-imports
102 (acons package-name names shadowing-imports
))))))
104 (setf use
(append use
(stringify-package-designators optval
))
107 (let ((package-name (stringify-package-designator (car optval
)))
108 (names (stringify-string-designators (cdr optval
))))
109 (let ((assoc (assoc package-name imports
:test
#'string
=)))
111 (setf (cdr assoc
) (append (cdr assoc
) names
))
112 (setf imports
(acons package-name names imports
))))))
114 (setf interns
(append interns
(stringify-string-designators optval
))))
116 (setf exports
(append exports
(stringify-string-designators optval
))))
119 (setf implement
(append implement
(stringify-package-designators optval
))
123 (setf lock
(coerce optval
'boolean
)))
125 (setf doc
(possibly-base-stringize optval
)))
127 (error 'simple-program-error
128 :format-control
"bogus DEFPACKAGE option: ~S"
129 :format-arguments
(list option
)))))
130 (check-disjoint `(:intern
,@interns
) `(:export
,@exports
))
131 (check-disjoint `(:intern
,@interns
)
133 ,@(apply #'append
(mapcar #'rest imports
)))
135 `(:shadowing-import-from
136 ,@(apply #'append
(mapcar #'rest shadowing-imports
))))
137 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
138 (%defpackage
,package
',nicknames
',size
139 ',shadows
',shadowing-imports
',(if use-p use
:default
)
140 ',imports
',interns
',exports
141 ;; FIXME: the default singleton list seems unnecessary.
142 ;; PACKAGE-LOCK-VIOLATION-P considers every package to implement
143 ;; itself. Additionally there's an obvious inconsistency:
144 ;; * (package-implements-list (defpackage "A")) => (#<PACKAGE "A">)
145 ;; * (package-implements-list (make-package "B")) => NIL
146 ',(if implement-p implement
(list package
))
148 ',lock
(sb-c:source-location
)
152 (defun check-disjoint (&rest args
)
153 ;; An arg is (:key . set)
154 (do ((list args
(cdr list
)))
159 for z
= (remove-duplicates (intersection (cdr x
)(cdr y
) :test
#'string
=))
160 when z do
(error 'simple-program-error
161 :format-control
"Parameters ~S and ~S must be disjoint ~
162 but have common elements ~% ~S"
163 :format-arguments
(list (car x
)(car y
) z
)))))
165 (flet ((designator-to-string (kind designator
)
166 (cond ((and (eq kind
'package
) (packagep designator
))
167 (package-name designator
)) ; already simple and basic if possible
169 (possibly-base-stringize
170 (cond ((stringp designator
) designator
)
171 ((symbolp designator
) (symbol-name designator
))
172 ((characterp designator
) (string designator
))
173 (t (error 'simple-type-error
176 (if (eq kind
'package
) 'package-designator
'string-designator
)
177 :format-control
"~S does not designate a ~(~A~)"
178 :format-arguments
(list designator kind
)))))))))
179 (defun stringify-string-designator (string-designator)
180 (designator-to-string 'string string-designator
))
181 (defun stringify-package-designator (package-designator)
182 (designator-to-string 'package package-designator
)))
184 (defun stringify-string-designators (string-designators)
185 (mapcar #'stringify-string-designator string-designators
))
187 (defun stringify-package-designators (package-designators)
188 (mapcar #'stringify-package-designator package-designators
))
190 (defun import-list-symbols (import-list)
192 (dolist (import import-list symbols
)
193 (destructuring-bind (package-name &rest symbol-names
)
195 (let ((package (find-undeleted-package-or-lose package-name
)))
196 (mapcar (lambda (name)
197 (push (find-or-make-symbol name package
) symbols
))
200 (defun use-list-packages (package package-designators
)
201 (cond ((listp package-designators
)
202 (mapcar #'find-undeleted-package-or-lose package-designators
))
204 ;; :default for an existing package means preserve the
206 (package-use-list package
))
208 ;; :default for a new package is the *!default-package-use-list*
209 '#.
*!default-package-use-list
*)))
211 (defun update-package (package nicknames source-location
212 shadows shadowing-imports
215 exports implement local-nicknames
217 (declare #-sb-package-locks
(ignore implement lock
))
218 (%enter-new-nicknames package nicknames
)
219 ;; 1. :shadow and :shadowing-import-from
221 ;; shadows is a list of strings, shadowing-imports is a list of symbols.
222 (shadow shadows package
)
223 (shadowing-import shadowing-imports package
)
226 ;; use is a list of package objects.
227 (use-package use package
)
228 ;; 3. :import-from and :intern
230 ;; imports is a list of symbols. interns is a list of strings.
231 (import imports package
)
232 (dolist (intern interns
)
233 (intern intern package
))
236 ;; exports is a list of strings
237 (export (mapcar (lambda (symbol-name) (intern symbol-name package
))
240 ;; 5. :local-nicknames
241 (setf (package-%local-nicknames package
) nil
) ; throw out the old ones.
242 (loop :for
(nickname . nickname-package
) :in local-nicknames
:do
243 (add-package-local-nickname nickname nickname-package package
))
244 ;; Everything was created: update metadata
245 (when source-location
246 (setf (package-source-location package
) source-location
))
247 (setf (package-doc-string package
) doc-string
)
250 ;; Handle packages this is an implementation package of
251 (dolist (p implement
)
252 (add-implementation-package package p
))
254 (setf (package-lock package
) lock
))
257 (declaim (type list
*on-package-variance
*))
258 (defvar *on-package-variance
* '(:warn t
)
259 "Specifies behavior when redefining a package using DEFPACKAGE and the
260 definition is in variance with the current state of the package.
262 The value should be of the form:
264 (:WARN [T | packages-names] :ERROR [T | package-names])
266 specifying which packages get which behaviour -- with T signifying the default unless
267 otherwise specified. If default is not specified, :WARN is used.
269 :WARN keeps as much state as possible and causes SBCL to signal a full warning.
271 :ERROR causes SBCL to signal an error when the variant DEFPACKAGE form is executed,
272 with restarts provided for user to specify what action should be taken.
276 (setf *on-package-variance* '(:warn (:swank :swank-backend) :error t))
278 specifies to signal a warning if SWANK package is in variance, and an error otherwise.")
280 (defun note-package-variance (&rest args
&key package
&allow-other-keys
)
281 (let ((pname (package-name package
)))
282 (destructuring-bind (&key warn error
) *on-package-variance
*
283 (let ((what (cond ((and (listp error
) (member pname error
:test
#'string
=))
285 ((and (listp warn
) (member pname warn
:test
#'string
=))
293 (apply #'error
'package-at-variance-error args
))
295 (apply #'warn
'package-at-variance args
)))))))
297 (defun update-package-with-variance (package name nicknames source-location
298 shadows shadowing-imports
302 implement local-nicknames
304 (unless (string= (the string
(package-name package
)) name
)
305 (error 'simple-package-error
307 :format-control
"~A is a nickname for the package ~A"
308 :format-arguments
(list name
(package-name name
))))
309 (let ((no-longer-shadowed
310 (set-difference (package-%shadowing-symbols package
)
311 (append shadows shadowing-imports
)
313 (when no-longer-shadowed
315 (let ((*package
* (find-package :keyword
)))
316 (note-package-variance
317 :format-control
"~A also shadows the following symbols:~% ~S"
318 :format-arguments
(list name no-longer-shadowed
)
321 :report
"Stop shadowing them by uninterning them."
322 (dolist (sym no-longer-shadowed
)
323 (unintern sym package
)))
325 :report
"Keep shadowing them."))))
326 (let ((no-longer-used (set-difference (package-use-list package
) use
)))
329 (note-package-variance
330 :format-control
"~A also uses the following packages:~% ~A"
331 :format-arguments
(list name
(mapcar #'package-name no-longer-used
))
334 :report
"Stop using them."
335 (unuse-package no-longer-used package
))
337 :report
"Keep using them."))))
339 (do-external-symbols (s package
)
340 (push s old-exports
))
341 (let ((no-longer-exported (set-difference old-exports exports
:test
#'string
=)))
342 (when no-longer-exported
344 (note-package-variance
345 :format-control
"~A also exports the following symbols:~% ~S"
346 :format-arguments
(list name no-longer-exported
)
349 :report
"Unexport them."
350 (unexport no-longer-exported package
))
352 :report
"Keep exporting them.")))))
354 (let ((old-implements
355 (set-difference (package-implements-list package
)
356 (mapcar #'find-undeleted-package-or-lose implement
))))
359 (note-package-variance
360 :format-control
"~A is also an implementation package for:~% ~{~S~^~% ~}"
361 :format-arguments
(list name old-implements
)
364 :report
"Stop being an implementation package for them."
365 (dolist (p old-implements
)
366 (remove-implementation-package package p
)))
368 :report
"Keep exporting them."))))
369 (update-package package nicknames source-location
370 shadows shadowing-imports
371 use imports interns exports
372 implement local-nicknames
375 (defun %defpackage
(name nicknames size shadows shadowing-imports
376 use imports interns exports implement local-nicknames
377 lock source-location
&optional doc
)
378 (declare (type simple-string name
)
379 (type list nicknames shadows shadowing-imports
380 imports interns exports
)
381 (type (or list
(member :default
)) use
)
382 (type (or simple-string null
) doc
))
383 (with-package-graph ()
384 (let* ((existing-package (find-package name
))
385 (use (use-list-packages existing-package use
))
386 (shadowing-imports (import-list-symbols shadowing-imports
))
387 (imports (import-list-symbols imports
)))
389 (update-package-with-variance existing-package name
390 nicknames source-location
391 shadows shadowing-imports
392 use imports interns exports
393 implement local-nicknames
395 (let ((package (make-package name
397 :internal-symbols
(or size
10)
398 :external-symbols
(length exports
))))
399 (update-package package
402 shadows shadowing-imports
403 use imports interns exports
404 implement local-nicknames
407 (defun find-or-make-symbol (name package
)
408 (multiple-value-bind (symbol how
) (find-symbol name package
)
412 (with-simple-restart (continue "INTERN it.")
413 (error 'simple-package-error
415 :format-control
"no symbol named ~S in ~S"
416 :format-arguments
(list name
(package-name package
))))
417 (intern name package
)))))
421 ;;; FIXME: This nickname is a deprecated hack for backwards
422 ;;; compatibility with code which assumed the CMU-CL-style
423 ;;; SB-ALIEN/SB-C-CALL split. That split went away and was deprecated
424 ;;; in 0.7.0, so we should get rid of this nickname after a while.
425 (let ((package (find-package "SB-ALIEN")))
426 (rename-package package package
427 (cons "SB-C-CALL" (package-nicknames package
))))
429 (let ((package (find-package "SB-SEQUENCE")))
430 (rename-package package package
(list "SEQUENCE")))