/[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.38 by ram, Thu May 6 09:56:54 1993 UTC revision 1.39 by ram, Thu Jun 24 12:22:27 1993 UTC
# Line 19  Line 19 
19  ;;;  ;;;
20  (in-package "LISP")  (in-package "LISP")
21  (export '(defvar defparameter defconstant when unless setf  (export '(defvar defparameter defconstant when unless setf
22            defsetf define-setf-method psetf shiftf rotatef push pushnew pop            defsetf psetf shiftf rotatef push pushnew pop
23            incf decf remf case typecase with-open-file            incf decf remf case typecase with-open-file
24            with-open-stream with-input-from-string with-output-to-string            with-open-stream with-input-from-string with-output-to-string
25            locally etypecase ctypecase ecase ccase            locally etypecase ctypecase ecase ccase
26            get-setf-method get-setf-method-multiple-value            get-setf-expansion define-setf-expander
27            define-modify-macro destructuring-bind nth-value            define-modify-macro destructuring-bind nth-value
28            otherwise ; Sacred to CASE and related macros.            otherwise ; Sacred to CASE and related macros.
29            define-compiler-macro))            define-compiler-macro
30              ;; CLtL1 versions:
31              define-setf-method get-setf-method get-setf-method-multiple-value))
32    
33  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
34  (export '(do-anonymous collect iterate))  (export '(do-anonymous collect iterate))
# Line 188  Line 190 
190    name)    name)
191    
192    
193  ;;; And so is DEFINE-SETF-METHOD.  ;;; And so is DEFINE-SETF-EXPANDER.
194    
195  (defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.")  (defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.")
196    
197  (defmacro define-setf-method (access-fn lambda-list &body body)  (defmacro define-setf-expander (access-fn lambda-list &body body)
198    "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body    "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body
199    must be a form that returns the five magical values."    must be a form that returns the five magical values."
200    (unless (symbolp access-fn)    (unless (symbolp access-fn)
# Line 214  Line 216 
216            nil            nil
217            ',doc)))))            ',doc)))))
218    
219    (defmacro define-setf-method (&rest stuff)
220      "Obsolete, use define-setf-expander."
221      `(define-setf-expander ,@stuff))
222    
223    
224  ;;; %DEFINE-SETF-MACRO  --  Internal  ;;; %DEFINE-SETF-MACRO  --  Internal
225  ;;;  ;;;
# Line 520  Line 526 
526  ;;; 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,
527  ;;; and an accessing function.  ;;; and an accessing function.
528    
529  (defun get-setf-method-multiple-value (form &optional environment)  (defun get-setf-expansion (form &optional environment)
530    "Returns five values needed by the SETF machinery: a list of temporary    "Returns five values needed by the SETF machinery: a list of temporary
531     variables, a list of values with which to fill them, a list of temporaries     variables, a list of values with which to fill them, a list of temporaries
532     for the new values, the setting function, and the accessing function."     for the new values, the setting function, and the accessing function."
# Line 530  Line 536 
536                 (expansion expanded)                 (expansion expanded)
537                 (macroexpand-1 form environment)                 (macroexpand-1 form environment)
538               (if expanded               (if expanded
539                   (get-setf-method-multiple-value expansion environment)                   (get-setf-expansion expansion environment)
540                   (let ((new-var (gensym)))                   (let ((new-var (gensym)))
541                     (values nil nil (list new-var)                     (values nil nil (list new-var)
542                             `(setq ,form ,new-var) form)))))                             `(setq ,form ,new-var) form)))))
# Line 550  Line 556 
556            (t            (t
557             (expand-or-get-setf-inverse form environment)))))             (expand-or-get-setf-inverse form environment)))))
558    
559    (defun get-setf-method-multiple-value (form &optional env)
560      "Obsolete: use GET-SETF-EXPANSION."
561      (get-setf-expansion form env))
562    
563  ;;;  ;;;
564  ;;; If a macro, expand one level and try again.  If not, go for the  ;;; If a macro, expand one level and try again.  If not, go for the
# Line 559  Line 568 
568        (expansion expanded)        (expansion expanded)
569        (macroexpand-1 form environment)        (macroexpand-1 form environment)
570      (if expanded      (if expanded
571          (get-setf-method-multiple-value expansion environment)          (get-setf-expansion expansion environment)
572          (get-setf-method-inverse form `(funcall #'(setf ,(car form)))          (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
573                                   t))))                                   t))))
574    
# Line 580  Line 589 
589    
590    
591  (defun get-setf-method (form &optional environment)  (defun get-setf-method (form &optional environment)
592    "Like Get-Setf-Method-Multiple-Value, but signal an error if there are    "Obsolete: use GET-SETF-EXPANSION and handle multiple store values."
    more than one new-value variables."  
593    (multiple-value-bind    (multiple-value-bind
594        (temps value-forms store-vars store-form access-form)        (temps value-forms store-vars store-form access-form)
595        (get-setf-method-multiple-value form environment)        (get-setf-expansion form environment)
596      (when (cdr store-vars)      (when (cdr store-vars)
597        (error "GET-SETF-METHOD used for a form with multiple store ~        (error "GET-SETF-METHOD used for a form with multiple store ~
598                variables:~%  ~S" form))                variables:~%  ~S" form))
# Line 680  Line 688 
688          (if (atom place)          (if (atom place)
689              `(setq ,place ,value-form)              `(setq ,place ,value-form)
690              (multiple-value-bind (dummies vals newval setter getter)              (multiple-value-bind (dummies vals newval setter getter)
691                                   (get-setf-method-multiple-value place env)                                   (get-setf-expansion place env)
692                (declare (ignore getter))                (declare (ignore getter))
693                (let ((inverse (info setf inverse (car place))))                (let ((inverse (info setf inverse (car place))))
694                  (if (and inverse (eq inverse (car setter)))                  (if (and inverse (eq inverse (car setter)))
# Line 707  Line 715 
715            (error "Odd number of args to PSETF."))            (error "Odd number of args to PSETF."))
716        (multiple-value-bind        (multiple-value-bind
717            (dummies vals newval setter getter)            (dummies vals newval setter getter)
718            (get-setf-method-multiple-value (car a) env)            (get-setf-expansion (car a) env)
719          (declare (ignore getter))          (declare (ignore getter))
720          (let*-bindings (mapcar #'list dummies vals))          (let*-bindings (mapcar #'list dummies vals))
721          (mv-bindings (list newval (cadr a)))          (mv-bindings (list newval (cadr a)))
# Line 738  Line 746 
746                     ,prev-setter)))                     ,prev-setter)))
747        (multiple-value-bind        (multiple-value-bind
748            (temps exprs store-vars setter getter)            (temps exprs store-vars setter getter)
749            (get-setf-method-multiple-value (car a) env)            (get-setf-expansion (car a) env)
750          (loop          (loop
751            for temp in temps            for temp in temps
752            for expr in exprs            for expr in exprs
# Line 763  Line 771 
771        (dolist (arg args)        (dolist (arg args)
772          (multiple-value-bind          (multiple-value-bind
773              (temps subforms store-vars setter getter)              (temps subforms store-vars setter getter)
774              (get-setf-method-multiple-value arg env)              (get-setf-expansion arg env)
775            (loop            (loop
776              for temp in temps              for temp in temps
777              for subform in subforms              for subform in subforms

Legend:
Removed from v.1.38  
changed lines
  Added in v.1.39

  ViewVC Help
Powered by ViewVC 1.1.5