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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6.1.3 - (hide annotations) (vendor branch)
Thu Sep 29 21:03:44 1994 UTC (19 years, 6 months ago) by ram
Branch: cmu
Changes since 1.6.1.2: +2 -1 lines
In find-class compiler macro, don't do anything unless *boot-state* is braid or
complete, since the class-cell system doesn't exist until then.
1 wlott 1.1 ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
2     ;;;
3     ;;; *************************************************************************
4     ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5     ;;; All rights reserved.
6     ;;;
7     ;;; Use and copying of this software and preparation of derivative works
8     ;;; based upon this software are permitted. Any distribution of this
9     ;;; software or derivative works must comply with all applicable United
10     ;;; States export control laws.
11     ;;;
12     ;;; This software is made available AS IS, and Xerox Corporation makes no
13     ;;; warranty about the software, its performance or its conformity to any
14     ;;; specification.
15     ;;;
16     ;;; Any person obtaining a copy of this software is requested to send their
17     ;;; name and post office or electronic mail address to:
18     ;;; CommonLoops Coordinator
19     ;;; Xerox PARC
20     ;;; 3333 Coyote Hill Rd.
21     ;;; Palo Alto, CA 94304
22     ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23     ;;;
24     ;;; Suggestions, comments and requests for improvements are also welcome.
25     ;;; *************************************************************************
26     ;;;
27     ;;; 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 phg 1.6 (in-package :pcl)
35 wlott 1.1
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 ram 1.5 method-name
50     method-lambda-list
51 wlott 1.1 ))
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 ram 1.5 (make-caxr (- n 4) `(cddddr ,form))))
76 wlott 1.1
77     (defun make-cdxr (n form)
78     (cond ((zerop n) form)
79     ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
80 ram 1.5 (t (make-cdxr (- n 4) `(cddddr ,form)))))
81 wlott 1.1 )
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 ram 1.5 (run-time-vars (gensym))
104     (run-time-vals (gensym))
105 wlott 1.1 (expand-time-val-forms ()))
106     (dolist (var vars)
107 ram 1.5 (push `(if (or (symbolp ,var)
108     (numberp ,var)
109     (and (listp ,var)
110     (member (car ,var) '(quote function))))
111 wlott 1.1 ,var
112 ram 1.5 (let ((,gensym-var (gensym)))
113 wlott 1.1 (push ,gensym-var ,run-time-vars)
114     (push ,var ,run-time-vals)
115     ,gensym-var))
116 ram 1.5 expand-time-val-forms))
117 wlott 1.1 `(let* (,run-time-vars
118     ,run-time-vals
119     (wrapped-body
120     (let ,(mapcar #'list vars (reverse expand-time-val-forms))
121     ,@body)))
122 ram 1.5 `(let ,(mapcar #'list (reverse ,run-time-vars)
123     (reverse ,run-time-vals))
124     ,wrapped-body))))
125 wlott 1.1
126     (eval-when (compile load eval)
127     (defun extract-declarations (body &optional environment)
128 ram 1.5 ;;(declare (values documentation declarations body))
129 wlott 1.1 (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 ram 1.5 (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 wlott 1.1
162 ram 1.5
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 wlott 1.1 (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 ram 1.5 ;;(declare (values setqs binds))
223 wlott 1.1 (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
283     (if (consp pat) (car pat) pat)
284     gensym)))
285     setqs)
286     (when (symbolp (cdr pat))
287     (push (cdr pat) *destructure-vars*)
288     (return)))))
289     setqs)))
290     )
291    
292    
293     (defmacro collecting-once (&key initial-value)
294     `(let* ((head ,initial-value)
295     (tail ,(and initial-value `(last head))))
296     (values #'(lambda (value)
297     (if (null head)
298     (setq head (setq tail (list value)))
299     (unless (memq value head)
300     (setq tail
301     (cdr (rplacd tail (list value)))))))
302     #'(lambda nil head))))
303    
304     (defmacro doplist ((key val) plist &body body &environment env)
305     (multiple-value-bind (doc decls bod)
306     (extract-declarations body env)
307     (declare (ignore doc))
308     `(let ((.plist-tail. ,plist) ,key ,val)
309     ,@decls
310     (loop (when (null .plist-tail.) (return nil))
311     (setq ,key (pop .plist-tail.))
312     (when (null .plist-tail.)
313     (error "Malformed plist in doplist, odd number of elements."))
314     (setq ,val (pop .plist-tail.))
315     (progn ,@bod)))))
316    
317     (defmacro if* (condition true &rest false)
318     `(if ,condition ,true (progn ,@false)))
319    
320 ram 1.3 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
321     `(let ((,var nil)
322     (.dolist-carefully. ,list))
323     (loop (when (null .dolist-carefully.) (return nil))
324     (if (consp .dolist-carefully.)
325     (progn
326     (setq ,var (pop .dolist-carefully.))
327     ,@body)
328     (,improper-list-handler)))))
329 wlott 1.1
330     ;;
331     ;;;;;; printing-random-thing
332     ;;
333     ;;; Similar to printing-random-object in the lisp machine but much simpler
334     ;;; and machine independent.
335     (defmacro printing-random-thing ((thing stream) &body body)
336 ram 1.6.1.1 #+cmu17
337     `(print-unreadable-object (,thing ,stream :identity t) ,@body)
338     #-cmu17
339     (once-only (thing stream)
340     `(progn
341     (when *print-readably*
342     (error "~S cannot be printed readably." thing))
343     (format ,stream "#<")
344     ,@body
345     (format ,stream " ")
346     (printing-random-thing-internal ,thing ,stream)
347     (format ,stream ">"))))
348 wlott 1.1
349     (defun printing-random-thing-internal (thing stream)
350     (declare (ignore thing stream))
351     nil)
352    
353     ;;
354     ;;;;;;
355     ;;
356    
357     (defun capitalize-words (string &optional (dashes-p t))
358     (let ((string (copy-seq (string string))))
359     (declare (string string))
360     (do* ((flag t flag)
361     (length (length string) length)
362     (char nil char)
363     (i 0 (+ i 1)))
364     ((= i length) string)
365     (setq char (elt string i))
366     (cond ((both-case-p char)
367     (if flag
368     (and (setq flag (lower-case-p char))
369     (setf (elt string i) (char-upcase char)))
370     (and (not flag) (setf (elt string i) (char-downcase char))))
371     (setq flag nil))
372     ((char-equal char #\-)
373     (setq flag t)
374     (unless dashes-p (setf (elt string i) #\space)))
375     (t (setq flag nil))))))
376    
377 ram 1.5 #-(or lucid kcl)
378     (eval-when (compile load eval)
379     ;(warn "****** Things will go faster if you fix define-compiler-macro")
380 ram 1.3 )
381 wlott 1.1
382 ram 1.6.1.1 #-cmu
383 ram 1.3 (defmacro define-compiler-macro (name arglist &body body)
384 ram 1.5 #+(or lucid kcl)
385     `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
386 phg 1.6 ,name ,arglist
387     ,@body)
388 ram 1.5 #-(or kcl lucid)
389 phg 1.6 (declare (ignore name arglist body))
390     #-(or kcl lucid)
391 ram 1.5 nil)
392 ram 1.3
393    
394 ram 1.5 ;;;
395     ;;; FIND-CLASS
396     ;;;
397     ;;; This is documented in the CLOS specification.
398     ;;;
399     (defvar *find-class* (make-hash-table :test #'eq))
400 wlott 1.1
401 ram 1.3 (defun make-constant-function (value)
402     #'(lambda (object)
403     (declare (ignore object))
404     value))
405 wlott 1.1
406 ram 1.3 (defun function-returning-nil (x)
407     (declare (ignore x))
408     nil)
409    
410     (defun function-returning-t (x)
411     (declare (ignore x))
412     t)
413    
414 ram 1.5 (defmacro find-class-cell-class (cell)
415     `(car ,cell))
416 ram 1.3
417 ram 1.5 (defmacro find-class-cell-predicate (cell)
418 phg 1.6 `(cadr ,cell))
419 ram 1.3
420 phg 1.6 (defmacro find-class-cell-make-instance-function-keys (cell)
421     `(cddr ,cell))
422    
423 ram 1.5 (defmacro make-find-class-cell (class-name)
424     (declare (ignore class-name))
425 phg 1.6 '(list* nil #'function-returning-nil nil))
426 ram 1.5
427     (defun find-class-cell (symbol &optional dont-create-p)
428     (or (gethash symbol *find-class*)
429     (unless dont-create-p
430     (unless (legal-class-name-p symbol)
431     (error "~S is not a legal class name." symbol))
432     (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
433    
434     (defvar *create-classes-from-internal-structure-definitions-p* t)
435    
436     (defun find-class-from-cell (symbol cell &optional (errorp t))
437     (or (find-class-cell-class cell)
438     (and *create-classes-from-internal-structure-definitions-p*
439     (structure-type-p symbol)
440     (find-structure-class symbol))
441     (cond ((null errorp) nil)
442     ((legal-class-name-p symbol)
443     (error "No class named: ~S." symbol))
444     (t
445     (error "~S is not a legal class name." symbol)))))
446    
447     (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
448     (unless (find-class-cell-class cell)
449     (find-class-from-cell symbol cell errorp))
450     (find-class-cell-predicate cell))
451    
452     (defun legal-class-name-p (x)
453     (and (symbolp x)
454     (not (keywordp x))))
455    
456     (defun find-class (symbol &optional (errorp t) environment)
457     (declare (ignore environment))
458 phg 1.6 (find-class-from-cell
459     symbol (find-class-cell symbol errorp) errorp))
460 ram 1.5
461     (defun find-class-predicate (symbol &optional (errorp t) environment)
462     (declare (ignore environment))
463 phg 1.6 (find-class-predicate-from-cell
464     symbol (find-class-cell symbol errorp) errorp))
465 ram 1.5
466 ram 1.6.1.2 ; 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 ram 1.6.1.3 (constantp errorp)
475     (member *boot-state* '(braid complete)))
476 ram 1.6.1.2 (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 ram 1.5 #-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 phg 1.6 (declare (special *boot-state*))
498 ram 1.5 (if (legal-class-name-p symbol)
499 phg 1.6 (let ((cell (find-class-cell symbol)))
500     (setf (find-class-cell-class cell) new-value)
501     (when (or (eq *boot-state* 'complete)
502     (eq *boot-state* 'braid))
503 ram 1.6.1.1 #+cmu17
504     (let ((lclass (kernel:layout-class (class-wrapper new-value))))
505     (setf (lisp:class-name lclass) (class-name new-value))
506     (unless (eq (lisp:find-class symbol nil) lclass)
507     (setf (lisp:find-class symbol) lclass)))
508    
509 phg 1.6 (setf (find-class-cell-predicate cell)
510     (symbol-function (class-predicate-name new-value)))
511     (when (and new-value (not (forward-referenced-class-p new-value)))
512 ram 1.6.1.1
513 phg 1.6 (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
514     (update-initialize-info-internal
515     (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
516     'make-instance-function)))))
517 ram 1.5 (error "~S is not a legal class name." symbol)))
518    
519     #-setf
520     (defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
521     (declare (ignore errorp environment))
522     `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
523    
524     (defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)
525     (new-value symbol)
526     (if (legal-class-name-p symbol)
527     (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
528     (error "~S is not a legal class name." symbol)))
529    
530     (defun find-wrapper (symbol)
531     (class-wrapper (find-class symbol)))
532    
533 ram 1.2 #|| ; Anything that used this should use eval instead.
534 wlott 1.1 (defun reduce-constant (old)
535     (let ((new (eval old)))
536     (if (eq new old)
537     new
538     (if (constantp new)
539     (reduce-constant new)
540     new))))
541 ram 1.2 ||#
542 wlott 1.1
543     (defmacro gathering1 (gatherer &body body)
544     `(gathering ((.gathering1. ,gatherer))
545     (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
546     ,@body)))
547    
548     ;;;
549     ;;;
550     ;;;
551     (defmacro vectorizing (&key (size 0))
552     `(let* ((limit ,size)
553     (result (make-array limit))
554     (index 0))
555     (values #'(lambda (value)
556     (if (= index limit)
557     (error "vectorizing more elements than promised.")
558     (progn
559     (setf (svref result index) value)
560 ram 1.5 (incf index)
561 wlott 1.1 value)))
562     #'(lambda () result))))
563    
564     ;;;
565     ;;; These are augmented definitions of list-elements and list-tails from
566     ;;; iterate.lisp. These versions provide the extra :by keyword which can
567     ;;; be used to specify the step function through the list.
568     ;;;
569     (defmacro *list-elements (list &key (by #'cdr))
570     `(let ((tail ,list))
571     #'(lambda (finish)
572     (if (endp tail)
573     (funcall finish)
574     (prog1 (car tail)
575     (setq tail (funcall ,by tail)))))))
576    
577     (defmacro *list-tails (list &key (by #'cdr))
578     `(let ((tail ,list))
579     #'(lambda (finish)
580     (prog1 (if (endp tail)
581     (funcall finish)
582     tail)
583     (setq tail (funcall ,by tail))))))
584 ram 1.2
585 ram 1.3 (defmacro function-funcall (form &rest args)
586 ram 1.5 #-cmu `(funcall ,form ,@args)
587     #+cmu `(funcall (the function ,form) ,@args))
588 ram 1.3
589     (defmacro function-apply (form &rest args)
590 ram 1.5 #-cmu `(apply ,form ,@args)
591     #+cmu `(apply (the function ,form) ,@args))
592 ram 1.3
593    
594     ;;;
595     ;;; Convert a function name to its standard setf function name. We have to
596     ;;; do this hack because not all Common Lisps have yet converted to having
597     ;;; setf function specs.
598     ;;;
599     ;;; In a port that does have setf function specs you can use those just by
600     ;;; making the obvious simple changes to these functions. The rest of PCL
601     ;;; believes that there are function names like (SETF <foo>), this is the
602     ;;; only place that knows about this hack.
603     ;;;
604     (eval-when (compile load eval)
605     ; In 15e (and also 16c), using the built in setf mechanism costs
606     ; a hash table lookup every time a setf function is called.
607     ; Uncomment the next line to use the built in setf mechanism.
608     ;#+cmu (pushnew :setf *features*)
609     )
610    
611     (eval-when (compile load eval)
612    
613     #-setf
614     (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
615    
616     (defun get-setf-function-name (name)
617     #+setf `(setf ,name)
618     #-setf
619     (or (gethash name *setf-function-names*)
620     (setf (gethash name *setf-function-names*)
621     (let ((pkg (symbol-package name)))
622     (if pkg
623     (intern (format nil
624     "SETF ~A ~A"
625     (package-name pkg)
626     (symbol-name name))
627     *the-pcl-package*)
628     (make-symbol (format nil "SETF ~A" (symbol-name name))))))))
629    
630     ;;;
631     ;;; Call this to define a setf macro for a function with the same behavior as
632     ;;; specified by the SETF function cleanup proposal. Specifically, this will
633     ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
634     ;;;
635     ;;; do-standard-defsetf A macro interface for use at top level
636     ;;; in files. Unfortunately, users may
637     ;;; have to use this for a while.
638     ;;;
639     ;;; do-standard-defsetfs-for-defclass A special version called by defclass.
640     ;;;
641     ;;; do-standard-defsetf-1 A functional interface called by the
642     ;;; above, defmethod and defgeneric.
643     ;;; Since this is all a crock anyways,
644     ;;; users are free to call this as well.
645     ;;;
646     (defmacro do-standard-defsetf (&rest function-names)
647     `(eval-when (compile load eval)
648     (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
649    
650     (defun do-standard-defsetfs-for-defclass (accessors)
651     (dolist (name accessors) (do-standard-defsetf-1 name)))
652    
653     (defun do-standard-defsetf-1 (function-name)
654     #+setf
655     (declare (ignore function-name))
656     #+setf nil
657     #-setf
658 ram 1.4 (unless (and (setfboundp function-name)
659     (get function-name 'standard-setf))
660     (setf (get function-name 'standard-setf) t)
661 ram 1.3 (let* ((setf-function-name (get-setf-function-name function-name)))
662    
663     #+Genera
664     (let ((fn #'(lambda (form)
665     (lt::help-defsetf
666     '(&rest accessor-args) '(new-value) function-name 'nil
667     `(`(,',setf-function-name ,new-value .,accessor-args))
668     form))))
669     (setf (get function-name 'lt::setf-method) fn
670     (get function-name 'lt::setf-method-internal) fn))
671    
672     #+Lucid
673     (lucid::set-simple-setf-method
674     function-name
675     #'(lambda (form new-value)
676     (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
677     (cdr form)))
678     (vars (mapcar #'car bindings)))
679     ;; This may wrap spurious LET bindings around some form,
680     ;; but the PQC compiler will unwrap then.
681     `(LET (,.bindings)
682     (,setf-function-name ,new-value . ,vars)))))
683    
684     #+kcl
685     (let ((helper (gensym)))
686     (setf (macro-function helper)
687     #'(lambda (form env)
688     (declare (ignore env))
689     (let* ((loc-args (butlast (cdr form)))
690     (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
691     (vars (mapcar #'car bindings)))
692     `(let ,bindings
693     (,setf-function-name ,(car (last form)) ,@vars)))))
694     (eval `(defsetf ,function-name ,helper)))
695     #+Xerox
696     (flet ((setf-expander (body env)
697     (declare (ignore env))
698     (let ((temps
699     (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
700     (cdr body)))
701     (forms (cdr body))
702     (vars (list (gensym))))
703     (values temps
704     forms
705     vars
706     `(,setf-function-name ,@vars ,@temps)
707     `(,function-name ,@temps)))))
708     (let ((setf-method-expander (intern (concatenate 'string
709     (symbol-name function-name)
710     "-setf-expander")
711     (symbol-package function-name))))
712     (setf (get function-name :setf-method-expander) setf-method-expander
713     (symbol-function setf-method-expander) #'setf-expander)))
714    
715     #-(or Genera Lucid kcl Xerox)
716     (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
717     (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
718     (vars (mapcar #'car bindings)))
719     `(let ,bindings
720     (,',setf-function-name ,new-value ,@vars)))))
721    
722     )))
723    
724     (defun setfboundp (symbol)
725     #+Genera (not (null (get-properties (symbol-plist symbol)
726     'lt::(derived-setf-function trivial-setf-method
727     setf-equivalence setf-method))))
728     #+Lucid (locally
729     (declare (special lucid::*setf-inverse-table*
730     lucid::*simple-setf-method-table*
731     lucid::*setf-method-expander-table*))
732     (or (gethash symbol lucid::*setf-inverse-table*)
733     (gethash symbol lucid::*simple-setf-method-table*)
734     (gethash symbol lucid::*setf-method-expander-table*)))
735     #+kcl (or (get symbol 'si::setf-method)
736     (get symbol 'si::setf-update-fn)
737     (get symbol 'si::setf-lambda))
738     #+Xerox (or (get symbol :setf-inverse)
739     (get symbol 'il:setf-inverse)
740     (get symbol 'il:setfn)
741     (get symbol :shared-setf-inverse)
742     (get symbol :setf-method-expander)
743     (get symbol 'il:setf-method-expander))
744     #+:coral (or (get symbol 'ccl::setf-inverse)
745     (get symbol 'ccl::setf-method-expander))
746     #+cmu (fboundp `(setf ,symbol))
747     #-(or Genera Lucid KCL Xerox :coral cmu) nil)
748    
749     );eval-when
750    
751    
752     ;;;
753     ;;; PCL, like user code, must endure the fact that we don't have a properly
754     ;;; working setf. Many things work because they get mentioned by a defclass
755     ;;; or defmethod before they are used, but others have to be done by hand.
756     ;;;
757     (do-standard-defsetf
758     class-wrapper ;***
759     generic-function-name
760     method-function-plist
761     method-function-get
762     plist-value
763     object-plist
764     gdefinition
765     slot-value-using-class
766     )
767    
768     (defsetf slot-value set-slot-value)
769    
770     (defvar *redefined-functions* nil)
771    
772     (defmacro original-definition (name)
773     `(get ,name ':definition-before-pcl))
774    
775     (defun redefine-function (name new)
776     (pushnew name *redefined-functions*)
777     (unless (original-definition name)
778     (setf (original-definition name)
779     (symbol-function name)))
780     (setf (symbol-function name)
781     (symbol-function new)))
782 ram 1.4

  ViewVC Help
Powered by ViewVC 1.1.5