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)))) |