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

Diff of /src/code/macros.lisp

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

revision 1.21 by ram, Sat Apr 20 14:20:06 1991 UTC revision 1.22 by ram, Wed May 8 16:30:04 1991 UTC
# Line 11  Line 11 
11  ;;;  ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
 ;;; $Header$  
 ;;;  
14  ;;; This file contains the macros that are part of the standard  ;;; This file contains the macros that are part of the standard
15  ;;; Spice Lisp environment.  ;;; Spice Lisp environment.
16  ;;;  ;;;
17  ;;; Written by Scott Fahlman and Rob MacLachlan.  ;;; Written by Scott Fahlman and Rob MacLachlan.
18  ;;; Modified by Bill Chiles to adhere to  ;;; Modified by Bill Chiles to adhere to the wall.
19  ;;;  ;;;
20  (in-package "LISP")  (in-package "LISP")
21  (export '(defvar defparameter defconstant when unless setf  (export '(defvar defparameter defconstant when unless setf
# Line 169  Line 167 
167                                           'define-setf-method                                           'define-setf-method
168                                           :environment environment)                                           :environment environment)
169        `(eval-when (load compile eval)        `(eval-when (load compile eval)
170           (setf (info setf inverse ',access-fn) nil)           (%define-setf-macro
171           (setf (info setf expander ',access-fn)            ',access-fn
172                 #'(lambda (,whole ,environment)            #'(lambda (,whole ,environment)
173                     ,@local-decs                ,@local-decs
174                     (block ,access-fn ,body)))                (block ,access-fn ,body))
175           ,@(when doc            nil
176               `((setf (documentation ',access-fn 'setf) ,doc)))            ',doc)))))
177           ',access-fn))))  
178    
179    ;;; %DEFINE-SETF-MACRO  --  Internal
180    ;;;
181    ;;;    Do stuff for defining a setf macro.
182    ;;;
183    (defun %define-setf-macro (name expander inverse doc)
184      (cond ((not (fboundp `(setf ,name))))
185            ((info function accessor-for name)
186             (warn "Defining setf macro for destruct slot accessor; redefining as ~
187                    a normal function:~%  ~S"
188                   name)
189             (c::define-function-name name))
190            ((not (eq (symbol-package name) (symbol-package 'aref)))
191             (warn "Defining setf macro for ~S, but ~S is fbound."
192                   name `(setf ,name))))
193      (when (or inverse (info setf inverse name))
194        (setf (info setf inverse name) inverse))
195      (when (or expander (info setf expander name))
196        (setf (info setf expander name) expander))
197      (when doc
198        (setf (documentation name 'setf) doc))
199      name)
200    
201    
202  ;;;; Destructuring-bind  ;;;; Destructuring-bind
203    
# Line 470  Line 490 
490      (cond ((symbolp form)      (cond ((symbolp form)
491             (let ((new-var (gensym)))             (let ((new-var (gensym)))
492               (values nil nil (list new-var) `(setq ,form ,new-var) form)))               (values nil nil (list new-var) `(setq ,form ,new-var) form)))
493            ((atom form)            ((and environment
494             (error "~S illegal atomic form for GET-SETF-METHOD." form))                  (assoc (car form) (c::lexenv-functions environment)))
495               (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t))
496            ;;            ;;
497            ;; ### Bootstrap hack...            ;; ### Bootstrap hack...
498            ;; Ignore any DEFSETF info for structure accessors.            ;; Ignore any DEFSETF info for structure accessors.
# Line 531  Line 552 
552    details."    details."
553    (cond ((not (listp (car rest)))    (cond ((not (listp (car rest)))
554           `(eval-when (load compile eval)           `(eval-when (load compile eval)
555              (setf (info setf inverse ',access-fn) ',(car rest))              (%define-setf-macro ',access-fn nil ',(car rest)
556              (setf (info setf expander ',access-fn) nil)                                  ,(when (and (car rest) (stringp (cadr rest)))
557              ,@(if (and (car rest) (stringp (cadr rest)))                                     `',(cadr rest)))))
                   `((eval-when (load eval)  
                       (%put ',access-fn '%setf-documentation ,(cadr rest)))))  
             ',access-fn))  
558          ((and (listp (car rest)) (cdr rest) (listp (cadr rest)))          ((and (listp (car rest)) (cdr rest) (listp (cadr rest)))
559           (if (not (= (length (cadr rest)) 1))           (if (not (= (length (cadr rest)) 1))
560               (cerror "Ignore the extra items in the list."               (cerror "Ignore the extra items in the list."
# Line 544  Line 562 
562           (multiple-value-bind (setting-form-generator doc)           (multiple-value-bind (setting-form-generator doc)
563                                (defsetter access-fn rest)                                (defsetter access-fn rest)
564             `(eval-when (load compile eval)             `(eval-when (load compile eval)
565                (setf (info setf inverse ',access-fn) nil)                (%define-setf-macro
566                (setf (info setf expander ',access-fn)                 ',access-fn
567                      #'(lambda (access-form environment)                 #'(lambda (access-form environment)
568                          (declare (ignore environment))                     (declare (ignore environment))
569                          (do* ((args (cdr access-form) (cdr args))                     (do* ((args (cdr access-form) (cdr args))
570                                (dummies nil (cons (gensym) dummies))                           (dummies nil (cons (gensym) dummies))
571                                (newval-var (gensym))                           (newval-var (gensym))
572                                (new-access-form nil))                           (new-access-form nil))
573                               ((atom args)                          ((atom args)
574                                (setq new-access-form                           (setq new-access-form
575                                      (cons (car access-form) dummies))                                 (cons (car access-form) dummies))
576                                (values                           (values
577                                 dummies                            dummies
578                                 (cdr access-form)                            (cdr access-form)
579                                 (list newval-var)                            (list newval-var)
580                                 (funcall (function ,setting-form-generator)                            (funcall (function ,setting-form-generator)
581                                          new-access-form newval-var)                                     new-access-form newval-var)
582                                 new-access-form)))))                            new-access-form))))
583                ,@(if doc                 nil
584                      `((eval-when (load eval)                 ',doc))))
                         (setf (info setf documentation ',access-fn) ',doc)))  
                     `((eval-when (load eval)  
                         (or (clear-info setf documentation ',access-fn)  
                             (setf (info setf documentation ',access-fn)  
                                   nil)))))  
               ',access-fn)))  
585          (t (error "Ill-formed DEFSETF for ~S." access-fn))))          (t (error "Ill-formed DEFSETF for ~S." access-fn))))
586    
587  (defmacro setf (&rest args &environment env)  (defmacro setf (&rest args &environment env)
# Line 577  Line 589 
589    is the value that is supposed to go into that place.  Returns the last    is the value that is supposed to go into that place.  Returns the last
590    value.  The place argument may be any of the access forms for which SETF    value.  The place argument may be any of the access forms for which SETF
591    knows a corresponding setting form."    knows a corresponding setting form."
592    (let ((temp (length args)))    (let ((nargs (length args)))
593      (cond ((= temp 2)      (cond
594             (cond ((atom (car args))       ((= nargs 2)
595                    `(setq ,(car args) ,(cadr args)))        (if (atom (car args))
596                   ((info function accessor-for (caar args))            `(setq ,(car args) ,(cadr args))
597                    `(funcall #'(setf ,(caar args)) ,(cadr args) ,@(cdar args)))            (multiple-value-bind (dummies vals newval setter getter)
598                   ((setq temp (info setf inverse (caar args)))                                 (get-setf-method (car args) env)
599                    `(,temp ,@(cdar args) ,(cadr args)))              (declare (ignore getter))
600                   (t (multiple-value-bind (dummies vals newval setter getter)              (do* ((d dummies (cdr d))
601                                           (get-setf-method (car args) env)                    (v vals (cdr v))
602                        (declare (ignore getter))                    (let-list nil))
603                        (do* ((d dummies (cdr d))                   ((null d)
604                              (v vals (cdr v))                    (setq let-list
605                              (let-list nil))                          (nreverse (cons (list (car newval)
606                             ((null d)                                                (cadr args))
607                              (setq let-list                                          let-list)))
608                                    (nreverse (cons (list (car newval)                    `(let* ,let-list ,setter))
609                                                          (cadr args))                (setq let-list
610                                                    let-list)))                      (cons (list (car d) (car v)) let-list))))))
611                              `(let* ,let-list ,setter))       ((oddp nargs)
612                          (setq let-list        (error "Odd number of args to SETF."))
613                                (cons (list (car d) (car v)) let-list)))))))       (t
614            ((oddp temp)        (do ((a args (cddr a)) (l nil))
615             (error "Odd number of args to SETF."))            ((null a) `(progn ,@(nreverse l)))
616            (t (do ((a args (cddr a)) (l nil))          (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
                  ((null a) `(progn ,@(nreverse l)))  
                (setq l (cons (list 'setf (car a) (cadr a)) l)))))))  
617    
618    
619  (defmacro psetf (&rest args &environment env)  (defmacro psetf (&rest args &environment env)
# Line 947  Line 957 
957            ,v))            ,v))
958    
959    
960  ;;; Evil hack invented by the gnomes of Vassar Street.  The function  ;;; Evil hack invented by the gnomes of Vassar Street.  The function arg must
961  ;;; arg must be constant.  Get a setf method for this function, pretending  ;;; be constant.  Get a setf method for this function, pretending that the
962  ;;; that the final (list) arg to apply is just a normal arg.  If the  ;;; final (list) arg to apply is just a normal arg.  If the setting and access
963  ;;; setting and access forms produced in this way reference this arg at  ;;; forms produced in this way reference this arg at the end, then just splice
964  ;;; the end, then just splice the APPLY back onto the front and the right  ;;; the APPLY back onto the front and the right thing happens.
965  ;;; thing happens.  ;;;
966    ;;; We special-case uses functions in the Lisp package so that APPLY AREF works
967    ;;; even though %ASET takes the new-value last.  (there is (SETF AREF) as well
968    ;;; as a setf method, etc.)
969    ;;;
970  (define-setf-method apply (function &rest args &environment env)  (define-setf-method apply (function &rest args &environment env)
971    (if (and (listp function)    (unless (and (listp function)
972             (= (list-length function) 2)                 (= (list-length function) 2)
973             (eq (first function) 'function)                 (eq (first function) 'function)
974             (symbolp (second function)))                 (symbolp (second function)))
975        (setq function (second function))      (error "Setf of Apply is only defined for function args like #'symbol."))
976        (error    (let ((function (second function)))
977         "Setf of Apply is only defined for function args of form #'symbol."))      (multiple-value-bind
978    (multiple-value-bind (dummies vals newval setter getter)          (dummies vals newval setter getter)
979                         (get-setf-method (cons function args) env)          (if (eq (symbol-package function) (symbol-package 'aref))
980      ;; Special case aref and svref.              (get-setf-method-inverse (cons function args) `((setf ,function)) t)
981      (cond ((or (eq function 'aref) (eq function 'svref))              (get-setf-method (cons function args) env))
982             (let ((nargs (subseq setter 0 (1- (length setter))))        (unless (and (eq (car (last args)) (car (last vals)))
983                   (fcn (if (eq function 'aref) 'lisp::%apply-aset 'lisp::%apply-svset)))                     (eq (car (last getter)) (car (last dummies)))
984               (values dummies vals newval                     (eq (car (last setter)) (car (last dummies))))
985                       `(apply (function ,fcn) ,(car newval) ,@(cdr nargs))          (error "Apply of ~S not understood as a location for Setf." function))
986                       `(apply (function ,function) ,@(cdr getter)))))        (values dummies vals newval
987            ;; Make sure the place is one that we can handle.                `(apply (function ,(car setter)) ,@(cdr setter))
988            (T (unless (and (eq (car (last args)) (car (last vals)))                `(apply (function ,(car getter)) ,@(cdr getter))))))
                           (eq (car (last getter)) (car (last dummies)))  
                           (eq (car (last setter)) (car (last dummies))))  
                (error "Apply of ~S not understood as a location for Setf."  
                       function))  
              (values dummies vals newval  
                      `(apply (function ,(car setter)) ,@(cdr setter))  
                      `(apply (function ,(car getter)) ,@(cdr getter)))))))  
989    
990    
991  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.

Legend:
Removed from v.1.21  
changed lines
  Added in v.1.22

  ViewVC Help
Powered by ViewVC 1.1.5