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
)
32 "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
34 (:NICKNAMES {package-name}*)
36 (:SHADOW {symbol-name}*)
37 (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
38 (:USE {package-name}*)
39 (:IMPORT-FROM <package-name> {symbol-name}*)
40 (:INTERN {symbol-name}*)
41 (:EXPORT {symbol-name}*)
42 (:DOCUMENTATION doc-string)
43 All options except :SIZE and :DOCUMENTATION can be used multiple times."
47 (shadowing-imports nil
)
54 (dolist (option options
)
55 (unless (consp option
)
56 (error 'simple-program-error
57 :format-control
"bogus DEFPACKAGE option: ~S"
58 :format-arguments
(list option
)))
61 (setf nicknames
(stringify-names (cdr option
) "package")))
64 (error 'simple-program-error
65 :format-control
"can't specify :SIZE twice."))
66 ((and (consp (cdr option
))
67 (typep (second option
) 'unsigned-byte
))
68 (setf size
(second option
)))
72 :format-control
":SIZE is not a positive integer: ~S"
73 :format-arguments
(list (second option
))))))
75 (let ((new (stringify-names (cdr option
) "symbol")))
76 (setf shadows
(append shadows new
))))
77 (:shadowing-import-from
78 (let ((package-name (stringify-name (second option
) "package"))
79 (names (stringify-names (cddr option
) "symbol")))
80 (let ((assoc (assoc package-name shadowing-imports
83 (setf (cdr assoc
) (append (cdr assoc
) names
))
84 (setf shadowing-imports
85 (acons package-name names shadowing-imports
))))))
87 (setf use
(append use
(stringify-names (cdr option
) "package") )
90 (let ((package-name (stringify-name (second option
) "package"))
91 (names (stringify-names (cddr option
) "symbol")))
92 (let ((assoc (assoc package-name imports
95 (setf (cdr assoc
) (append (cdr assoc
) names
))
96 (setf imports
(acons package-name names imports
))))))
98 (let ((new (stringify-names (cdr option
) "symbol")))
99 (setf interns
(append interns new
))))
101 (let ((new (stringify-names (cdr option
) "symbol")))
102 (setf exports
(append exports new
))))
105 (error 'simple-program-error
106 :format-control
"multiple :DOCUMENTATION options"))
107 (setf doc
(coerce (second option
) 'simple-string
)))
109 (error 'simple-program-error
110 :format-control
"bogus DEFPACKAGE option: ~S"
111 :format-arguments
(list option
)))))
112 (check-disjoint `(:intern
,@interns
) `(:export
,@exports
))
113 (check-disjoint `(:intern
,@interns
)
115 ,@(apply #'append
(mapcar #'rest imports
)))
117 `(:shadowing-import-from
118 ,@(apply #'append
(mapcar #'rest shadowing-imports
))))
119 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
120 (%defpackage
,(stringify-name package
"package") ',nicknames
',size
121 ',shadows
',shadowing-imports
',(if use-p use
:default
)
122 ',imports
',interns
',exports
',doc
))))
124 (defun check-disjoint (&rest args
)
125 ;; An arg is (:key . set)
126 (do ((list args
(cdr list
)))
131 for z
= (remove-duplicates (intersection (cdr x
)(cdr y
) :test
#'string
=))
132 when z do
(error 'simple-program-error
133 :format-control
"Parameters ~S and ~S must be disjoint ~
134 but have common elements ~% ~S"
135 :format-arguments
(list (car x
)(car y
) z
)))))
137 (defun stringify-name (name kind
)
139 (simple-base-string name
)
140 (string (coerce name
'simple-base-string
))
141 (symbol (symbol-name name
))
142 (base-char (string name
))
144 (error "bogus ~A name: ~S" kind name
))))
146 (defun stringify-names (names kind
)
147 (mapcar (lambda (name)
148 (stringify-name name kind
))
151 (defun %defpackage
(name nicknames size shadows shadowing-imports
152 use imports interns exports doc-string
)
153 (declare (type simple-base-string name
)
154 (type list nicknames shadows shadowing-imports
155 imports interns exports
)
156 (type (or list
(member :default
)) use
)
157 (type (or simple-base-string null
) doc-string
))
158 (let ((package (or (find-package name
)
160 (when (eq use
:default
)
161 (setf use
'#.
*default-package-use-list
*))
164 :internal-symbols
(or size
10)
165 :external-symbols
(length exports
))))))
166 (unless (string= (the string
(package-name package
)) name
)
167 (error 'simple-package-error
169 :format-control
"~A is a nickname for the package ~A"
170 :format-arguments
(list name
(package-name name
))))
171 (enter-new-nicknames package nicknames
)
172 ;; Handle shadows and shadowing-imports.
173 (let ((old-shadows (package-%shadowing-symbols package
)))
174 (shadow shadows package
)
175 (dolist (sym-name shadows
)
176 (setf old-shadows
(remove (find-symbol sym-name package
) old-shadows
)))
177 (dolist (simports-from shadowing-imports
)
178 (let ((other-package (find-undeleted-package-or-lose
179 (car simports-from
))))
180 (dolist (sym-name (cdr simports-from
))
181 (let ((sym (find-or-make-symbol sym-name other-package
)))
182 (shadowing-import sym package
)
183 (setf old-shadows
(remove sym old-shadows
))))))
185 (warn "~A also shadows the following symbols:~% ~S"
188 (unless (eq use
:default
)
189 (let ((old-use-list (package-use-list package
))
190 (new-use-list (mapcar #'find-undeleted-package-or-lose use
)))
191 (use-package (set-difference new-use-list old-use-list
) package
)
192 (let ((laterize (set-difference old-use-list new-use-list
)))
194 (unuse-package laterize package
)
195 (warn "~A used to use the following packages:~% ~S"
198 ;; Handle IMPORT and INTERN.
199 (dolist (sym-name interns
)
200 (intern sym-name package
))
201 (dolist (imports-from imports
)
202 (let ((other-package (find-undeleted-package-or-lose (car
204 (dolist (sym-name (cdr imports-from
))
205 (import (list (find-or-make-symbol sym-name other-package
))
208 (let ((old-exports nil
)
209 (exports (mapcar (lambda (sym-name) (intern sym-name package
))
211 (do-external-symbols (sym package
)
212 (push sym old-exports
))
213 (export exports package
)
214 (let ((diff (set-difference old-exports exports
)))
216 (warn "~A also exports the following symbols:~% ~S" name diff
))))
217 ;; Handle documentation.
218 (setf (package-doc-string package
) doc-string
)
221 (defun find-or-make-symbol (name package
)
222 (multiple-value-bind (symbol how
) (find-symbol name package
)
226 (with-simple-restart (continue "INTERN it.")
227 (error 'simple-package-error
229 :format-control
"no symbol named ~S in ~S"
230 :format-arguments
(list name
(package-name package
))))
231 (intern name package
)))))