/[gcl]/gcl/pcl/gcl_pcl_macros.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 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    (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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26