1 |
|
;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Package: (DEFPACKAGE :COLON-MODE :EXTERNAL) -*- |
2 |
|
;;; |
3 |
|
;;; THE BOEING COMPANY |
4 |
|
;;; BOEING COMPUTER SERVICES |
5 |
|
;;; RESEARCH AND TECHNOLOGY |
6 |
|
;;; COMPUTER SCIENCE |
7 |
|
;;; P.O. BOX 24346, MS 7L-64 |
8 |
|
;;; SEATTLE, WA 98124-0346 |
9 |
|
;;; |
10 |
|
;;; |
11 |
|
;;; Copyright (c) 1990, 1991 The Boeing Company, All Rights Reserved. |
12 |
|
;;; |
13 |
|
;;; Permission is granted to any individual or institution to use, |
14 |
|
;;; copy, modify, and distribute this software, provided that this |
15 |
|
;;; complete copyright and permission notice is maintained, intact, in |
16 |
|
;;; all copies and supporting documentation and that modifications are |
17 |
|
;;; appropriately documented with date, author and description of the |
18 |
|
;;; change. |
19 |
|
;;; |
20 |
|
;;; Stephen L. Nicoud (snicoud@boeing.com) provides this software "as |
21 |
|
;;; is" without express or implied warranty by him or The Boeing |
22 |
|
;;; Company. |
23 |
|
;;; |
24 |
|
;;; This software is distributed in the hope that it will be useful, |
25 |
|
;;; but WITHOUT ANY WARRANTY. No author or distributor accepts |
26 |
|
;;; responsibility to anyone for the consequences of using it or for |
27 |
|
;;; whether it serves any particular purpose or works at all. |
28 |
|
;;; |
29 |
|
;;; Author: Stephen L. Nicoud |
30 |
|
;;; |
31 |
|
;;; ----------------------------------------------------------------- |
32 |
|
;;; |
33 |
|
;;; Read-Time Conditionals used in this file. |
34 |
|
;;; |
35 |
|
;;; #+LISPM |
36 |
|
;;; #+EXCL |
37 |
|
;;; #+SYMBOLICS |
38 |
|
;;; #+TI |
39 |
|
;;; |
40 |
|
;;; ----------------------------------------------------------------- |
41 |
|
|
42 |
|
;;; ----------------------------------------------------------------- |
43 |
|
;;; |
44 |
|
;;; DEFPACKAGE - This files attempts to define a portable |
45 |
|
;;; implementation for DEFPACKAGE, as defined in "Common LISP, The |
46 |
|
;;; Language", by Guy L. Steele, Jr., Second Edition, 1990, Digital |
47 |
|
;;; Press. |
48 |
|
;;; |
49 |
|
;;; Send comments, suggestions, and/or questions to: |
50 |
|
;;; |
51 |
|
;;; Stephen L Nicoud <snicoud@boeing.com> |
52 |
|
;;; |
53 |
|
;;; An early version of this file was tested in Symbolics Common |
54 |
|
;;; Lisp (Genera 7.2 & 8.0 on a Symbolics 3650 Lisp Machine), |
55 |
|
;;; Franz's Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS |
56 |
|
;;; 4.1), and Sun Common Lisp (Lucid Common Lisp 3.0.2 on a Sun 3, |
57 |
|
;;; SunOS 4.1). |
58 |
|
;;; |
59 |
|
;;; 91/5/23 (SLN) - Since the initial testing, modifications have |
60 |
|
;;; been made to reflect new understandings of what DEFPACKAGE |
61 |
|
;;; should do. These new understandings are the result of |
62 |
|
;;; discussions appearing on the X3J13 and Common Lisp mailing |
63 |
|
;;; lists. Cursory testing was done on the modified version only |
64 |
|
;;; in Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS 4.1). |
65 |
|
;;; |
66 |
|
;;; ----------------------------------------------------------------- |
67 |
|
|
68 |
|
|
69 |
|
(lisp:in-package :DEFPACKAGE) |
70 |
|
|
71 |
|
(export '(defpackage)) |
72 |
|
;(provide :defpackage) |
73 |
|
|
74 |
|
(use-package :SLOOP) |
75 |
|
;(use-package :DEFPACKAGE) |
76 |
|
|
77 |
|
(proclaim '(declaration values arglist)) |
78 |
|
|
79 |
|
|
80 |
|
;#-gcl |
81 |
|
;(eval-when (compile load eval) |
82 |
|
; #-lispm |
83 |
|
; (unless (member :loop *features*) |
84 |
|
; (require :loop #+excl (merge-pathnames "loop" excl::*library-code-fasl-pathname*))) |
85 |
|
; |
86 |
|
; (unless (find-package :common-lisp) |
87 |
|
; (rename-package :lisp :common-lisp (union '("CL" "LISP") (package-nicknames (find-package :lisp)) :test #'string=))) |
88 |
|
; (unless (find-package :common-lisp-user) |
89 |
|
; (rename-package :user :common-lisp-user (union '("CL-USER" "USER") (package-nicknames (find-package :user)) :test #'string=))) |
90 |
|
; |
91 |
|
; #+lispm |
92 |
|
; (shadow (intern "DEFPACKAGE" #+symbolics :scl #+ti :ticl) 'defpackage) |
93 |
|
; (proclaim '(declaration values arglist)) |
94 |
|
; (export 'defpackage 'defpackage) |
95 |
|
; ) |
96 |
|
|
97 |
|
(defmacro DEFPACKAGE (name &rest options) |
98 |
|
(declare (type (or symbol string) name) |
99 |
|
(arglist defined-package-name &rest options) |
100 |
|
(values package)) |
101 |
|
"DEFPACKAGE - DEFINED-PACKAGE-NAME {OPTION}* [Macro] |
102 |
|
|
103 |
|
This creates a new package, or modifies an existing one, whose name is |
104 |
|
DEFINED-PACKAGE-NAME. The DEFINED-PACKAGE-NAME may be a string or a |
105 |
|
symbol; if it is a symbol, only its print name matters, and not what |
106 |
|
package, if any, the symbol happens to be in. The newly created or |
107 |
|
modified package is returned as the value of the DEFPACKAGE form. |
108 |
|
|
109 |
|
Each standard OPTION is a list of keyword (the name of the option) |
110 |
|
and associated arguments. No part of a DEFPACKAGE form is evaluated. |
111 |
|
Except for the :SIZE and :DOCUMENTATION options, more than one option |
112 |
|
of the same kind may occur within the same DEFPACKAGE form. |
113 |
|
|
114 |
|
Valid Options: |
115 |
|
(:documentation string) |
116 |
|
(:size integer) |
117 |
|
(:nicknames {package-name}*) |
118 |
|
(:shadow {symbol-name}*) |
119 |
|
(:shadowing-import-from package-name {symbol-name}*) |
120 |
|
(:use {package-name}*) |
121 |
|
(:import-from package-name {symbol-name}*) |
122 |
|
(:intern {symbol-name}*) |
123 |
|
(:export {symbol-name}*) |
124 |
|
(:export-from {package-name}*) |
125 |
|
|
126 |
|
[Note: :EXPORT-FROM is an extension to DEFPACKAGE. |
127 |
|
If a symbol is interned in the package being created and |
128 |
|
if a symbol with the same print name appears as an external |
129 |
|
symbol of one of the packages in the :EXPORT-FROM option, |
130 |
|
then the symbol is exported from the package being created. |
131 |
|
|
132 |
|
:DOCUMENTATION is an extension to DEFPACKAGE. |
133 |
|
|
134 |
|
:SIZE is used only in Genera and Allegro.]" |
135 |
|
|
136 |
|
(sloop for option in options |
137 |
|
unless (member |
138 |
|
(first option) |
139 |
|
'(:documentation :size :nicknames :shadow |
140 |
|
:shadowing-import-from :use :import-from |
141 |
|
:intern :export :export-from)) |
142 |
|
do (cerror "Proceed, ignoring this option." "~s is not a valid option." option)) |
143 |
|
(labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1))) |
144 |
|
(option-values-list (option options) |
145 |
|
(sloop for result = (member option options |
146 |
|
':test #'option-test) |
147 |
|
then (member option (rest result) |
148 |
|
':test #'option-test) |
149 |
|
until (null result) when result collect |
150 |
|
(rest (first result)))) |
151 |
|
(option-values (option options) |
152 |
|
(sloop for result = (member option options ':test #'option-test) |
153 |
|
then (member option (rest result) ':test #'option-test) |
154 |
|
until (null result) when result append |
155 |
|
(rest (first result))))) |
156 |
|
(sloop for option in '(:size :documentation) |
157 |
|
when (<= 2 (count option options ':key #'car)) |
158 |
|
do (specific-error :invalid-form |
159 |
|
"DEFPACKAGE option ~s specified more than once." |
160 |
|
option)) |
161 |
|
(setq name (string name)) |
162 |
|
(let ((nicknames (mapcar #'string (option-values ':nicknames options))) |
163 |
|
(documentation (first (option-values ':documentation options))) |
164 |
|
(size (first (option-values ':size options))) |
165 |
|
(shadowed-symbol-names (mapcar #'string (option-values ':shadow options))) |
166 |
|
(interned-symbol-names (mapcar #'string (option-values ':intern options))) |
167 |
|
(exported-symbol-names (mapcar #'string (option-values ':export options))) |
168 |
|
(shadowing-imported-from-symbol-names-list |
169 |
|
(sloop for list in (option-values-list ':shadowing-import-from options) |
170 |
|
collect (cons (string (first list)) (mapcar #'string (rest list))))) |
171 |
|
(imported-from-symbol-names-list |
172 |
|
(sloop for list in (option-values-list ':import-from options) |
173 |
|
collect (cons (string (first list)) (mapcar #'string (rest list))))) |
174 |
|
(exported-from-package-names |
175 |
|
(mapcar #'string (option-values ':export-from options)))) |
176 |
|
(flet ((find-duplicates |
177 |
|
(&rest lists) |
178 |
|
(let (results) |
179 |
|
(sloop for list in lists |
180 |
|
for more on (cdr lists) |
181 |
|
for i from 1 |
182 |
|
do |
183 |
|
(sloop for elt in list |
184 |
|
as entry = (find elt results :key #'car :test #'string=) |
185 |
|
unless (member i entry) |
186 |
|
do |
187 |
|
(sloop for l2 in more |
188 |
|
for j from (1+ i) |
189 |
|
do |
190 |
|
(if (member elt l2 :test #'string=) |
191 |
|
(if entry |
192 |
|
(nconc entry (list j)) |
193 |
|
(setq entry |
194 |
|
(car (push |
195 |
|
(list elt i j) results)))))))) |
196 |
|
results))) |
197 |
|
(sloop for duplicate in |
198 |
|
(find-duplicates |
199 |
|
shadowed-symbol-names |
200 |
|
interned-symbol-names |
201 |
|
(sloop for list in shadowing-imported-from-symbol-names-list |
202 |
|
append (rest list)) |
203 |
|
(sloop for list in imported-from-symbol-names-list |
204 |
|
append (rest list))) |
205 |
|
do |
206 |
|
(specific-error |
207 |
|
:invalid-form |
208 |
|
"The symbol ~s cannot coexist in these lists:~{ ~s~}" |
209 |
|
(first duplicate) |
210 |
|
(sloop for num in (rest duplicate) |
211 |
|
collect |
212 |
|
(case num |
213 |
|
(1 ':SHADOW) |
214 |
|
(2 ':INTERN) |
215 |
|
(3 ':SHADOWING-IMPORT-FROM) |
216 |
|
(4 ':IMPORT-FROM))))) |
217 |
|
(sloop for duplicate in |
218 |
|
(find-duplicates exported-symbol-names interned-symbol-names) |
219 |
|
do |
220 |
|
(specific-error |
221 |
|
:invalid-form |
222 |
|
"The symbol ~s cannot coexist in these lists:~{ ~s~}" |
223 |
|
(first duplicate) |
224 |
|
(sloop for num in |
225 |
|
(rest duplicate) |
226 |
|
collect (case num |
227 |
|
(1 ':EXPORT) |
228 |
|
(2 ':INTERN)))))) |
229 |
|
`(eval-when (load eval compile) |
230 |
|
(if (find-package ,name) |
231 |
|
(progn (rename-package ,name ,name) |
232 |
|
,@(when nicknames |
233 |
|
`((rename-package ,name ,name ',nicknames))) |
234 |
|
#+(or symbolics excl) |
235 |
|
,@(when size |
236 |
|
#+symbolics |
237 |
|
`((when (> ,size (pkg-max-number-of-symbols |
238 |
|
(find-package ,name))) |
239 |
|
(pkg-rehash (find-package ,name) ,size))) |
240 |
|
#+excl `((let |
241 |
|
((tab (excl::package-internal-symbols |
242 |
|
(find-package ,name)))) |
243 |
|
(when (hash-table-p tab) |
244 |
|
(setf (excl::ha_rehash-size tab) ,size))))) |
245 |
|
,@(when (not (null (member ':use options ':key #'car))) |
246 |
|
`((unuse-package |
247 |
|
(package-use-list (find-package ,name)) ,name)))) |
248 |
|
(make-package |
249 |
|
,name |
250 |
|
':use 'nil |
251 |
|
':nicknames |
252 |
|
',nicknames |
253 |
|
,@(when size |
254 |
|
#+lispm `(:size ,size) |
255 |
|
#+excl `(:internal-symbols ,size)))) |
256 |
|
,@(progn |
257 |
|
`((setf (get ',(intern name :keyword) |
258 |
|
'si::package-documentation) |
259 |
|
,documentation)) |
260 |
|
) |
261 |
|
(let ((*package* (find-package ,name))) |
262 |
|
,@(when SHADOWed-symbol-names |
263 |
|
`((SHADOW (mapcar #'intern ',SHADOWed-symbol-names)))) |
264 |
|
,@(when SHADOWING-IMPORTed-from-symbol-names-list |
265 |
|
(mapcar #'(lambda (list) |
266 |
|
`(SHADOWING-IMPORT |
267 |
|
(mapcar #'(lambda (symbol) |
268 |
|
(if (find-symbol symbol ,(first list)) |
269 |
|
(intern symbol ,(first list)) |
270 |
|
; FIXME better error messages |
271 |
|
(specific-correctable-error :package-error |
272 |
|
"" ,(first list) |
273 |
|
(format nil "Symbol ~S not present~%" symbol)))) |
274 |
|
',(rest list)))) |
275 |
|
SHADOWING-IMPORTed-from-symbol-names-list)) |
276 |
|
(USE-PACKAGE ',(if (member ':USE options ':test #'option-test) |
277 |
|
(mapcar #'string (option-values ':USE options)) |
278 |
|
"LISP")) |
279 |
|
,@(when IMPORTed-from-symbol-names-list |
280 |
|
(mapcar #'(lambda (list) |
281 |
|
`(IMPORT (mapcar #'(lambda (symbol) |
282 |
|
(if (find-symbol symbol ,(first list)) |
283 |
|
(intern symbol ,(first list)) |
284 |
|
; FIXME better error messages |
285 |
|
(specific-correctable-error :package-error |
286 |
|
"" ,(first list) |
287 |
|
(format nil "Symbol ~S not present~%" symbol)))) |
288 |
|
',(rest list)))) |
289 |
|
IMPORTed-from-symbol-names-list)) |
290 |
|
,@(when INTERNed-symbol-names |
291 |
|
`((mapcar #'INTERN ',INTERNed-symbol-names))) |
292 |
|
,@(when EXPORTed-symbol-names |
293 |
|
`((EXPORT (mapcar #'intern ',EXPORTed-symbol-names)))) |
294 |
|
,@(when EXPORTed-from-package-names |
295 |
|
`((dolist (package ',EXPORTed-from-package-names) |
296 |
|
(do-external-symbols |
297 |
|
(symbol (find-package package)) |
298 |
|
(when (nth 1 (multiple-value-list |
299 |
|
(find-symbol (string symbol)))) |
300 |
|
(EXPORT (list (intern (string symbol))))))))) |
301 |
|
) |
302 |
|
(find-package ,name))))) |
303 |
|
|
304 |
|
;#+excl |
305 |
|
;(excl::defadvice cl:documentation (look-for-package-type :around) |
306 |
|
; (let ((symbol (first excl::arglist)) |
307 |
|
; (type (second excl::arglist))) |
308 |
|
; (if (or (eq ':package (intern (string type) :keyword)) |
309 |
|
; (eq ':defpackage (intern (string type) :keyword))) |
310 |
|
; (or (get symbol 'excl::%package-documentation) |
311 |
|
; (get (intern (string symbol) :keyword) 'excl::%package-documentation)) |
312 |
|
; (values :do-it)))) |
313 |
|
|
314 |
|
;#+symbolics |
315 |
|
;(scl::advise cl:documentation :around look-for-package-type nil |
316 |
|
; (let ((symbol (first scl::arglist)) |
317 |
|
; (type (second scl::arglist))) |
318 |
|
; (if (or (eq ':package (intern (string type) :keyword)) |
319 |
|
; (eq ':defpackage (intern (string type) :keyword))) |
320 |
|
; (or (get symbol ':package-documentation) |
321 |
|
; (get (intern (string symbol) :keyword) ':package-documentation)) |
322 |
|
; (values :do-it)))) |
323 |
|
|
324 |
|
;(pushnew :defpackage *features*) |
325 |
|
;(unintern 'defpackage 'user) |
326 |
|
|
327 |
|
(provide :defpackage) |
328 |
|
(pushnew :defpackage *features*) |
329 |
|
|
330 |
|
(eval-when (load) |
331 |
|
(in-package "USER") |
332 |
|
(unintern 'defpackage 'user) |
333 |
|
(use-package "DEFPACKAGE")) |
334 |
|
|
335 |
|
;;;; ------------------------------------------------------------ |
336 |
|
;;;; End of File |
337 |
|
;;;; ------------------------------------------------------------ |
338 |
|
|