/[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.9 by dtc, Fri Oct 6 15:20:38 2000 UTC
# Line 145  Line 145 
145    
146    
147    
148    ;;;; DEFINE-SYMBOL-MACRO
149    
150    ;;; define-symbol-macro  --  Public
151    ;;;
152    (defmacro define-symbol-macro (name expansion)
153      `(eval-when (compile load eval)
154         (%define-symbol-macro ',name ',expansion)))
155    ;;;
156    (defun %define-symbol-macro (name expansion)
157      (unless (symbolp name)
158        (error 'simple-type-error :datum name :expected-type 'symbol
159               :format-control "Symbol macro name is not a symbol: ~S."
160               :format-arguments (list name)))
161      (ecase (info variable kind name)
162        ((:macro :global nil)
163         (setf (info variable kind name) :macro)
164         (setf (info variable macro-expansion name) expansion))
165        (:special
166         (error 'simple-program-error
167                :format-control "Symbol macro name already declared special: ~S."
168                :format-arguments (list name)))
169        (:constant
170         (error 'simple-program-error
171                :format-control "Symbol macro name already declared constant: ~S."
172                :format-arguments (list name))))
173      name)
174    
175    
176  ;;; DEFTYPE is a lot like DEFMACRO.  ;;; DEFTYPE is a lot like DEFMACRO.
177    
178  (defmacro deftype (name arglist &body body)  (defmacro deftype (name arglist &body body)
# Line 196  Line 224 
224    "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body    "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body
225    must be a form that returns the five magical values."    must be a form that returns the five magical values."
226    (unless (symbolp access-fn)    (unless (symbolp access-fn)
227      (error "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD."      (error "~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER."
228             access-fn))             access-fn))
229    
230    (let ((whole (gensym "WHOLE-"))    (let ((whole (gensym "WHOLE-"))
231          (environment (gensym "ENV-")))          (environment (gensym "ENV-")))
232      (multiple-value-bind (body local-decs doc)      (multiple-value-bind (body local-decs doc)
233                           (parse-defmacro lambda-list whole body access-fn                           (parse-defmacro lambda-list whole body access-fn
234                                           'define-setf-method                                           'define-setf-expander
235                                           :environment environment)                                           :environment environment)
236        `(eval-when (load compile eval)        `(eval-when (load compile eval)
237           (%define-setf-macro           (%define-setf-macro
# Line 497  Line 525 
525             (declare (ignore ,@dummy-list))             (declare (ignore ,@dummy-list))
526             ,keeper))             ,keeper))
527        (once-only ((n n))        (once-only ((n n))
528          `(case (the fixnum ,n)          `(case (the (values fixnum &rest t) ,n)
529             (0 (nth-value 0 ,form))             (0 (nth-value 0 ,form))
530             (1 (nth-value 1 ,form))             (1 (nth-value 1 ,form))
531             (2 (nth-value 2 ,form))             (2 (nth-value 2 ,form))
532             (T (nth (the fixnum ,n) (multiple-value-list ,form)))))))             (T (nth (the (values fixnum &rest t) ,n)
533                            (multiple-value-list ,form)))))))
534    
535    
536  ;;;; SETF and friends.  ;;;; SETF and friends.
# Line 519  Line 548 
548  ;;; new-value arg at the end.  ;;; new-value arg at the end.
549  ;;;  ;;;
550  ;;; 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
551  ;;; 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
552  ;;; 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
553  ;;; 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,
554  ;;; and an accessing function.  ;;; and an accessing function.
# Line 824  Line 853 
853                `(let* ,(nreverse let-list)                `(let* ,(nreverse let-list)
854                   ,setter)))))))                   ,setter)))))))
855    
   
   
856  (defmacro push (obj place &environment env)  (defmacro push (obj place &environment env)
857    "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
858    the list, returning the modified list."    the list, returning the modified list.  OBJ is evaluated before PLACE."
859    (if (symbolp place)    (if (symbolp place)
860        `(setq ,place (cons ,obj ,place))        `(setq ,place (cons ,obj ,place))
861        (multiple-value-bind (dummies vals newval setter getter)        (multiple-value-bind (dummies vals newval setter getter)
862                             (get-setf-method place env)            (get-setf-method place env)
863          (do* ((d dummies (cdr d))          (let ((g (gensym)))
864                (v vals (cdr v))            `(let* ((,g ,obj)
865                (let-list nil))                    ,@(mapcar #'list dummies vals)
866               ((null d)                    (,(car newval) (cons ,g ,getter)))
867                (push (list (car newval) `(cons ,obj ,getter))              ,setter)))))
                     let-list)  
               `(let* ,(nreverse let-list)  
                  ,setter))  
           (push (list (car d) (car v)) let-list)))))  
   
868    
869  (defmacro pushnew (obj place &rest keys &environment env)  (defmacro pushnew (obj place &rest keys &environment env)
870    "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 1004 
1004  (defsetf symbol-value set)  (defsetf symbol-value set)
1005  (defsetf symbol-function fset)  (defsetf symbol-function fset)
1006  (defsetf symbol-plist %set-symbol-plist)  (defsetf symbol-plist %set-symbol-plist)
 (defsetf documentation %set-documentation)  
1007  (defsetf nth %setnth)  (defsetf nth %setnth)
1008  (defsetf fill-pointer %set-fill-pointer)  (defsetf fill-pointer %set-fill-pointer)
1009  (defsetf search-list %set-search-list)  (defsetf search-list %set-search-list)
# Line 993  Line 1014 
1014  (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)  (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
1015  (defsetf sap-ref-32 %set-sap-ref-32)  (defsetf sap-ref-32 %set-sap-ref-32)
1016  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
 #+alpha  
1017  (defsetf sap-ref-64 %set-sap-ref-64)  (defsetf sap-ref-64 %set-sap-ref-64)
 #+alpha  
1018  (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)  (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
1019  (defsetf sap-ref-sap %set-sap-ref-sap)  (defsetf sap-ref-sap %set-sap-ref-sap)
1020  (defsetf sap-ref-single %set-sap-ref-single)  (defsetf sap-ref-single %set-sap-ref-single)
1021  (defsetf sap-ref-double %set-sap-ref-double)  (defsetf sap-ref-double %set-sap-ref-double)
1022    #+long-float
1023    (defsetf sap-ref-long %set-sap-ref-long)
1024    
1025  (define-setf-method getf (place prop &optional default &environment env)  (define-setf-expander getf (place prop &optional default &environment env)
1026    (multiple-value-bind (temps values stores set get)    (multiple-value-bind (temps values stores set get)
1027                         (get-setf-method place env)                         (get-setf-method place env)
1028      (let ((newval (gensym))      (let ((newval (gensym))
# Line 1015  Line 1036 
1036                   ,newval)                   ,newval)
1037                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
1038    
1039  (define-setf-method get (symbol prop &optional default)  (define-setf-expander get (symbol prop &optional default)
1040    (let ((symbol-temp (gensym))    (let ((symbol-temp (gensym))
1041          (prop-temp (gensym))          (prop-temp (gensym))
1042          (def-temp (gensym))          (def-temp (gensym))
# Line 1026  Line 1047 
1047              `(%put ,symbol-temp ,prop-temp ,newval)              `(%put ,symbol-temp ,prop-temp ,newval)
1048              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
1049    
1050  (define-setf-method gethash (key hashtable &optional default)  (define-setf-expander gethash (key hashtable &optional default)
1051    (let ((key-temp (gensym))    (let ((key-temp (gensym))
1052          (hashtable-temp (gensym))          (hashtable-temp (gensym))
1053          (default-temp (gensym))          (default-temp (gensym))
# Line 1047  Line 1068 
1068  ;;; 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
1069  ;;; APPLY of ther SETF function, which ought to exist.  ;;; APPLY of ther SETF function, which ought to exist.
1070  ;;;  ;;;
1071  (define-setf-method apply (function &rest args)  (define-setf-expander apply (function &rest args)
1072    (unless (and (listp function)    (unless (and (listp function)
1073                 (= (list-length function) 2)                 (= (list-length function) 2)
1074                 (eq (first function) 'function)                 (eq (first function) 'function)
# Line 1066  Line 1087 
1087    
1088  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
1089  ;;;  ;;;
1090  (define-setf-method ldb (bytespec place &environment env)  (define-setf-expander ldb (bytespec place &environment env)
1091    "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
1092    acceptable to SETF.  Replaces the specified byte of the number in this    acceptable to SETF.  Replaces the specified byte of the number in this
1093    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 1116 
1116                    `(ldb ,btemp ,getter))))))                    `(ldb ,btemp ,getter))))))
1117    
1118    
1119  (define-setf-method mask-field (bytespec place &environment env)  (define-setf-expander mask-field (bytespec place &environment env)
1120    "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
1121    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
1122    with bits from the corresponding position in the new value."    with bits from the corresponding position in the new value."
# Line 1112  Line 1133 
1133                `(mask-field ,btemp ,getter)))))                `(mask-field ,btemp ,getter)))))
1134    
1135    
1136  (define-setf-method the (type place &environment env)  (define-setf-expander the (type place &environment env)
1137    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1138                         (get-setf-method place env)                         (get-setf-method place env)
1139        (values dummies        (values dummies
# Line 1121  Line 1142 
1142                (subst `(the ,type ,(car newval)) (car newval) setter)                (subst `(the ,type ,(car newval)) (car newval) setter)
1143                `(the ,type ,getter))))                `(the ,type ,getter))))
1144    
1145    (define-setf-expander values (&rest places &environment env)
1146      (collect ((setters) (getters))
1147        (let ((all-dummies '())
1148              (all-vals '())
1149              (newvals '()))
1150          (dolist (place places)
1151            (multiple-value-bind (dummies vals newval setter getter)
1152                (get-setf-expansion place env)
1153              (setf all-dummies (append all-dummies dummies))
1154              (setf all-vals (append all-vals vals))
1155              (setf newvals (append newvals newval))
1156              (setters setter)
1157              (getters getter)))
1158          (values all-dummies all-vals newvals
1159                  `(values ,@(setters)) `(values ,@(getters))))))
1160    
1161    
1162  ;;;; CASE, TYPECASE, & Friends.  ;;;; CASE, TYPECASE, & Friends.
1163    
# Line 1392  Line 1429 
1429  (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))
1430    "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
1431    executes the body.  See manual for details."    executes the body.  See manual for details."
1432    `(let ((,var    ;; The once-only inhibits compiler note for unreachable code when 'end' is true.
1433            ,(cond ((null end)    (once-only ((string string))
1434                    `(make-string-input-stream ,string ,(or start 0)))      `(let ((,var
1435                   ((symbolp end)              ,(cond ((null end)
1436                    `(if ,end                      `(make-string-input-stream ,string ,(or start 0)))
1437                         (make-string-input-stream ,string ,(or start 0) ,end)                     ((symbolp end)
1438                       (make-string-input-stream ,string ,(or start 0))))                      `(if ,end
1439                   (t                           (make-string-input-stream ,string ,(or start 0) ,end)
1440                    `(make-string-input-stream ,string ,(or start 0) ,end)))))                           (make-string-input-stream ,string ,(or start 0))))
1441       ,@decls                     (t
1442       (unwind-protect                      `(make-string-input-stream ,string ,(or start 0) ,end)))))
1443         (progn ,@forms)         ,@decls
1444         (close ,var)         (unwind-protect
1445         ,@(if index `((setf ,index (string-input-stream-current ,var)))))))             (progn ,@forms)
1446             (close ,var)
1447             ,@(if index `((setf ,index (string-input-stream-current ,var))))))))
1448    
1449    
1450  (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 1505 
1505    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
1506    specified Init form.  On subsequent iterations, the Vars are assigned the    specified Init form.  On subsequent iterations, the Vars are assigned the
1507    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
1508    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
1509    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
1510    named NIL is established around the entire expansion, allowing RETURN to be    named NIL is established around the entire expansion, allowing RETURN to be
1511    used as an laternate exit mechanism."    used as an laternate exit mechanism."
# Line 1480  Line 1519 
1519    value of the specified Init form.  On subsequent iterations, the Vars are    value of the specified Init form.  On subsequent iterations, the Vars are
1520    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
1521    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,
1522    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
1523    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,
1524    allowing RETURN to be used as an laternate exit mechanism."    allowing RETURN to be used as an laternate exit mechanism."
1525    (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))    (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))
# Line 1488  Line 1527 
1527    
1528  ;;;; Miscellaneous macros:  ;;;; Miscellaneous macros:
1529    
 (defmacro locally (&rest forms)  
   "A form providing a container for locally-scoped variables."  
   `(let () ,@forms))  
   
1530  (defmacro psetq (&rest pairs)  (defmacro psetq (&rest pairs)
1531    (do ((lets nil)    (do ((lets nil)
1532         (setqs nil)         (setqs nil)
1533         (pairs pairs (cddr pairs)))         (pairs pairs (cddr pairs)))
1534        ((atom (cdr pairs))        ((atom (cdr pairs))
1535         `(let ,(nreverse lets) (setq ,@(nreverse setqs))))         `(let ,(nreverse lets) (setq ,@(nreverse setqs)) nil))
1536      (let ((gen (gensym)))      (let ((gen (gensym)))
1537        (push `(,gen ,(cadr pairs)) lets)        (push `(,gen ,(cadr pairs)) lets)
1538        (push (car pairs) setqs)        (push (car pairs) setqs)

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

  ViewVC Help
Powered by ViewVC 1.1.5