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 |
|
;;; Macros global variable definitions, and other random support stuff used |
28 |
|
;;; by the rest of the system. |
29 |
|
;;; |
30 |
|
;;; For simplicity (not having to use eval-when a lot), this file must be |
31 |
|
;;; loaded before it can be compiled. |
32 |
|
;;; |
33 |
|
|
34 |
|
(in-package :pcl) |
35 |
|
|
36 |
|
(proclaim '(declaration |
37 |
|
#-Genera values ;I use this so that Zwei can remind |
38 |
|
;me what values a function returns. |
39 |
|
|
40 |
|
#-Genera arglist ;Tells me what the pretty arglist |
41 |
|
;of something (which probably takes |
42 |
|
;&rest args) is. |
43 |
|
|
44 |
|
#-Genera indentation ;Tells ZWEI how to indent things |
45 |
|
;like defclass. |
46 |
|
class |
47 |
|
variable-rebinding |
48 |
|
pcl-fast-call |
49 |
|
method-name |
50 |
|
method-lambda-list |
51 |
|
)) |
52 |
|
|
53 |
|
;;; Age old functions which CommonLisp cleaned-up away. They probably exist |
54 |
|
;;; in other packages in all CommonLisp implementations, but I will leave it |
55 |
|
;;; to the compiler to optimize into calls to them. |
56 |
|
;;; |
57 |
|
;;; Common Lisp BUG: |
58 |
|
;;; Some Common Lisps define these in the Lisp package which causes |
59 |
|
;;; all sorts of lossage. Common Lisp should explictly specify which |
60 |
|
;;; symbols appear in the Lisp package. |
61 |
|
;;; |
62 |
|
(eval-when (compile load eval) |
63 |
|
|
64 |
|
(defmacro memq (item list) `(member ,item ,list :test #'eq)) |
65 |
|
(defmacro assq (item list) `(assoc ,item ,list :test #'eq)) |
66 |
|
(defmacro rassq (item list) `(rassoc ,item ,list :test #'eq)) |
67 |
|
(defmacro delq (item list) `(delete ,item ,list :test #'eq)) |
68 |
|
(defmacro posq (item list) `(position ,item ,list :test #'eq)) |
69 |
|
(defmacro neq (x y) `(not (eq ,x ,y))) |
70 |
|
|
71 |
|
|
72 |
|
(defun make-caxr (n form) |
73 |
|
(if (< n 4) |
74 |
|
`(,(nth n '(car cadr caddr cadddr)) ,form) |
75 |
|
(make-caxr (- n 4) `(cddddr ,form)))) |
76 |
|
|
77 |
|
(defun make-cdxr (n form) |
78 |
|
(cond ((zerop n) form) |
79 |
|
((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form)) |
80 |
|
(t (make-cdxr (- n 4) `(cddddr ,form))))) |
81 |
|
) |
82 |
|
|
83 |
|
;(deftype non-negative-fixnum () |
84 |
|
; '(and fixnum (integer 0 *))) |
85 |
|
|
86 |
|
(defun true (&rest ignore) (declare (ignore ignore)) t) |
87 |
|
(defun false (&rest ignore) (declare (ignore ignore)) nil) |
88 |
|
(defun zero (&rest ignore) (declare (ignore ignore)) 0) |
89 |
|
|
90 |
|
(defun make-plist (keys vals) |
91 |
|
(if (null vals) |
92 |
|
() |
93 |
|
(list* (car keys) |
94 |
|
(car vals) |
95 |
|
(make-plist (cdr keys) (cdr vals))))) |
96 |
|
|
97 |
|
(defun remtail (list tail) |
98 |
|
(if (eq list tail) () (cons (car list) (remtail (cdr list) tail)))) |
99 |
|
|
100 |
|
;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just |
101 |
|
;;; lifted it from there but I am honest. Not only that but this one is |
102 |
|
;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more |
103 |
|
;;; like rebuilding Rome. |
104 |
|
(defmacro once-only (vars &body body) |
105 |
|
(let ((gensym-var (gensym)) |
106 |
|
(run-time-vars (gensym)) |
107 |
|
(run-time-vals (gensym)) |
108 |
|
(expand-time-val-forms ())) |
109 |
|
(dolist (var vars) |
110 |
|
(push `(if (or (symbolp ,var) |
111 |
|
(numberp ,var) |
112 |
|
(and (listp ,var) |
113 |
|
(member (car ,var) '(quote function)))) |
114 |
|
,var |
115 |
|
(let ((,gensym-var (gensym))) |
116 |
|
(push ,gensym-var ,run-time-vars) |
117 |
|
(push ,var ,run-time-vals) |
118 |
|
,gensym-var)) |
119 |
|
expand-time-val-forms)) |
120 |
|
`(let* (,run-time-vars |
121 |
|
,run-time-vals |
122 |
|
(wrapped-body |
123 |
|
(let ,(mapcar #'list vars (reverse expand-time-val-forms)) |
124 |
|
,@body))) |
125 |
|
`(let ,(mapcar #'list (reverse ,run-time-vars) |
126 |
|
(reverse ,run-time-vals)) |
127 |
|
,wrapped-body)))) |
128 |
|
|
129 |
|
(eval-when (compile load eval) |
130 |
|
(defun extract-declarations (body &optional environment) |
131 |
|
;;(declare (values documentation declarations body)) |
132 |
|
(let (documentation declarations form) |
133 |
|
(when (and (stringp (car body)) |
134 |
|
(cdr body)) |
135 |
|
(setq documentation (pop body))) |
136 |
|
(block outer |
137 |
|
(loop |
138 |
|
(when (null body) (return-from outer nil)) |
139 |
|
(setq form (car body)) |
140 |
|
(when (block inner |
141 |
|
(loop (cond ((not (listp form)) |
142 |
|
(return-from outer nil)) |
143 |
|
((eq (car form) 'declare) |
144 |
|
(return-from inner 't)) |
145 |
|
(t |
146 |
|
(multiple-value-bind (newform macrop) |
147 |
|
(macroexpand-1 form environment) |
148 |
|
(if (or (not (eq newform form)) macrop) |
149 |
|
(setq form newform) |
150 |
|
(return-from outer nil))))))) |
151 |
|
(pop body) |
152 |
|
(dolist (declaration (cdr form)) |
153 |
|
(push declaration declarations))))) |
154 |
|
(values documentation |
155 |
|
(and declarations `((declare ,.(nreverse declarations)))) |
156 |
|
body))) |
157 |
|
) |
158 |
|
|
159 |
|
(defun get-declaration (name declarations &optional default) |
160 |
|
(dolist (d declarations default) |
161 |
|
(dolist (form (cdr d)) |
162 |
|
(when (and (consp form) (eq (car form) name)) |
163 |
|
(return-from get-declaration (cdr form)))))) |
164 |
|
|
165 |
|
|
166 |
|
#+Lucid |
167 |
|
(eval-when (compile load eval) |
168 |
|
(eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid))))) |
169 |
|
|
170 |
|
(defvar *keyword-package* (find-package 'keyword)) |
171 |
|
|
172 |
|
(defun make-keyword (symbol) |
173 |
|
(intern (symbol-name symbol) *keyword-package*)) |
174 |
|
|
175 |
|
(eval-when (compile load eval) |
176 |
|
|
177 |
|
(defun string-append (&rest strings) |
178 |
|
(setq strings (copy-list strings)) ;The explorer can't even |
179 |
|
;rplaca an &rest arg? |
180 |
|
(do ((string-loc strings (cdr string-loc))) |
181 |
|
((null string-loc) |
182 |
|
(apply #'concatenate 'string strings)) |
183 |
|
(rplaca string-loc (string (car string-loc))))) |
184 |
|
) |
185 |
|
|
186 |
|
(defun symbol-append (sym1 sym2 &optional (package *package*)) |
187 |
|
(intern (string-append sym1 sym2) package)) |
188 |
|
|
189 |
|
(defmacro check-member (place list &key (test #'eql) (pretty-name place)) |
190 |
|
(once-only (place list) |
191 |
|
`(or (member ,place ,list :test ,test) |
192 |
|
(error "The value of ~A, ~S is not one of ~S." |
193 |
|
',pretty-name ,place ,list)))) |
194 |
|
|
195 |
|
(defmacro alist-entry (alist key make-entry-fn) |
196 |
|
(once-only (alist key) |
197 |
|
`(or (assq ,key ,alist) |
198 |
|
(progn (setf ,alist (cons (,make-entry-fn ,key) ,alist)) |
199 |
|
(car ,alist))))) |
200 |
|
|
201 |
|
;;; A simple version of destructuring-bind. |
202 |
|
|
203 |
|
;;; This does no more error checking than CAR and CDR themselves do. Some |
204 |
|
;;; attempt is made to be smart about preserving intermediate values. It |
205 |
|
;;; could be better, although the only remaining case should be easy for |
206 |
|
;;; the compiler to spot since it compiles to PUSH POP. |
207 |
|
;;; |
208 |
|
;;; Common Lisp BUG: |
209 |
|
;;; Common Lisp should have destructuring-bind. |
210 |
|
;;; |
211 |
|
;#-gcl |
212 |
|
; FIXME use regular destructuring-bind |
213 |
|
(defmacro pcl-destructuring-bind (pattern form &body body) |
214 |
|
(multiple-value-bind (ignore declares body) |
215 |
|
(extract-declarations body) |
216 |
|
(declare (ignore ignore)) |
217 |
|
(multiple-value-bind (setqs binds) |
218 |
|
(destructure pattern form) |
219 |
|
`(let ,binds |
220 |
|
,@declares |
221 |
|
,@setqs |
222 |
|
(progn .destructure-form.) |
223 |
|
. ,body)))) |
224 |
|
|
225 |
|
(eval-when (compile load eval) |
226 |
|
(defun destructure (pattern form) |
227 |
|
;;(declare (values setqs binds)) |
228 |
|
(let ((*destructure-vars* ()) |
229 |
|
(setqs ())) |
230 |
|
(declare (special *destructure-vars*)) |
231 |
|
(setq *destructure-vars* '(.destructure-form.) |
232 |
|
setqs (list `(setq .destructure-form. ,form)) |
233 |
|
form '.destructure-form.) |
234 |
|
(values (nconc setqs (nreverse (destructure-internal pattern form))) |
235 |
|
(delete nil *destructure-vars*)))) |
236 |
|
|
237 |
|
(defun destructure-internal (pattern form) |
238 |
|
;; When we are called, pattern must be a list. Form should be a symbol |
239 |
|
;; which we are free to setq containing the value to be destructured. |
240 |
|
;; Optimizations are performed for the last element of pattern cases. |
241 |
|
;; we assume that the compiler is smart about gensyms which are bound |
242 |
|
;; but only for a short period of time. |
243 |
|
(declare (special *destructure-vars*)) |
244 |
|
(let ((gensym (gensym)) |
245 |
|
(pending-pops 0) |
246 |
|
(var nil) |
247 |
|
(setqs ())) |
248 |
|
(labels |
249 |
|
((make-pop (var form pop-into) |
250 |
|
(prog1 |
251 |
|
(cond ((zerop pending-pops) |
252 |
|
`(progn ,(and var `(setq ,var (car ,form))) |
253 |
|
,(and pop-into `(setq ,pop-into (cdr ,form))))) |
254 |
|
((null pop-into) |
255 |
|
(and var `(setq ,var ,(make-caxr pending-pops form)))) |
256 |
|
(t |
257 |
|
`(progn (setq ,pop-into ,(make-cdxr pending-pops form)) |
258 |
|
,(and var `(setq ,var (pop ,pop-into)))))) |
259 |
|
(setq pending-pops 0)))) |
260 |
|
(do ((pat pattern (cdr pat))) |
261 |
|
((null pat) ()) |
262 |
|
(if (symbolp (setq var (car pat))) |
263 |
|
(progn |
264 |
|
#-:coral (unless (memq var '(nil ignore)) |
265 |
|
(push var *destructure-vars*)) |
266 |
|
#+:coral (push var *destructure-vars*) |
267 |
|
(cond ((null (cdr pat)) |
268 |
|
(push (make-pop var form ()) setqs)) |
269 |
|
((symbolp (cdr pat)) |
270 |
|
(push (make-pop var form (cdr pat)) setqs) |
271 |
|
(push (cdr pat) *destructure-vars*) |
272 |
|
(return ())) |
273 |
|
#-:coral |
274 |
|
((memq var '(nil ignore)) (incf pending-pops)) |
275 |
|
#-:coral |
276 |
|
((memq (cadr pat) '(nil ignore)) |
277 |
|
(push (make-pop var form ()) setqs) |
278 |
|
(incf pending-pops 1)) |
279 |
|
(t |
280 |
|
(push (make-pop var form form) setqs)))) |
281 |
|
(progn |
282 |
|
(push `(let ((,gensym ())) |
283 |
|
,(make-pop gensym |
284 |
|
form |
285 |
|
(if (symbolp (cdr pat)) (cdr pat) form)) |
286 |
|
,@(nreverse |
287 |
|
(destructure-internal |
288 |
|
(if (consp pat) (car pat) pat) |
289 |
|
gensym))) |
290 |
|
setqs) |
291 |
|
(when (symbolp (cdr pat)) |
292 |
|
(push (cdr pat) *destructure-vars*) |
293 |
|
(return))))) |
294 |
|
setqs))) |
295 |
|
) |
296 |
|
|
297 |
|
|
298 |
|
(defmacro collecting-once (&key initial-value) |
299 |
|
`(let* ((head ,initial-value) |
300 |
|
(tail ,(and initial-value `(last head)))) |
301 |
|
(values #'(lambda (value) |
302 |
|
(if (null head) |
303 |
|
(setq head (setq tail (list value))) |
304 |
|
(unless (memq value head) |
305 |
|
(setq tail |
306 |
|
(cdr (rplacd tail (list value))))))) |
307 |
|
#'(lambda nil head)))) |
308 |
|
|
309 |
|
(defmacro doplist ((key val) plist &body body &environment env) |
310 |
|
(multiple-value-bind (doc decls bod) |
311 |
|
(extract-declarations body env) |
312 |
|
(declare (ignore doc)) |
313 |
|
`(let ((.plist-tail. ,plist) ,key ,val) |
314 |
|
,@decls |
315 |
|
(loop (when (null .plist-tail.) (return nil)) |
316 |
|
(setq ,key (pop .plist-tail.)) |
317 |
|
(when (null .plist-tail.) |
318 |
|
(specific-error :invalid-form |
319 |
|
"Malformed plist in doplist, odd number of elements.")) |
320 |
|
(when (not (symbolp ,key)) |
321 |
|
(specific-error :invalid-form |
322 |
|
"Supplied key is not a symbol.")) |
323 |
|
(setq ,val (pop .plist-tail.)) |
324 |
|
(progn ,@bod))))) |
325 |
|
|
326 |
|
(defmacro if* (condition true &rest false) |
327 |
|
`(if ,condition ,true (progn ,@false))) |
328 |
|
|
329 |
|
(defmacro dolist-carefully ((var list improper-list-handler) &body body) |
330 |
|
`(let ((,var nil) |
331 |
|
(.dolist-carefully. ,list)) |
332 |
|
(loop (when (null .dolist-carefully.) (return nil)) |
333 |
|
(if (consp .dolist-carefully.) |
334 |
|
(progn |
335 |
|
(setq ,var (pop .dolist-carefully.)) |
336 |
|
,@body) |
337 |
|
(,improper-list-handler))))) |
338 |
|
|
339 |
|
;; |
340 |
|
;;;;;; printing-random-thing |
341 |
|
;; |
342 |
|
;;; Similar to printing-random-object in the lisp machine but much simpler |
343 |
|
;;; and machine independent. |
344 |
|
(defmacro printing-random-thing ((thing stream) &body body) |
345 |
|
#+cmu17 |
346 |
|
`(print-unreadable-object (,thing ,stream :identity t) ,@body) |
347 |
|
#-cmu17 |
348 |
|
(once-only (thing stream) |
349 |
|
`(progn |
350 |
|
#+cmu |
351 |
|
(when *print-readably* |
352 |
|
(error "~S cannot be printed readably." ,thing)) |
353 |
|
(format ,stream "#<") |
354 |
|
,@body |
355 |
|
(format ,stream " ") |
356 |
|
(printing-random-thing-internal ,thing ,stream) |
357 |
|
(format ,stream ">")))) |
358 |
|
|
359 |
|
(defun printing-random-thing-internal (thing stream) |
360 |
|
(declare (ignore thing stream)) |
361 |
|
nil) |
362 |
|
|
363 |
|
;; |
364 |
|
;;;;;; |
365 |
|
;; |
366 |
|
|
367 |
|
(defun capitalize-words (string &optional (dashes-p t)) |
368 |
|
(let ((string (copy-seq (string string)))) |
369 |
|
(declare (string string)) |
370 |
|
(do* ((flag t flag) |
371 |
|
(length (length string) length) |
372 |
|
(char nil char) |
373 |
|
(i 0 (+ i 1))) |
374 |
|
((= i length) string) |
375 |
|
(setq char (elt string i)) |
376 |
|
(cond ((both-case-p char) |
377 |
|
(if flag |
378 |
|
(and (setq flag (lower-case-p char)) |
379 |
|
(setf (elt string i) (char-upcase char))) |
380 |
|
(and (not flag) (setf (elt string i) (char-downcase char)))) |
381 |
|
(setq flag nil)) |
382 |
|
((char-equal char #\-) |
383 |
|
(setq flag t) |
384 |
|
(unless dashes-p (setf (elt string i) #\space))) |
385 |
|
(t (setq flag nil)))))) |
386 |
|
|
387 |
|
#-(or lucid kcl) |
388 |
|
(eval-when (compile load eval) |
389 |
|
;(warn "****** Things will go faster if you fix define-compiler-macro") |
390 |
|
) |
391 |
|
|
392 |
|
#-cmu |
393 |
|
(defmacro define-compiler-macro (name arglist &body body) |
394 |
|
#+(or lucid kcl) |
395 |
|
`(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro |
396 |
|
,name ,arglist |
397 |
|
,@body) |
398 |
|
#-(or kcl lucid) |
399 |
|
(declare (ignore name arglist body)) |
400 |
|
#-(or kcl lucid) |
401 |
|
nil) |
402 |
|
|
403 |
|
|
404 |
|
;;; |
405 |
|
;;; FIND-CLASS |
406 |
|
;;; |
407 |
|
;;; This is documented in the CLOS specification. |
408 |
|
;;; |
409 |
|
(defvar *find-class* (make-hash-table :test #'eq)) |
410 |
|
|
411 |
|
(defun make-constant-function (value) |
412 |
|
#'(lambda (object) |
413 |
|
(declare (ignore object)) |
414 |
|
value)) |
415 |
|
|
416 |
|
(defun function-returning-nil (x) |
417 |
|
(declare (ignore x)) |
418 |
|
nil) |
419 |
|
|
420 |
|
(defun function-returning-t (x) |
421 |
|
(declare (ignore x)) |
422 |
|
t) |
423 |
|
|
424 |
|
(defmacro find-class-cell-class (cell) |
425 |
|
`(car ,cell)) |
426 |
|
|
427 |
|
(defmacro find-class-cell-predicate (cell) |
428 |
|
`(cadr ,cell)) |
429 |
|
|
430 |
|
(defmacro find-class-cell-make-instance-function-keys (cell) |
431 |
|
`(cddr ,cell)) |
432 |
|
|
433 |
|
(defmacro make-find-class-cell (class-name) |
434 |
|
(declare (ignore class-name)) |
435 |
|
'(list* nil #'function-returning-nil nil)) |
436 |
|
|
437 |
|
(defun find-class-cell (symbol &optional dont-create-p) |
438 |
|
(or (gethash symbol *find-class*) |
439 |
|
(unless dont-create-p |
440 |
|
(unless (legal-class-name-p symbol) |
441 |
|
(error "~S is not a legal class name." symbol)) |
442 |
|
(setf (gethash symbol *find-class*) (make-find-class-cell symbol))))) |
443 |
|
|
444 |
|
(defvar *create-classes-from-internal-structure-definitions-p* t) |
445 |
|
|
446 |
|
(defun find-class-from-cell (symbol cell &optional (errorp t)) |
447 |
|
(or (find-class-cell-class cell) |
448 |
|
(and *create-classes-from-internal-structure-definitions-p* |
449 |
|
(structure-type-p symbol) |
450 |
|
(find-structure-class symbol)) |
451 |
|
(cond ((null errorp) nil) |
452 |
|
((legal-class-name-p symbol) |
453 |
|
(error "No class named: ~S." symbol)) |
454 |
|
(t |
455 |
|
(error "~S is not a legal class name." symbol))))) |
456 |
|
|
457 |
|
(defun find-class-predicate-from-cell (symbol cell &optional (errorp t)) |
458 |
|
(unless (find-class-cell-class cell) |
459 |
|
(find-class-from-cell symbol cell errorp)) |
460 |
|
(find-class-cell-predicate cell)) |
461 |
|
|
462 |
|
(defun legal-class-name-p (x) |
463 |
|
(symbolp x)) |
464 |
|
; (and (symbolp x) |
465 |
|
; (not (keywordp x)))) |
466 |
|
|
467 |
|
(defun find-class (symbol &optional (errorp t) environment) |
468 |
|
(declare (ignore environment)) |
469 |
|
(find-class-from-cell |
470 |
|
symbol (find-class-cell symbol errorp) errorp)) |
471 |
|
|
472 |
|
(defun find-class-predicate (symbol &optional (errorp t) environment) |
473 |
|
(declare (ignore environment)) |
474 |
|
(find-class-predicate-from-cell |
475 |
|
symbol (find-class-cell symbol errorp) errorp)) |
476 |
|
|
477 |
|
(defvar *boot-state* nil) ; duplicate defvar to defs.lisp |
478 |
|
|
479 |
|
; Use this definition in any CL implementation supporting |
480 |
|
; both define-compiler-macro and load-time-value. |
481 |
|
#+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class |
482 |
|
(define-compiler-macro find-class (&whole form |
483 |
|
symbol &optional (errorp t) environment) |
484 |
|
(declare (ignore environment)) |
485 |
|
(if (and (constantp symbol) |
486 |
|
(legal-class-name-p (eval symbol)) |
487 |
|
(constantp errorp) |
488 |
|
(member *boot-state* '(braid complete))) |
489 |
|
(let ((symbol (eval symbol)) |
490 |
|
(errorp (not (null (eval errorp)))) |
491 |
|
(class-cell (make-symbol "CLASS-CELL"))) |
492 |
|
`(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) |
493 |
|
(or (find-class-cell-class ,class-cell) |
494 |
|
#-cmu17 |
495 |
|
(find-class-from-cell ',symbol ,class-cell ,errorp) |
496 |
|
#+cmu17 |
497 |
|
,(if errorp |
498 |
|
`(find-class-from-cell ',symbol ,class-cell t) |
499 |
|
`(and (kernel:class-cell-class |
500 |
|
',(kernel:find-class-cell symbol)) |
501 |
|
(find-class-from-cell ',symbol ,class-cell nil)))))) |
502 |
|
form)) |
503 |
|
|
504 |
|
#-setf |
505 |
|
(defsetf find-class (symbol &optional (errorp t) environment) (new-value) |
506 |
|
(declare (ignore errorp environment)) |
507 |
|
`(SETF\ PCL\ FIND-CLASS ,new-value ,symbol)) |
508 |
|
|
509 |
|
(defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol &optional errorp environment) |
510 |
|
(if (legal-class-name-p symbol) |
511 |
|
(let ((cell (find-class-cell symbol))) |
512 |
|
(setf (find-class-cell-class cell) new-value) |
513 |
|
(when (or (eq *boot-state* 'complete) |
514 |
|
(eq *boot-state* 'braid)) |
515 |
|
#+cmu17 |
516 |
|
(let ((lclass (kernel:layout-class (class-wrapper new-value)))) |
517 |
|
(setf (lisp:class-name lclass) (class-name new-value)) |
518 |
|
(unless (eq (lisp:find-class symbol nil) lclass) |
519 |
|
(setf (lisp:find-class symbol) lclass))) |
520 |
|
|
521 |
|
(setf (find-class-cell-predicate cell) |
522 |
|
(symbol-function (class-predicate-name new-value))) |
523 |
|
(when (and new-value (not (forward-referenced-class-p new-value))) |
524 |
|
|
525 |
|
(dolist (keys+aok (find-class-cell-make-instance-function-keys cell)) |
526 |
|
(update-initialize-info-internal |
527 |
|
(initialize-info new-value (car keys+aok) nil (cdr keys+aok)) |
528 |
|
'make-instance-function)))) |
529 |
|
new-value) |
530 |
|
(error "~S is not a legal class name." symbol))) |
531 |
|
|
532 |
|
#-setf |
533 |
|
(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value) |
534 |
|
(declare (ignore errorp environment)) |
535 |
|
`(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol)) |
536 |
|
|
537 |
|
(defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate) |
538 |
|
(new-value symbol) |
539 |
|
(if (legal-class-name-p symbol) |
540 |
|
(setf (find-class-cell-predicate (find-class-cell symbol)) new-value) |
541 |
|
(error "~S is not a legal class name." symbol))) |
542 |
|
|
543 |
|
(defun find-wrapper (symbol) |
544 |
|
(class-wrapper (find-class symbol))) |
545 |
|
|
546 |
|
#|| ; Anything that used this should use eval instead. |
547 |
|
(defun reduce-constant (old) |
548 |
|
(let ((new (eval old))) |
549 |
|
(if (eq new old) |
550 |
|
new |
551 |
|
(if (constantp new) |
552 |
|
(reduce-constant new) |
553 |
|
new)))) |
554 |
|
||# |
555 |
|
|
556 |
|
(defmacro gathering1 (gatherer &body body) |
557 |
|
`(gathering ((.gathering1. ,gatherer)) |
558 |
|
(macrolet ((gather1 (x) `(gather ,x .gathering1.))) |
559 |
|
,@body))) |
560 |
|
|
561 |
|
;;; |
562 |
|
;;; |
563 |
|
;;; |
564 |
|
(defmacro vectorizing (&key (size 0)) |
565 |
|
`(let* ((limit ,size) |
566 |
|
(result (make-array limit)) |
567 |
|
(index 0)) |
568 |
|
(values #'(lambda (value) |
569 |
|
(if (= index limit) |
570 |
|
(error "vectorizing more elements than promised.") |
571 |
|
(progn |
572 |
|
(setf (svref result index) value) |
573 |
|
(incf index) |
574 |
|
value))) |
575 |
|
#'(lambda () result)))) |
576 |
|
|
577 |
|
;;; |
578 |
|
;;; These are augmented definitions of list-elements and list-tails from |
579 |
|
;;; iterate.lisp. These versions provide the extra :by keyword which can |
580 |
|
;;; be used to specify the step function through the list. |
581 |
|
;;; |
582 |
|
(defmacro *list-elements (list &key (by #'cdr)) |
583 |
|
`(let ((tail ,list)) |
584 |
|
#'(lambda (finish) |
585 |
|
(if (endp tail) |
586 |
|
(funcall finish) |
587 |
|
(prog1 (car tail) |
588 |
|
(setq tail (funcall ,by tail))))))) |
589 |
|
|
590 |
|
(defmacro *list-tails (list &key (by #'cdr)) |
591 |
|
`(let ((tail ,list)) |
592 |
|
#'(lambda (finish) |
593 |
|
(prog1 (if (endp tail) |
594 |
|
(funcall finish) |
595 |
|
tail) |
596 |
|
(setq tail (funcall ,by tail)))))) |
597 |
|
|
598 |
|
(defmacro function-funcall (form &rest args) |
599 |
|
#-cmu `(funcall ,form ,@args) |
600 |
|
#+cmu `(funcall (the function ,form) ,@args)) |
601 |
|
|
602 |
|
(defmacro function-apply (form &rest args) |
603 |
|
#-cmu `(apply ,form ,@args) |
604 |
|
#+cmu `(apply (the function ,form) ,@args)) |
605 |
|
|
606 |
|
|
607 |
|
;;; |
608 |
|
;;; Convert a function name to its standard setf function name. We have to |
609 |
|
;;; do this hack because not all Common Lisps have yet converted to having |
610 |
|
;;; setf function specs. |
611 |
|
;;; |
612 |
|
;;; In a port that does have setf function specs you can use those just by |
613 |
|
;;; making the obvious simple changes to these functions. The rest of PCL |
614 |
|
;;; believes that there are function names like (SETF <foo>), this is the |
615 |
|
;;; only place that knows about this hack. |
616 |
|
;;; |
617 |
|
(eval-when (compile load eval) |
618 |
|
; In 15e (and also 16c), using the built in setf mechanism costs |
619 |
|
; a hash table lookup every time a setf function is called. |
620 |
|
; Uncomment the next line to use the built in setf mechanism. |
621 |
|
;#+cmu (pushnew :setf *features*) |
622 |
|
) |
623 |
|
|
624 |
|
(eval-when (compile load eval) |
625 |
|
|
626 |
|
#-setf |
627 |
|
(defvar *setf-function-names* (make-hash-table :size 200 :test #'eq)) |
628 |
|
|
629 |
|
(defun get-setf-function-name (name) |
630 |
|
#+setf `(setf ,name) |
631 |
|
#-setf |
632 |
|
(or (gethash name *setf-function-names*) |
633 |
|
(setf (gethash name *setf-function-names*) |
634 |
|
(let ((pkg (symbol-package name))) |
635 |
|
(if pkg |
636 |
|
(intern (format nil |
637 |
|
"SETF ~A ~A" |
638 |
|
(package-name pkg) |
639 |
|
(symbol-name name)) |
640 |
|
*the-pcl-package*) |
641 |
|
(make-symbol (format nil "SETF ~A" (symbol-name name)))))))) |
642 |
|
|
643 |
|
;;; |
644 |
|
;;; Call this to define a setf macro for a function with the same behavior as |
645 |
|
;;; specified by the SETF function cleanup proposal. Specifically, this will |
646 |
|
;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b). |
647 |
|
;;; |
648 |
|
;;; do-standard-defsetf A macro interface for use at top level |
649 |
|
;;; in files. Unfortunately, users may |
650 |
|
;;; have to use this for a while. |
651 |
|
;;; |
652 |
|
;;; do-standard-defsetfs-for-defclass A special version called by defclass. |
653 |
|
;;; |
654 |
|
;;; do-standard-defsetf-1 A functional interface called by the |
655 |
|
;;; above, defmethod and defgeneric. |
656 |
|
;;; Since this is all a crock anyways, |
657 |
|
;;; users are free to call this as well. |
658 |
|
;;; |
659 |
|
(defmacro do-standard-defsetf (&rest function-names) |
660 |
|
`(eval-when (compile load eval) |
661 |
|
(dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name)))) |
662 |
|
|
663 |
|
(defun do-standard-defsetfs-for-defclass (accessors) |
664 |
|
(dolist (name accessors) (do-standard-defsetf-1 name))) |
665 |
|
|
666 |
|
;; FIXME remove this when all is well |
667 |
|
(defun do-standard-defsetf-1 (function-name) |
668 |
|
#+setf |
669 |
|
(declare (ignore function-name)) |
670 |
|
#+setf nil |
671 |
|
#-setf |
672 |
|
(unless (and (setfboundp function-name) |
673 |
|
(get function-name 'standard-setf)) |
674 |
|
(setf (get function-name 'standard-setf) t) |
675 |
|
(let* ((setf-function-name (get-setf-function-name function-name))) |
676 |
|
|
677 |
|
#+Genera |
678 |
|
(let ((fn #'(lambda (form) |
679 |
|
(lt::help-defsetf |
680 |
|
'(&rest accessor-args) '(new-value) function-name 'nil |
681 |
|
`(`(,',setf-function-name ,new-value .,accessor-args)) |
682 |
|
form)))) |
683 |
|
(setf (get function-name 'lt::setf-method) fn |
684 |
|
(get function-name 'lt::setf-method-internal) fn)) |
685 |
|
|
686 |
|
#+Lucid |
687 |
|
(lucid::set-simple-setf-method |
688 |
|
function-name |
689 |
|
#'(lambda (form new-value) |
690 |
|
(let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) |
691 |
|
(cdr form))) |
692 |
|
(vars (mapcar #'car bindings))) |
693 |
|
;; This may wrap spurious LET bindings around some form, |
694 |
|
;; but the PQC compiler will unwrap then. |
695 |
|
`(LET (,.bindings) |
696 |
|
(,setf-function-name ,new-value . ,vars))))) |
697 |
|
|
698 |
|
#+kcl |
699 |
|
(let ((helper (gensym))) |
700 |
|
(setf (macro-function helper) |
701 |
|
#'(lambda (form env) |
702 |
|
(declare (ignore env)) |
703 |
|
(let* ((loc-args (butlast (cdr form))) |
704 |
|
(bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args)) |
705 |
|
(vars (mapcar #'car bindings))) |
706 |
|
`(let ,bindings |
707 |
|
(funcall #',setf-function-name ,(car (last form)) ,@vars))))) |
708 |
|
(format t "defsetfinf ~S~%" `(defsetf ,function-name ,helper)) |
709 |
|
(eval `(defsetf ,function-name ,helper))) |
710 |
|
#+Xerox |
711 |
|
(flet ((setf-expander (body env) |
712 |
|
(declare (ignore env)) |
713 |
|
(let ((temps |
714 |
|
(mapcar #'(lambda (x) (declare (ignore x)) (gensym)) |
715 |
|
(cdr body))) |
716 |
|
(forms (cdr body)) |
717 |
|
(vars (list (gensym)))) |
718 |
|
(values temps |
719 |
|
forms |
720 |
|
vars |
721 |
|
`(,setf-function-name ,@vars ,@temps) |
722 |
|
`(,function-name ,@temps))))) |
723 |
|
(let ((setf-method-expander (intern (concatenate 'string |
724 |
|
(symbol-name function-name) |
725 |
|
"-setf-expander") |
726 |
|
(symbol-package function-name)))) |
727 |
|
(setf (get function-name :setf-method-expander) setf-method-expander |
728 |
|
(symbol-function setf-method-expander) #'setf-expander))) |
729 |
|
|
730 |
|
#-(or Genera Lucid kcl Xerox) |
731 |
|
(eval `(defsetf ,function-name (&rest accessor-args) (new-value) |
732 |
|
(let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args)) |
733 |
|
(vars (mapcar #'car bindings))) |
734 |
|
`(let ,bindings |
735 |
|
(,',setf-function-name ,new-value ,@vars))))) |
736 |
|
|
737 |
|
))) |
738 |
|
|
739 |
|
(defun setfboundp (symbol) |
740 |
|
#+Genera (not (null (get-properties (symbol-plist symbol) |
741 |
|
'lt::(derived-setf-function trivial-setf-method |
742 |
|
setf-equivalence setf-method)))) |
743 |
|
#+Lucid (locally |
744 |
|
(declare (special lucid::*setf-inverse-table* |
745 |
|
lucid::*simple-setf-method-table* |
746 |
|
lucid::*setf-method-expander-table*)) |
747 |
|
(or (gethash symbol lucid::*setf-inverse-table*) |
748 |
|
(gethash symbol lucid::*simple-setf-method-table*) |
749 |
|
(gethash symbol lucid::*setf-method-expander-table*))) |
750 |
|
#+kcl (or (get symbol 'si::setf-method) |
751 |
|
(get symbol 'si::setf-update-fn) |
752 |
|
(get symbol 'si::setf-lambda)) |
753 |
|
#+Xerox (or (get symbol :setf-inverse) |
754 |
|
(get symbol 'il:setf-inverse) |
755 |
|
(get symbol 'il:setfn) |
756 |
|
(get symbol :shared-setf-inverse) |
757 |
|
(get symbol :setf-method-expander) |
758 |
|
(get symbol 'il:setf-method-expander)) |
759 |
|
#+:coral (or (get symbol 'ccl::setf-inverse) |
760 |
|
(get symbol 'ccl::setf-method-expander)) |
761 |
|
#+cmu (fboundp `(setf ,symbol)) |
762 |
|
#-(or Genera Lucid KCL Xerox :coral cmu) nil) |
763 |
|
|
764 |
|
);eval-when |
765 |
|
|
766 |
|
|
767 |
|
;;; |
768 |
|
;;; PCL, like user code, must endure the fact that we don't have a properly |
769 |
|
;;; working setf. Many things work because they get mentioned by a defclass |
770 |
|
;;; or defmethod before they are used, but others have to be done by hand. |
771 |
|
;;; |
772 |
|
(do-standard-defsetf |
773 |
|
class-wrapper ;*** |
774 |
|
generic-function-name |
775 |
|
method-function-plist |
776 |
|
method-function-get |
777 |
|
plist-value |
778 |
|
object-plist |
779 |
|
gdefinition |
780 |
|
slot-value-using-class |
781 |
|
) |
782 |
|
|
783 |
|
(defsetf slot-value set-slot-value) |
784 |
|
|
785 |
|
(defvar *redefined-functions* nil) |
786 |
|
|
787 |
|
(defmacro original-definition (name) |
788 |
|
`(get ,name 'definition-before-pcl)) |
789 |
|
|
790 |
|
(defun redefine-function (name new) |
791 |
|
(pushnew name *redefined-functions*) |
792 |
|
(unless (original-definition name) |
793 |
|
(setf (original-definition name) |
794 |
|
(symbol-function name))) |
795 |
|
(setf (symbol-function name) |
796 |
|
(symbol-function new))) |
797 |
|
|