/[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.50 by pw, Thu Jun 5 13:02:45 1997 UTC revision 1.50.2.6 by dtc, Sun Jul 9 14:03:01 2000 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 497  Line 497 
497             (declare (ignore ,@dummy-list))             (declare (ignore ,@dummy-list))
498             ,keeper))             ,keeper))
499        (once-only ((n n))        (once-only ((n n))
500          `(case (the fixnum ,n)          `(case (the (values fixnum &rest t) ,n)
501             (0 (nth-value 0 ,form))             (0 (nth-value 0 ,form))
502             (1 (nth-value 1 ,form))             (1 (nth-value 1 ,form))
503             (2 (nth-value 2 ,form))             (2 (nth-value 2 ,form))
504             (T (nth (the fixnum ,n) (multiple-value-list ,form)))))))             (T (nth (the (values fixnum &rest t) ,n)
505                            (multiple-value-list ,form)))))))
506    
507    
508  ;;;; SETF and friends.  ;;;; SETF and friends.
# Line 519  Line 520 
520  ;;; new-value arg at the end.  ;;; new-value arg at the end.
521  ;;;  ;;;
522  ;;; 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
523  ;;; 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
524  ;;; 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
525  ;;; 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,
526  ;;; and an accessing function.  ;;; and an accessing function.
# Line 824  Line 825 
825                `(let* ,(nreverse let-list)                `(let* ,(nreverse let-list)
826                   ,setter)))))))                   ,setter)))))))
827    
   
   
828  (defmacro push (obj place &environment env)  (defmacro push (obj place &environment env)
829    "Takes an object and a location holding a list.  Conses the object onto    "Takes an object and a location holding a list.  Conses the object onto
830    the list, returning the modified list."    the list, returning the modified list.  OBJ is evaluated before PLACE."
831    (if (symbolp place)    (if (symbolp place)
832        `(setq ,place (cons ,obj ,place))        `(setq ,place (cons ,obj ,place))
833        (multiple-value-bind (dummies vals newval setter getter)        (multiple-value-bind (dummies vals newval setter getter)
834                             (get-setf-method place env)            (get-setf-method place env)
835          (do* ((d dummies (cdr d))          (let ((g (gensym)))
836                (v vals (cdr v))            `(let* ((,g ,obj)
837                (let-list nil))                    ,@(mapcar #'list dummies vals)
838               ((null d)                    (,(car newval) (cons ,g ,getter)))
839                (push (list (car newval) `(cons ,obj ,getter))              ,setter)))))
                     let-list)  
               `(let* ,(nreverse let-list)  
                  ,setter))  
           (push (list (car d) (car v)) let-list)))))  
   
840    
841  (defmacro pushnew (obj place &rest keys &environment env)  (defmacro pushnew (obj place &rest keys &environment env)
842    "Takes an object and a location holding a list.  If the object is already    "Takes an object and a location holding a list.  If the object is already
# Line 982  Line 976 
976  (defsetf symbol-value set)  (defsetf symbol-value set)
977  (defsetf symbol-function fset)  (defsetf symbol-function fset)
978  (defsetf symbol-plist %set-symbol-plist)  (defsetf symbol-plist %set-symbol-plist)
 (defsetf documentation %set-documentation)  
979  (defsetf nth %setnth)  (defsetf nth %setnth)
980  (defsetf fill-pointer %set-fill-pointer)  (defsetf fill-pointer %set-fill-pointer)
981  (defsetf search-list %set-search-list)  (defsetf search-list %set-search-list)
# Line 993  Line 986 
986  (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)  (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
987  (defsetf sap-ref-32 %set-sap-ref-32)  (defsetf sap-ref-32 %set-sap-ref-32)
988  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
 #+alpha  
989  (defsetf sap-ref-64 %set-sap-ref-64)  (defsetf sap-ref-64 %set-sap-ref-64)
 #+alpha  
990  (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)  (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
991  (defsetf sap-ref-sap %set-sap-ref-sap)  (defsetf sap-ref-sap %set-sap-ref-sap)
992  (defsetf sap-ref-single %set-sap-ref-single)  (defsetf sap-ref-single %set-sap-ref-single)
993  (defsetf sap-ref-double %set-sap-ref-double)  (defsetf sap-ref-double %set-sap-ref-double)
994    #+long-float
995    (defsetf sap-ref-long %set-sap-ref-long)
996    
997  (define-setf-method getf (place prop &optional default &environment env)  (define-setf-expander getf (place prop &optional default &environment env)
998    (multiple-value-bind (temps values stores set get)    (multiple-value-bind (temps values stores set get)
999                         (get-setf-method place env)                         (get-setf-method place env)
1000      (let ((newval (gensym))      (let ((newval (gensym))
# Line 1015  Line 1008 
1008                   ,newval)                   ,newval)
1009                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
1010    
1011  (define-setf-method get (symbol prop &optional default)  (define-setf-expander get (symbol prop &optional default)
1012    (let ((symbol-temp (gensym))    (let ((symbol-temp (gensym))
1013          (prop-temp (gensym))          (prop-temp (gensym))
1014          (def-temp (gensym))          (def-temp (gensym))
# Line 1026  Line 1019 
1019              `(%put ,symbol-temp ,prop-temp ,newval)              `(%put ,symbol-temp ,prop-temp ,newval)
1020              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
1021    
1022  (define-setf-method gethash (key hashtable &optional default)  (define-setf-expander gethash (key hashtable &optional default)
1023    (let ((key-temp (gensym))    (let ((key-temp (gensym))
1024          (hashtable-temp (gensym))          (hashtable-temp (gensym))
1025          (default-temp (gensym))          (default-temp (gensym))
# Line 1047  Line 1040 
1040  ;;; 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
1041  ;;; APPLY of ther SETF function, which ought to exist.  ;;; APPLY of ther SETF function, which ought to exist.
1042  ;;;  ;;;
1043  (define-setf-method apply (function &rest args)  (define-setf-expander apply (function &rest args)
1044    (unless (and (listp function)    (unless (and (listp function)
1045                 (= (list-length function) 2)                 (= (list-length function) 2)
1046                 (eq (first function) 'function)                 (eq (first function) 'function)
# Line 1066  Line 1059 
1059    
1060  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
1061  ;;;  ;;;
1062  (define-setf-method ldb (bytespec place &environment env)  (define-setf-expander ldb (bytespec place &environment env)
1063    "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
1064    acceptable to SETF.  Replaces the specified byte of the number in this    acceptable to SETF.  Replaces the specified byte of the number in this
1065    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 1095  Line 1088 
1088                    `(ldb ,btemp ,getter))))))                    `(ldb ,btemp ,getter))))))
1089    
1090    
1091  (define-setf-method mask-field (bytespec place &environment env)  (define-setf-expander mask-field (bytespec place &environment env)
1092    "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
1093    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
1094    with bits from the corresponding position in the new value."    with bits from the corresponding position in the new value."
# Line 1112  Line 1105 
1105                `(mask-field ,btemp ,getter)))))                `(mask-field ,btemp ,getter)))))
1106    
1107    
1108  (define-setf-method the (type place &environment env)  (define-setf-expander the (type place &environment env)
1109    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1110                         (get-setf-method place env)                         (get-setf-method place env)
1111        (values dummies        (values dummies
# Line 1121  Line 1114 
1114                (subst `(the ,type ,(car newval)) (car newval) setter)                (subst `(the ,type ,(car newval)) (car newval) setter)
1115                `(the ,type ,getter))))                `(the ,type ,getter))))
1116    
1117    (define-setf-expander values (&rest places &environment env)
1118      (collect ((setters) (getters))
1119        (let ((all-dummies '())
1120              (all-vals '())
1121              (newvals '()))
1122          (dolist (place places)
1123            (multiple-value-bind (dummies vals newval setter getter)
1124                (get-setf-expansion place env)
1125              (setf all-dummies (append all-dummies dummies))
1126              (setf all-vals (append all-vals vals))
1127              (setf newvals (append newvals newval))
1128              (setters setter)
1129              (getters getter)))
1130          (values all-dummies all-vals newvals
1131                  `(values ,@(setters)) `(values ,@(getters))))))
1132    
1133    
1134  ;;;; CASE, TYPECASE, & Friends.  ;;;; CASE, TYPECASE, & Friends.
1135    
# Line 1392  Line 1401 
1401  (defmacro with-input-from-string ((var string &key index start end) &body (forms decls))  (defmacro with-input-from-string ((var string &key index start end) &body (forms decls))
1402    "Binds the Var to an input stream that returns characters from String and    "Binds the Var to an input stream that returns characters from String and
1403    executes the body.  See manual for details."    executes the body.  See manual for details."
1404    `(let ((,var    ;; The once-only inhibits compiler note for unreachable code when 'end' is true.
1405            ,(cond ((null end)    (once-only ((string string))
1406                    `(make-string-input-stream ,string ,(or start 0)))      `(let ((,var
1407                   ((symbolp end)              ,(cond ((null end)
1408                    `(if ,end                      `(make-string-input-stream ,string ,(or start 0)))
1409                         (make-string-input-stream ,string ,(or start 0) ,end)                     ((symbolp end)
1410                       (make-string-input-stream ,string ,(or start 0))))                      `(if ,end
1411                   (t                           (make-string-input-stream ,string ,(or start 0) ,end)
1412                    `(make-string-input-stream ,string ,(or start 0) ,end)))))                           (make-string-input-stream ,string ,(or start 0))))
1413       ,@decls                     (t
1414       (unwind-protect                      `(make-string-input-stream ,string ,(or start 0) ,end)))))
1415         (progn ,@forms)         ,@decls
1416         (close ,var)         (unwind-protect
1417         ,@(if index `((setf ,index (string-input-stream-current ,var)))))))             (progn ,@forms)
1418             (close ,var)
1419             ,@(if index `((setf ,index (string-input-stream-current ,var))))))))
1420    
1421    
1422  (defmacro with-output-to-string ((var &optional string) &body (forms decls))  (defmacro with-output-to-string ((var &optional string) &body (forms decls))
# Line 1466  Line 1477 
1477    Iteration construct.  Each Var is initialized in parallel to the value of the    Iteration construct.  Each Var is initialized in parallel to the value of the
1478    specified Init form.  On subsequent iterations, the Vars are assigned the    specified Init form.  On subsequent iterations, the Vars are assigned the
1479    value of the Step form (if any) in paralell.  The Test is evaluated before    value of the Step form (if any) in paralell.  The Test is evaluated before
1480    each evaluation of the body Forms.  When the Test is true, the the Exit-Forms    each evaluation of the body Forms.  When the Test is true, the Exit-Forms
1481    are evaluated as a PROGN, with the result being the value of the DO.  A block    are evaluated as a PROGN, with the result being the value of the DO.  A block
1482    named NIL is established around the entire expansion, allowing RETURN to be    named NIL is established around the entire expansion, allowing RETURN to be
1483    used as an laternate exit mechanism."    used as an laternate exit mechanism."
# Line 1480  Line 1491 
1491    value of the specified Init form.  On subsequent iterations, the Vars are    value of the specified Init form.  On subsequent iterations, the Vars are
1492    sequentially assigned the value of the Step form (if any).  The Test is    sequentially assigned the value of the Step form (if any).  The Test is
1493    evaluated before each evaluation of the body Forms.  When the Test is true,    evaluated before each evaluation of the body Forms.  When the Test is true,
1494    the the Exit-Forms are evaluated as a PROGN, with the result being the value    the Exit-Forms are evaluated as a PROGN, with the result being the value
1495    of the DO.  A block named NIL is established around the entire expansion,    of the DO.  A block named NIL is established around the entire expansion,
1496    allowing RETURN to be used as an laternate exit mechanism."    allowing RETURN to be used as an laternate exit mechanism."
1497    (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))    (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))
# Line 1497  Line 1508 
1508         (setqs nil)         (setqs nil)
1509         (pairs pairs (cddr pairs)))         (pairs pairs (cddr pairs)))
1510        ((atom (cdr pairs))        ((atom (cdr pairs))
1511         `(let ,(nreverse lets) (setq ,@(nreverse setqs))))         `(let ,(nreverse lets) (setq ,@(nreverse setqs)) nil))
1512      (let ((gen (gensym)))      (let ((gen (gensym)))
1513        (push `(,gen ,(cadr pairs)) lets)        (push `(,gen ,(cadr pairs)) lets)
1514        (push (car pairs) setqs)        (push (car pairs) setqs)

Legend:
Removed from v.1.50  
changed lines
  Added in v.1.50.2.6

  ViewVC Help
Powered by ViewVC 1.1.5