/[gcl]/gcl/lsp/gcl_defpackage.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_defpackage.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:04 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26