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

Diff of /gcl/lsp/defpackage.lsp

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

revision 1.1 by camm, Thu Jan 24 18:43:07 2002 UTC revision 1.2 by camm, Sun Feb 3 18:44:07 2002 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    (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    

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