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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5