/[gcl]/gcl/pcl/gcl_pcl_pkg.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_pkg.lisp

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

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
1    ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
2    ;;;
3    ;;; *************************************************************************
4    ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5    ;;; All rights reserved.
6    ;;;
7    ;;; Use and copying of this software and preparation of derivative works
8    ;;; based upon this software are permitted.  Any distribution of this
9    ;;; software or derivative works must comply with all applicable United
10    ;;; States export control laws.
11    ;;;
12    ;;; This software is made available AS IS, and Xerox Corporation makes no
13    ;;; warranty about the software, its performance or its conformity to any
14    ;;; specification.
15    ;;;
16    ;;; Any person obtaining a copy of this software is requested to send their
17    ;;; name and post office or electronic mail address to:
18    ;;;   CommonLoops Coordinator
19    ;;;   Xerox PARC
20    ;;;   3333 Coyote Hill Rd.
21    ;;;   Palo Alto, CA 94304
22    ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23    ;;;
24    ;;; Suggestions, comments and requests for improvements are also welcome.
25    ;;; *************************************************************************
26    ;;;
27    
28    (in-package :user)
29    
30    ;;; From defsys.lisp
31    (eval-when (compile load eval)
32    
33    (if (find-package ':walker)
34        (use-package '(:lisp) ':walker)
35        (make-package ':walker :use '(:lisp)))
36    
37    (if (find-package ':iterate)
38        (use-package '(:lisp :walker) ':iterate)
39        (make-package ':iterate :use '(:lisp :walker)))
40    
41    (if (find-package ':pcl)
42        (use-package '(:walker :iterate :lisp) ':pcl)
43        (make-package ':pcl :use '(:walker :iterate :lisp)))
44    
45    (export (intern (symbol-name :iterate)          ;Have to do this here,
46                    (find-package :iterate))        ;because in the defsystem
47            (find-package :iterate))                ;(later in this file)
48                                                    ;we use the symbol iterate
49                                                    ;to name the file
50    )
51    
52    (in-package :walker)
53    
54    (export '(define-walker-template
55              walk-form
56              walk-form-expand-macros-p
57              nested-walk-form
58              variable-lexical-p
59              variable-special-p
60              variable-globally-special-p
61              *variable-declarations*
62              variable-declaration
63              macroexpand-all
64              ))
65    
66    (in-package :iterate)
67    
68    (export '(iterate iterate* gathering gather with-gathering interval elements
69              list-elements list-tails plist-elements eachtime while until
70              collecting joining maximizing minimizing summing
71              *iterate-warnings*))
72    
73    (in-package :pcl)
74    
75    ;;;
76    ;;; Some CommonLisps have more symbols in the Lisp package than the ones that
77    ;;; are explicitly specified in CLtL.  This causes trouble. Any Lisp that has
78    ;;; extra symbols in the Lisp package should shadow those symbols in the PCL
79    ;;; package.
80    ;;;
81    #+TI
82    (shadow '(string-append once-only destructuring-bind
83              memq assq delq neq true false
84              without-interrupts
85              defmethod)
86            *the-pcl-package*)
87    
88    #+CMU
89    (shadow '(destructuring-bind)
90            *the-pcl-package*)
91    #+cmu17
92    (shadow '(find-class class-name class-of
93                         class built-in-class structure-class
94                         standard-class)
95            *the-pcl-package*)
96    
97    #+GCLisp
98    (shadow '(string-append memq assq delq neq make-instance)
99            *the-pcl-package*)
100    
101    (defun use-package-pcl (&optional (*package* *package*))
102      (shadowing-import
103       (let ((*package* *the-pcl-package*))
104         (mapcar #'intern
105                 #+cmu17 '("FIND-CLASS" "CLASS-NAME" "CLASS-OF"
106                           "CLASS" "BUILT-IN-CLASS" "STRUCTURE-CLASS"
107                           "STANDARD-CLASS")
108                 #+TI '("DEFMETHOD")
109                 #+GCLisp '("MAKE-INSTANCE")
110                 #-(or cmu17 TI GCLisp) '())))
111      (use-package *the-pcl-package*))
112    
113    #+Genera
114    (shadowing-import '(zl:arglist zwei:indentation) *the-pcl-package*)
115    
116    #+Lucid
117    (import '(#-LCL3.0 system:arglist #+LCL3.0 lcl:arglist
118              system:structurep system:structure-type system:structure-length)
119            *the-pcl-package*)
120      
121    #+lucid
122    (#-LCL3.0 progn #+LCL3.0 lcl:handler-bind
123        #+LCL3.0 ((lcl:warning #'(lambda (condition)
124                                   (declare (ignore condition))
125                                   (lcl:muffle-warning))))
126    (let ((importer
127            #+LCL3.0 #'sys:import-from-lucid-pkg
128            #-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID")))
129                       (if (and x (fboundp x))
130                           (symbol-function x)
131                           ;; Only the #'(lambda (x) ...) below is really needed,
132                           ;;  but when available, the "internal" function
133                           ;;  'import-from-lucid-pkg' provides better checking.
134                           #'(lambda (name)
135                               (import (intern name "LUCID")))))))
136      ;;
137      ;; We need the following "internal", undocumented Lucid goodies:
138      (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE"
139                       #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE"))
140    
141      ;;
142      ;; For without-interrupts.
143      ;;
144      #+LCL3.0
145      (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER"))
146    
147      ;;
148      ;; We import the following symbols, because in 2.1 Lisps they have to be
149      ;;  accessed as SYS:<foo>, whereas in 3.0 lisps, they are homed in the
150      ;;  LUCID-COMMON-LISP package.
151      (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*"))
152      ;;
153      ;; We import the following symbols, because in 2.1 Lisps they have to be
154      ;;  accessed as LUCID::<foo>, whereas in 3.0 lisps, they have to be
155      ;;  accessed as SYS:<foo>
156      (mapc importer '(
157                       "NEW-STRUCTURE"      "STRUCTURE-REF"
158                       "STRUCTUREP"         "STRUCTURE-TYPE"  "STRUCTURE-LENGTH"
159                       "PROCEDUREP"         "PROCEDURE-SYMBOL"
160                       "PROCEDURE-REF"      "SET-PROCEDURE-REF"
161                       ))
162    ; ;;
163    ; ;;  The following is for the "patch" to the general defstruct printer.
164    ; (mapc importer '(
165    ;                  "OUTPUT-STRUCTURE"     "DEFSTRUCT-INFO"
166    ;                  "OUTPUT-TERSE-OBJECT"  "DEFAULT-STRUCTURE-PRINT"
167    ;                  "STRUCTURE-TYPE"       "*PRINT-OUTPUT*"
168    ;                  ))
169      ;;
170      ;; The following is for a "patch" affecting compilation of %logand&.
171      ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas
172      ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS
173      ;; on *FEATURES*, so this conditionalizes correctly for APOLLO.
174      #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
175      (mapc importer '("COPY-STRUCTURE"  "GET-FDESC"  "SET-FDESC"))
176      
177      nil))
178    
179    #+kcl
180    (progn
181    (import '(si:structurep si:structure-def si:structure-ref))
182    (shadow 'lisp:dotimes)
183    )
184    #+kcl
185    (in-package "SI")
186    #+kcl
187    (export '(%structure-name
188              %compiled-function-name
189              %set-compiled-function-name
190              %instance-ref
191              %set-instance-ref))
192    #+kcl
193    (in-package 'pcl)
194    
195    #+cmu (shadow 'lisp:dotimes)
196    
197    #+cmu
198    (import '(kernel:funcallable-instance-p)
199            *the-pcl-package*)
200    
201    
202    (shadow 'documentation)
203    
204    
205    ;;;                                            
206    ;;; These come from the index pages of 88-002R.
207    ;;;
208    ;;;
209    (eval-when (compile load eval)  
210      
211    (defvar *exports* '(add-method
212                        built-in-class
213                        call-method
214                        call-next-method
215                        change-class
216                        class-name
217                        class-of
218                        compute-applicable-methods
219                        defclass
220                        defgeneric
221                        define-method-combination
222                        defmethod
223                        ensure-generic-function
224                        find-class
225                        find-method
226                        function-keywords
227                        generic-flet
228                        generic-labels
229                        initialize-instance
230                        invalid-method-error
231                        make-instance
232                        make-instances-obsolete
233                        method-combination-error
234                        method-qualifiers
235                        next-method-p
236                        no-applicable-method
237                        no-next-method
238                        print-object
239                        reinitialize-instance
240                        remove-method
241                        shared-initialize
242                        slot-boundp
243                        slot-exists-p
244                        slot-makunbound
245                        slot-missing
246                        slot-unbound
247                        slot-value
248                        standard
249                        standard-class
250                        standard-generic-function
251                        standard-method
252                        standard-object
253                        structure-class
254                        #-cmu17 symbol-macrolet
255                        update-instance-for-different-class
256                        update-instance-for-redefined-class
257                        with-accessors
258                        with-added-methods
259                        with-slots
260                        ))
261    
262    );eval-when
263    
264    #-(or KCL IBCL CMU)
265    (export *exports* *the-pcl-package*)
266    
267    #+CMU
268    (export '#.*exports* *the-pcl-package*)
269    
270    #+(or KCL IBCL)
271    (mapc 'export (list *exports*) (list *the-pcl-package*))
272    
273    
274    (eval-when (compile load eval)  
275      
276    (defvar *class-exports*
277            '(standard-instance
278              funcallable-standard-instance
279              generic-function
280              standard-generic-function
281              method
282              standard-method
283              standard-accessor-method
284              standard-reader-method
285              standard-writer-method
286              method-combination
287              slot-definition
288              direct-slot-definition
289              effective-slot-definition
290              standard-slot-definition
291              standard-direct-slot-definition
292              standard-effective-slot-definition
293              specializer
294              eql-specializer
295              built-in-class
296              forward-referenced-class
297              standard-class
298              funcallable-standard-class))
299    
300    (defvar *chapter-6-exports*
301            '(add-dependent
302              add-direct-method
303              add-direct-subclass
304              add-method
305              allocate-instance
306              class-default-initargs
307              class-direct-default-initargs
308              class-direct-slots
309              class-direct-subclasses
310              class-direct-superclasses
311              class-finalized-p
312              class-precedence-list
313              class-prototype
314              class-slots
315              compute-applicable-methods
316              compute-applicable-methods-using-classes
317              compute-class-precedence-list
318              compute-discriminating-function
319              compute-effective-method
320              compute-effective-slot-definition
321              compute-slots
322              direct-slot-definition-class
323              effective-slot-definition-class
324              ensure-class
325              ensure-class-using-class
326              ensure-generic-function
327              ensure-generic-function-using-class
328              eql-specializer-instance
329              extract-lambda-list
330              extract-specializer-names
331              finalize-inheritance
332              find-method-combination
333              funcallable-standard-instance-access
334              generic-function-argument-precedence-order
335              generic-function-declarations
336              generic-function-lambda-list
337              generic-function-method-class
338              generic-function-method-combination
339              generic-function-methods
340              generic-function-name
341              intern-eql-specializer
342              make-instance
343              make-method-lambda
344              map-dependents
345              method-function
346              method-generic-function
347              method-lambda-list
348              method-specializers
349              method-qualifiers
350              accessor-method-slot-definition
351              reader-method-class
352              remove-dependent
353              remove-direct-method
354              remove-direct-subclass
355              remove-method
356              set-funcallable-instance-function
357              slot-boundp-using-class
358              slot-definition-allocation
359              slot-definition-initargs
360              slot-definition-initform
361              slot-definition-initfunction
362              slot-definition-location
363              slot-definition-name
364              slot-definition-readers
365              slot-definition-writers
366              slot-definition-type
367              slot-makunbound-using-class
368              slot-value-using-class
369              specializer-direct-generic-function
370              specializer-direct-methods
371              standard-instance-access
372              update-dependent
373              validate-superclass
374              writer-method-class
375              ))
376    
377    );eval-when
378    
379    #-(or KCL IBCL)
380    (export *class-exports* *the-pcl-package*)
381    
382    #+(or KCL IBCL)
383    (mapc 'export (list *class-exports*) (list *the-pcl-package*))
384    
385    #-(or KCL IBCL)
386    (export *chapter-6-exports* *the-pcl-package*)
387    
388    #+(or KCL IBCL)
389    (mapc 'export (list *chapter-6-exports*) (list *the-pcl-package*))
390    
391    (defvar *slot-accessor-name-package*
392      (or (find-package :slot-accessor-name)
393          (make-package :slot-accessor-name
394                        :use '()
395                        :nicknames '(:s-a-n))))
396    
397    #+kcl
398    (when (get 'si::basic-wrapper 'si::s-data)
399      (import (mapcar #'(lambda (s) (intern (symbol-name s) "SI"))
400                      '(:copy-structure-header :swap-structure-contents :set-structure-def
401                        :%instance-ref :%set-instance-ref
402                        
403                        :cache-number-vector :cache-number-vector-length
404                        :wrapper-cache-number-adds-ok :wrapper-cache-number-length
405                        :wrapper-cache-number-mask :wrapper-cache-number-vector-length
406                        :wrapper-layout :wrapper-cache-number-vector
407                        :wrapper-state :wrapper-class :wrapper-length))))

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