/[cmucl]/src/pcl/macros.lisp
ViewVC logotype

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5