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 |
|
(lisp:in-package :DEFPACKAGE) |
69 |
|
|
70 |
|
(export '(defpackage)) |
71 |
|
|
72 |
|
|
73 |
|
(proclaim '(declaration values arglist)) |
74 |
|
|
75 |
|
;#-gcl |
76 |
|
;(eval-when (compile load eval) |
77 |
|
; #-lispm |
78 |
|
; (unless (member :loop *features*) |
79 |
|
; (require :loop #+excl (merge-pathnames "loop" excl::*library-code-fasl-pathname*))) |
80 |
|
; |
81 |
|
; (unless (find-package :common-lisp) |
82 |
|
; (rename-package :lisp :common-lisp (union '("CL" "LISP") (package-nicknames (find-package :lisp)) :test #'string=))) |
83 |
|
; (unless (find-package :common-lisp-user) |
84 |
|
; (rename-package :user :common-lisp-user (union '("CL-USER" "USER") (package-nicknames (find-package :user)) :test #'string=))) |
85 |
|
; |
86 |
|
; #+lispm |
87 |
|
; (shadow (intern "DEFPACKAGE" #+symbolics :scl #+ti :ticl) 'defpackage) |
88 |
|
; (proclaim '(declaration values arglist)) |
89 |
|
; (export 'defpackage 'defpackage) |
90 |
|
; ) |
91 |
|
|
92 |
|
(defmacro DEFPACKAGE (name &rest options) |
93 |
|
(declare (type (or symbol string) name) |
94 |
|
(arglist defined-package-name &rest options) |
95 |
|
(values package)) |
96 |
|
"DEFPACKAGE - DEFINED-PACKAGE-NAME {OPTION}* [Macro] |
97 |
|
|
98 |
|
This creates a new package, or modifies an existing one, whose name is |
99 |
|
DEFINED-PACKAGE-NAME. The DEFINED-PACKAGE-NAME may be a string or a |
100 |
|
symbol; if it is a symbol, only its print name matters, and not what |
101 |
|
package, if any, the symbol happens to be in. The newly created or |
102 |
|
modified package is returned as the value of the DEFPACKAGE form. |
103 |
|
|
104 |
|
Each standard OPTION is a list of keyword (the name of the option) |
105 |
|
and associated arguments. No part of a DEFPACKAGE form is evaluated. |
106 |
|
Except for the :SIZE and :DOCUMENTATION options, more than one option |
107 |
|
of the same kind may occur within the same DEFPACKAGE form. |
108 |
|
|
109 |
|
Valid Options: |
110 |
|
(:documentation string) |
111 |
|
(:size integer) |
112 |
|
(:nicknames {package-name}*) |
113 |
|
(:shadow {symbol-name}*) |
114 |
|
(:shadowing-import-from package-name {symbol-name}*) |
115 |
|
(:use {package-name}*) |
116 |
|
(:import-from package-name {symbol-name}*) |
117 |
|
(:intern {symbol-name}*) |
118 |
|
(:export {symbol-name}*) |
119 |
|
(:export-from {package-name}*) |
120 |
|
|
121 |
|
[Note: :EXPORT-FROM is an extension to DEFPACKAGE. |
122 |
|
If a symbol is interned in the package being created and |
123 |
|
if a symbol with the same print name appears as an external |
124 |
|
symbol of one of the packages in the :EXPORT-FROM option, |
125 |
|
then the symbol is exported from the package being created. |
126 |
|
|
127 |
|
:DOCUMENTATION is an extension to DEFPACKAGE. |
128 |
|
|
129 |
|
:SIZE is used only in Genera and Allegro.]" |
130 |
|
|
131 |
|
(loop for (option) in options |
132 |
|
unless (member option '(:documentation :size :nicknames :shadow :shadowing-import-from :use :import-from :intern :export :export-from)) |
133 |
|
do (cerror "Proceed, ignoring this option." "~s is not a valid DEFPACKAGE option." option)) |
134 |
|
(labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1))) |
135 |
|
(option-values-list (option options) |
136 |
|
(loop for result = (member option options ':test #'option-test) |
137 |
|
then (member option (rest result) ':test #'option-test) |
138 |
|
until (null result) when result collect (rest (first result)))) |
139 |
|
(option-values (option options) |
140 |
|
(loop for result = (member option options ':test #'option-test) |
141 |
|
then (member option (rest result) ':test #'option-test) |
142 |
|
until (null result) when result append (rest (first result))))) |
143 |
|
(loop for option in '(:size :documentation) |
144 |
|
when (<= 2 (count option options ':key #'car)) |
145 |
|
do (warn "DEFPACKAGE option ~s specified more than once. The first value \"~a\" will be used." option (first (option-values option options)))) |
146 |
|
(setq name (string name)) |
147 |
|
(let ((nicknames (mapcar #'string (option-values ':nicknames options))) |
148 |
|
(documentation (first (option-values ':documentation options))) |
149 |
|
(size (first (option-values ':size options))) |
150 |
|
(shadowed-symbol-names (mapcar #'string (option-values ':shadow options))) |
151 |
|
(interned-symbol-names (mapcar #'string (option-values ':intern options))) |
152 |
|
(exported-symbol-names (mapcar #'string (option-values ':export options))) |
153 |
|
(shadowing-imported-from-symbol-names-list (loop for list in (option-values-list ':shadowing-import-from options) |
154 |
|
collect (cons (string (first list)) (mapcar #'string (rest list))))) |
155 |
|
(imported-from-symbol-names-list (loop for list in (option-values-list ':import-from options) |
156 |
|
collect (cons (string (first list)) (mapcar #'string (rest list))))) |
157 |
|
(exported-from-package-names (mapcar #'string (option-values ':export-from options)))) |
158 |
|
(flet ((find-duplicates (&rest lists) |
159 |
|
(let (results) |
160 |
|
(loop for list in lists |
161 |
|
for more on (cdr lists) |
162 |
|
for i from 1 |
163 |
|
do |
164 |
|
(loop for elt in list |
165 |
|
as entry = (find elt results :key #'car :test #'string=) |
166 |
|
unless (member i entry) |
167 |
|
do |
168 |
|
(loop for l2 in more |
169 |
|
for j from (1+ i) |
170 |
|
do |
171 |
|
(if (member elt l2 :test #'string=) |
172 |
|
(if entry |
173 |
|
(nconc entry (list j)) |
174 |
|
(setq entry (car (push (list elt i j) results)))))))) |
175 |
|
results))) |
176 |
|
(loop for duplicate in (find-duplicates shadowed-symbol-names interned-symbol-names |
177 |
|
(loop for list in shadowing-imported-from-symbol-names-list append (rest list)) |
178 |
|
(loop for list in imported-from-symbol-names-list append (rest list))) |
179 |
|
do |
180 |
|
(error "The symbol ~s cannot coexist in these lists:~{ ~s~}" (first duplicate) |
181 |
|
(loop for num in (rest duplicate) |
182 |
|
collect (case num (1 ':SHADOW)(2 ':INTERN)(3 ':SHADOWING-IMPORT-FROM)(4 ':IMPORT-FROM))))) |
183 |
|
(loop for duplicate in (find-duplicates exported-symbol-names interned-symbol-names) |
184 |
|
do |
185 |
|
(error "The symbol ~s cannot coexist in these lists:~{ ~s~}" (first duplicate) |
186 |
|
(loop for num in (rest duplicate) collect (case num (1 ':EXPORT)(2 ':INTERN)))))) |
187 |
|
`(eval-when (load eval compile) |
188 |
|
(if (find-package ,name) |
189 |
|
(progn (rename-package ,name ,name) |
190 |
|
,@(when nicknames `((rename-package ,name ,name ',nicknames))) |
191 |
|
#+(or symbolics excl) |
192 |
|
,@(when size |
193 |
|
#+symbolics `((when (> ,size (pkg-max-number-of-symbols (find-package ,name))) |
194 |
|
(pkg-rehash (find-package ,name) ,size))) |
195 |
|
#+excl `((let ((tab (excl::package-internal-symbols (find-package ,name)))) |
196 |
|
(when (hash-table-p tab) |
197 |
|
(setf (excl::ha_rehash-size tab) ,size))))) |
198 |
|
,@(when (not (null (member ':use options ':key #'car))) |
199 |
|
`((unuse-package (package-use-list (find-package ,name)) ,name)))) |
200 |
|
(make-package ,name ':use 'nil ':nicknames ',nicknames ,@(when size #+lispm `(:size ,size) #+excl `(:internal-symbols ,size)))) |
201 |
|
,@(when documentation `((setf (get ',(intern name :keyword) #+excl 'excl::%package-documentation #-excl ':package-documentation) ,documentation))) |
202 |
|
(let ((*package* (find-package ,name))) |
203 |
|
,@(when SHADOWed-symbol-names `((SHADOW (mapcar #'intern ',SHADOWed-symbol-names)))) |
204 |
|
,@(when SHADOWING-IMPORTed-from-symbol-names-list |
205 |
|
(mapcar #'(lambda (list) |
206 |
|
`(SHADOWING-IMPORT (mapcar #'(lambda (symbol) (intern symbol ,(first list))) ',(rest list)))) |
207 |
|
SHADOWING-IMPORTed-from-symbol-names-list)) |
208 |
|
(USE-PACKAGE ',(or (mapcar #'string (option-values ':USE options)) "CL")) |
209 |
|
,@(when IMPORTed-from-symbol-names-list |
210 |
|
(mapcar #'(lambda (list) `(IMPORT (mapcar #'(lambda (symbol) (intern symbol ,(first list))) ',(rest list)))) |
211 |
|
IMPORTed-from-symbol-names-list)) |
212 |
|
,@(when INTERNed-symbol-names `((mapcar #'INTERN ',INTERNed-symbol-names))) |
213 |
|
,@(when EXPORTed-symbol-names `((EXPORT (mapcar #'intern ',EXPORTed-symbol-names)))) |
214 |
|
,@(when EXPORTed-from-package-names |
215 |
|
`((dolist (package ',EXPORTed-from-package-names) |
216 |
|
(do-external-symbols (symbol (find-package package)) |
217 |
|
(when (nth 1 (multiple-value-list (find-symbol (string symbol)))) |
218 |
|
(EXPORT (list (intern (string symbol))))))))) |
219 |
|
) |
220 |
|
(find-package ,name))))) |
221 |
|
|
222 |
|
;#+excl |
223 |
|
;(excl::defadvice cl:documentation (look-for-package-type :around) |
224 |
|
; (let ((symbol (first excl::arglist)) |
225 |
|
; (type (second excl::arglist))) |
226 |
|
; (if (or (eq ':package (intern (string type) :keyword)) |
227 |
|
; (eq ':defpackage (intern (string type) :keyword))) |
228 |
|
; (or (get symbol 'excl::%package-documentation) |
229 |
|
; (get (intern (string symbol) :keyword) 'excl::%package-documentation)) |
230 |
|
; (values :do-it)))) |
231 |
|
|
232 |
|
;#+symbolics |
233 |
|
;(scl::advise cl:documentation :around look-for-package-type nil |
234 |
|
; (let ((symbol (first scl::arglist)) |
235 |
|
; (type (second scl::arglist))) |
236 |
|
; (if (or (eq ':package (intern (string type) :keyword)) |
237 |
|
; (eq ':defpackage (intern (string type) :keyword))) |
238 |
|
; (or (get symbol ':package-documentation) |
239 |
|
; (get (intern (string symbol) :keyword) ':package-documentation)) |
240 |
|
; (values :do-it)))) |
241 |
|
|
242 |
|
(provide :defpackage) |
243 |
|
(pushnew :defpackage *features*) |
244 |
|
|
245 |
|
(eval-when (load) |
246 |
|
(in-package "USER") |
247 |
|
(unintern 'defpackage 'user) |
248 |
|
(use-package "DEFPACKAGE")) |
249 |
|
|
250 |
|
;;;; ------------------------------------------------------------ |
251 |
|
;;;; End of File |
252 |
|
;;;; ------------------------------------------------------------ |
253 |
|
|