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")
17 (defmacro defpackage (package &rest options)
19 "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
21 (:NICKNAMES {package-name}*)
23 (:SHADOW {symbol-name}*)
24 (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
25 (:USE {package-name}*)
26 (:IMPORT-FROM <package-name> {symbol-name}*)
27 (:INTERN {symbol-name}*)
28 (:EXPORT {symbol-name}*)
29 (:DOCUMENTATION doc-string)
30 All options except :SIZE and :DOCUMENTATION can be used multiple times."
34 (shadowing-imports nil)
41 (dolist (option options)
42 (unless (consp option)
44 :format-control "bogus DEFPACKAGE option: ~S"
45 :format-arguments (list option)))
48 (setf nicknames (stringify-names (cdr option) "package")))
52 :format-control "can't specify :SIZE twice."))
53 ((and (consp (cdr option))
54 (typep (second option) 'unsigned-byte))
55 (setf size (second option)))
59 :format-control ":SIZE is not a positive integer: ~S"
60 :format-arguments (list (second option))))))
62 (let ((new (stringify-names (cdr option) "symbol")))
63 (setf shadows (append shadows new))))
64 (:shadowing-import-from
65 (let ((package-name (stringify-name (second option) "package"))
66 (names (stringify-names (cddr option) "symbol")))
67 (let ((assoc (assoc package-name shadowing-imports
70 (setf (cdr assoc) (append (cdr assoc) names))
71 (setf shadowing-imports
72 (acons package-name names shadowing-imports))))))
74 (setf use (append use (stringify-names (cdr option) "package") )
77 (let ((package-name (stringify-name (second option) "package"))
78 (names (stringify-names (cddr option) "symbol")))
79 (let ((assoc (assoc package-name imports
82 (setf (cdr assoc) (append (cdr assoc) names))
83 (setf imports (acons package-name names imports))))))
85 (let ((new (stringify-names (cdr option) "symbol")))
86 (setf interns (append interns new))))
88 (let ((new (stringify-names (cdr option) "symbol")))
89 (setf exports (append exports new))))
93 :format-control "multiple :DOCUMENTATION options"))
94 (setf doc (coerce (second option) 'simple-string)))
97 :format-control "bogus DEFPACKAGE option: ~S"
98 :format-arguments (list option)))))
99 (check-disjoint `(:intern ,@interns) `(:export ,@exports))
100 (check-disjoint `(:intern ,@interns)
102 ,@(apply #'append (mapcar #'rest imports)))
104 `(:shadowing-import-from
105 ,@(apply #'append (mapcar #'rest shadowing-imports))))
106 `(eval-when (:compile-toplevel :load-toplevel :execute)
107 (%defpackage ,(stringify-name package "package") ',nicknames ',size
108 ',shadows ',shadowing-imports ',(if use-p use :default)
109 ',imports ',interns ',exports ',doc))))
111 (defun check-disjoint (&rest args)
112 ;; An arg is (:key . set)
113 (do ((list args (cdr list)))
118 for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
119 when z do (error 'program-error
120 :format-control "Parameters ~S and ~S must be disjoint ~
121 but have common elements ~% ~S"
122 :format-arguments (list (car x)(car y) z)))))
124 (defun stringify-name (name kind)
127 (string (coerce name 'simple-string))
128 (symbol (symbol-name name))
129 (base-char (string name))
131 (error "bogus ~A name: ~S" kind name))))
133 (defun stringify-names (names kind)
134 (mapcar #'(lambda (name)
135 (stringify-name name kind))
138 (defun %defpackage (name nicknames size shadows shadowing-imports
139 use imports interns exports doc-string)
140 (declare (type simple-base-string name)
141 (type list nicknames shadows shadowing-imports
142 imports interns exports)
143 (type (or list (member :default)) use)
144 (type (or simple-base-string null) doc-string))
145 (let ((package (or (find-package name)
147 (when (eq use :default)
148 (setf use *default-package-use-list*))
151 :internal-symbols (or size 10)
152 :external-symbols (length exports))))))
153 (unless (string= (the string (package-name package)) name)
154 (error 'simple-package-error
156 :format-control "~A is a nickname for the package ~A"
157 :format-arguments (list name (package-name name))))
158 (enter-new-nicknames package nicknames)
159 ;; Handle shadows and shadowing-imports.
160 (let ((old-shadows (package-%shadowing-symbols package)))
161 (shadow shadows package)
162 (dolist (sym-name shadows)
163 (setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
164 (dolist (simports-from shadowing-imports)
165 (let ((other-package (find-undeleted-package-or-lose
166 (car simports-from))))
167 (dolist (sym-name (cdr simports-from))
168 (let ((sym (find-or-make-symbol sym-name other-package)))
169 (shadowing-import sym package)
170 (setf old-shadows (remove sym old-shadows))))))
172 (warn "~A also shadows the following symbols:~% ~S"
175 (unless (eq use :default)
176 (let ((old-use-list (package-use-list package))
177 (new-use-list (mapcar #'find-undeleted-package-or-lose use)))
178 (use-package (set-difference new-use-list old-use-list) package)
179 (let ((laterize (set-difference old-use-list new-use-list)))
181 (unuse-package laterize package)
182 (warn "~A used to use the following packages:~% ~S"
185 ;; Handle IMPORT and INTERN.
186 (dolist (sym-name interns)
187 (intern sym-name package))
188 (dolist (imports-from imports)
189 (let ((other-package (find-undeleted-package-or-lose (car
191 (dolist (sym-name (cdr imports-from))
192 (import (list (find-or-make-symbol sym-name other-package))
195 (let ((old-exports nil)
196 (exports (mapcar #'(lambda (sym-name) (intern sym-name package))
198 (do-external-symbols (sym package)
199 (push sym old-exports))
200 (export exports package)
201 (let ((diff (set-difference old-exports exports)))
203 (warn "~A also exports the following symbols:~% ~S" name diff))))
204 ;; Handle documentation.
205 (setf (package-doc-string package) doc-string)
208 (defun find-or-make-symbol (name package)
209 (multiple-value-bind (symbol how) (find-symbol name package)
213 (with-simple-restart (continue "INTERN it.")
214 (error 'simple-package-error
216 :format-control "no symbol named ~S in ~S"
217 :format-arguments (list name (package-name package))))
218 (intern name package)))))