/[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.57 by pw, Thu Jul 16 13:30:48 1998 UTC revision 1.58 by dtc, Fri Jul 17 12:10:44 1998 UTC
# Line 196  Line 196 
196    "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body    "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body
197    must be a form that returns the five magical values."    must be a form that returns the five magical values."
198    (unless (symbolp access-fn)    (unless (symbolp access-fn)
199      (error "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD."      (error "~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER."
200             access-fn))             access-fn))
201    
202    (let ((whole (gensym "WHOLE-"))    (let ((whole (gensym "WHOLE-"))
203          (environment (gensym "ENV-")))          (environment (gensym "ENV-")))
204      (multiple-value-bind (body local-decs doc)      (multiple-value-bind (body local-decs doc)
205                           (parse-defmacro lambda-list whole body access-fn                           (parse-defmacro lambda-list whole body access-fn
206                                           'define-setf-method                                           'define-setf-expander
207                                           :environment environment)                                           :environment environment)
208        `(eval-when (load compile eval)        `(eval-when (load compile eval)
209           (%define-setf-macro           (%define-setf-macro
# Line 519  Line 519 
519  ;;; new-value arg at the end.  ;;; new-value arg at the end.
520  ;;;  ;;;
521  ;;; A SETF method expander is created by the long form of DEFSETF or  ;;; A SETF method expander is created by the long form of DEFSETF or
522  ;;; by DEFINE-SETF-METHOD.  It is a function that is called on the reference  ;;; by DEFINE-SETF-EXPANDER.  It is a function that is called on the reference
523  ;;; form and that produces five values: a list of temporary variables, a list  ;;; form and that produces five values: a list of temporary variables, a list
524  ;;; of value forms, a list of the single store-value form, a storing function,  ;;; of value forms, a list of the single store-value form, a storing function,
525  ;;; and an accessing function.  ;;; and an accessing function.
# Line 995  Line 995 
995  #+long-float  #+long-float
996  (defsetf sap-ref-long %set-sap-ref-long)  (defsetf sap-ref-long %set-sap-ref-long)
997    
998  (define-setf-method getf (place prop &optional default &environment env)  (define-setf-expander getf (place prop &optional default &environment env)
999    (multiple-value-bind (temps values stores set get)    (multiple-value-bind (temps values stores set get)
1000                         (get-setf-method place env)                         (get-setf-method place env)
1001      (let ((newval (gensym))      (let ((newval (gensym))
# Line 1009  Line 1009 
1009                   ,newval)                   ,newval)
1010                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
1011    
1012  (define-setf-method get (symbol prop &optional default)  (define-setf-expander get (symbol prop &optional default)
1013    (let ((symbol-temp (gensym))    (let ((symbol-temp (gensym))
1014          (prop-temp (gensym))          (prop-temp (gensym))
1015          (def-temp (gensym))          (def-temp (gensym))
# Line 1020  Line 1020 
1020              `(%put ,symbol-temp ,prop-temp ,newval)              `(%put ,symbol-temp ,prop-temp ,newval)
1021              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
1022    
1023  (define-setf-method gethash (key hashtable &optional default)  (define-setf-expander gethash (key hashtable &optional default)
1024    (let ((key-temp (gensym))    (let ((key-temp (gensym))
1025          (hashtable-temp (gensym))          (hashtable-temp (gensym))
1026          (default-temp (gensym))          (default-temp (gensym))
# Line 1041  Line 1041 
1041  ;;; it used to be.)  The function arg must be constant, and is converted to an  ;;; it used to be.)  The function arg must be constant, and is converted to an
1042  ;;; APPLY of ther SETF function, which ought to exist.  ;;; APPLY of ther SETF function, which ought to exist.
1043  ;;;  ;;;
1044  (define-setf-method apply (function &rest args)  (define-setf-expander apply (function &rest args)
1045    (unless (and (listp function)    (unless (and (listp function)
1046                 (= (list-length function) 2)                 (= (list-length function) 2)
1047                 (eq (first function) 'function)                 (eq (first function) 'function)
# Line 1060  Line 1060 
1060    
1061  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
1062  ;;;  ;;;
1063  (define-setf-method ldb (bytespec place &environment env)  (define-setf-expander ldb (bytespec place &environment env)
1064    "The first argument is a byte specifier.  The second is any place form    "The first argument is a byte specifier.  The second is any place form
1065    acceptable to SETF.  Replaces the specified byte of the number in this    acceptable to SETF.  Replaces the specified byte of the number in this
1066    place with bits from the low-order end of the new value."    place with bits from the low-order end of the new value."
# Line 1089  Line 1089 
1089                    `(ldb ,btemp ,getter))))))                    `(ldb ,btemp ,getter))))))
1090    
1091    
1092  (define-setf-method mask-field (bytespec place &environment env)  (define-setf-expander mask-field (bytespec place &environment env)
1093    "The first argument is a byte specifier.  The second is any place form    "The first argument is a byte specifier.  The second is any place form
1094    acceptable to SETF.  Replaces the specified byte of the number in this place    acceptable to SETF.  Replaces the specified byte of the number in this place
1095    with bits from the corresponding position in the new value."    with bits from the corresponding position in the new value."
# Line 1106  Line 1106 
1106                `(mask-field ,btemp ,getter)))))                `(mask-field ,btemp ,getter)))))
1107    
1108    
1109  (define-setf-method the (type place &environment env)  (define-setf-expander the (type place &environment env)
1110    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1111                         (get-setf-method place env)                         (get-setf-method place env)
1112        (values dummies        (values dummies
# Line 1115  Line 1115 
1115                (subst `(the ,type ,(car newval)) (car newval) setter)                (subst `(the ,type ,(car newval)) (car newval) setter)
1116                `(the ,type ,getter))))                `(the ,type ,getter))))
1117    
1118    (define-setf-expander values (&rest places &environment env)
1119      (collect ((setters) (getters))
1120        (let ((all-dummies '())
1121              (all-vals '())
1122              (newvals '()))
1123          (dolist (place places)
1124            (multiple-value-bind (dummies vals newval setter getter)
1125                (get-setf-expansion place env)
1126              (setf all-dummies (append all-dummies dummies))
1127              (setf all-vals (append all-vals vals))
1128              (setf newvals (append newvals newval))
1129              (setters setter)
1130              (getters getter)))
1131          (values all-dummies all-vals newvals
1132                  `(values ,@(setters)) `(values ,@(getters))))))
1133    
1134    
1135  ;;;; CASE, TYPECASE, & Friends.  ;;;; CASE, TYPECASE, & Friends.
1136    

Legend:
Removed from v.1.57  
changed lines
  Added in v.1.58

  ViewVC Help
Powered by ViewVC 1.1.5