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
))
187 (defun %defpackage
(name nicknames size shadows shadowing-imports
188 use imports interns exports implement lock doc-string
190 (declare (type simple-string name
)
191 (type list nicknames shadows shadowing-imports
192 imports interns exports
)
193 (type (or list
(member :default
)) use
)
194 (type (or simple-string null
) doc-string
)
196 (ignore implement lock
))
197 (let ((package (or (find-package name
)
199 (when (eq use
:default
)
200 (setf use
'#.
*default-package-use-list
*))
203 :internal-symbols
(or size
10)
204 :external-symbols
(length exports
))))))
205 (sb!c
:with-source-location
(source-location)
206 (setf (package-source-location package
) source-location
))
207 (unless (string= (the string
(package-name package
)) name
)
208 (error 'simple-package-error
210 :format-control
"~A is a nickname for the package ~A"
211 :format-arguments
(list name
(package-name name
))))
212 (enter-new-nicknames package nicknames
)
213 ;; Handle shadows and shadowing-imports.
214 (let ((old-shadows (package-%shadowing-symbols package
)))
215 (shadow shadows package
)
216 (dolist (sym-name shadows
)
217 (setf old-shadows
(remove (find-symbol sym-name package
) old-shadows
)))
218 (dolist (simports-from shadowing-imports
)
219 (let ((other-package (find-undeleted-package-or-lose
220 (car simports-from
))))
221 (dolist (sym-name (cdr simports-from
))
222 (let ((sym (find-or-make-symbol sym-name other-package
)))
223 (shadowing-import sym package
)
224 (setf old-shadows
(remove sym old-shadows
))))))
226 (warn 'package-at-variance
227 :format-control
"~A also shadows the following symbols:~% ~S"
228 :format-arguments
(list name old-shadows
))))
230 (unless (eq use
:default
)
231 (let ((old-use-list (package-use-list package
))
232 (new-use-list (mapcar #'find-undeleted-package-or-lose use
)))
233 (use-package (set-difference new-use-list old-use-list
) package
)
234 (let ((laterize (set-difference old-use-list new-use-list
)))
236 (unuse-package laterize package
)
237 (warn 'package-at-variance
238 :format-control
"~A used to use the following packages:~% ~S"
239 :format-arguments
(list name laterize
))))))
240 ;; Handle IMPORT and INTERN.
241 (dolist (sym-name interns
)
242 (intern sym-name package
))
243 (dolist (imports-from imports
)
244 (let ((other-package (find-undeleted-package-or-lose (car
246 (dolist (sym-name (cdr imports-from
))
247 (import (list (find-or-make-symbol sym-name other-package
))
250 (let ((old-exports nil
)
251 (exports (mapcar (lambda (sym-name) (intern sym-name package
))
253 (do-external-symbols (sym package
)
254 (push sym old-exports
))
255 (export exports package
)
256 (let ((diff (set-difference old-exports exports
)))
258 (warn 'package-at-variance
259 :format-control
"~A also exports the following symbols:~% ~S"
260 :format-arguments
(list name diff
)))))
263 ;; Handle packages this is an implementation package of
264 (dolist (p implement
)
265 (add-implementation-package package p
))
267 (setf (package-lock package
) lock
))
268 ;; Handle documentation.
269 (setf (package-doc-string package
) doc-string
)
272 (defun find-or-make-symbol (name package
)
273 (multiple-value-bind (symbol how
) (find-symbol name package
)
277 (with-simple-restart (continue "INTERN it.")
278 (error 'simple-package-error
280 :format-control
"no symbol named ~S in ~S"
281 :format-arguments
(list name
(package-name package
))))
282 (intern name package
)))))