/[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.10 by pw, Sat Mar 23 18:50:05 2002 UTC
# Line 24  Line 24 
24            get-setf-expansion define-setf-expander            get-setf-expansion define-setf-expander
25            define-modify-macro destructuring-bind nth-value            define-modify-macro destructuring-bind nth-value
26            otherwise ; Sacred to CASE and related macros.            otherwise ; Sacred to CASE and related macros.
27            define-compiler-macro            define-compiler-macro))
           ;; CLtL1 versions:  
           define-setf-method get-setf-method get-setf-method-multiple-value))  
28    
29  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
30  (export '(do-anonymous collect iterate))  (export '(do-anonymous collect iterate))
# Line 57  Line 55 
55        (let ((form (car tail)))        (let ((form (car tail)))
56          (cond ((and (stringp form) (cdr tail))          (cond ((and (stringp form) (cdr tail))
57                 (if doc-string-allowed                 (if doc-string-allowed
58                     (setq doc form)                     (setq doc form
59                             ;; Only one doc string is allowed.
60                             doc-string-allowed nil)
61                     (return (values tail (nreverse decls) doc))))                     (return (values tail (nreverse decls) doc))))
62                ((not (and (consp form) (symbolp (car form))))                ((not (and (consp form) (symbolp (car form))))
63                 (return (values tail (nreverse decls) doc)))                 (return (values tail (nreverse decls) doc)))
# Line 85  Line 85 
85                      ,@local-decs                      ,@local-decs
86                      (block ,name                      (block ,name
87                        ,body))))                        ,body))))
88          `(c::%defmacro ',name #',def ',lambda-list ,doc)))))          `(progn
89               (eval-when (:compile-toplevel)
90                 (c::do-macro-compile-time ',name #',def))
91               (eval-when (:load-toplevel :execute)
92                 (c::%defmacro ',name #',def ',lambda-list ,doc)))))))
93    
94    
95  ;;; %Defmacro, %%Defmacro  --  Internal  ;;; %Defmacro, %%Defmacro  --  Internal
# Line 128  Line 132 
132                      ,@local-decs                      ,@local-decs
133                      (block ,name                      (block ,name
134                        ,body))))                        ,body))))
135          `(c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))          `(progn
136               (eval-when (:compile-toplevel)
137                 (c::do-compiler-macro-compile-time ',name #',def))
138               (eval-when (:load-toplevel :execute)
139                 (c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))))
140    
141    
142  (defun c::%define-compiler-macro (name definition lambda-list doc)  (defun c::%define-compiler-macro (name definition lambda-list doc)
143    (assert (eval:interpreted-function-p definition))    (assert (eval:interpreted-function-p definition))
# Line 145  Line 154 
154    
155    
156    
157    ;;;; DEFINE-SYMBOL-MACRO
158    
159    ;;; define-symbol-macro  --  Public
160    ;;;
161    (defmacro define-symbol-macro (name expansion)
162      `(eval-when (compile load eval)
163         (%define-symbol-macro ',name ',expansion)))
164    ;;;
165    (defun %define-symbol-macro (name expansion)
166      (unless (symbolp name)
167        (error 'simple-type-error :datum name :expected-type 'symbol
168               :format-control "Symbol macro name is not a symbol: ~S."
169               :format-arguments (list name)))
170      (ecase (info variable kind name)
171        ((:macro :global nil)
172         (setf (info variable kind name) :macro)
173         (setf (info variable macro-expansion name) expansion))
174        (:special
175         (error 'simple-program-error
176                :format-control "Symbol macro name already declared special: ~S."
177                :format-arguments (list name)))
178        (:constant
179         (error 'simple-program-error
180                :format-control "Symbol macro name already declared constant: ~S."
181                :format-arguments (list name))))
182      name)
183    
184    
185  ;;; DEFTYPE is a lot like DEFMACRO.  ;;; DEFTYPE is a lot like DEFMACRO.
186    
187  (defmacro deftype (name arglist &body body)  (defmacro deftype (name arglist &body body)
# Line 193  Line 230 
230  (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.")
231    
232  (defmacro define-setf-expander (access-fn lambda-list &body body)  (defmacro define-setf-expander (access-fn lambda-list &body body)
233    "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body    "Syntax like DEFMACRO, but creates a Setf-Expansion generator.  The body
234    must be a form that returns the five magical values."    must be a form that returns the five magical values."
235    (unless (symbolp access-fn)    (unless (symbolp access-fn)
236      (error "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD."      (error "~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER."
237             access-fn))             access-fn))
238    
239    (let ((whole (gensym "WHOLE-"))    (let ((whole (gensym "WHOLE-"))
240          (environment (gensym "ENV-")))          (environment (gensym "ENV-")))
241      (multiple-value-bind (body local-decs doc)      (multiple-value-bind (body local-decs doc)
242                           (parse-defmacro lambda-list whole body access-fn                           (parse-defmacro lambda-list whole body access-fn
243                                           'define-setf-method                                           'define-setf-expander
244                                           :environment environment)                                           :environment environment)
245        `(eval-when (load compile eval)        `(eval-when (load compile eval)
246           (%define-setf-macro           (%define-setf-macro
# Line 307  Line 344 
344    value is constant and may be compiled into code.  If the variable already has    value is constant and may be compiled into code.  If the variable already has
345    a value, and this is not equal to the init, an error is signalled.  The third    a value, and this is not equal to the init, an error is signalled.  The third
346    argument is an optional documentation string for the variable."    argument is an optional documentation string for the variable."
347    `(c::%defconstant ',var ,val ',doc))    `(progn
348         (eval-when (:compile-toplevel)
349           (c::do-defconstant-compile-time ',var ,val ',doc))
350         (eval-when (:load-toplevel :execute)
351           (c::%%defconstant ',var ,val ',doc))))
352    
353  ;;; %Defconstant, %%Defconstant  --  Internal  ;;; %Defconstant, %%Defconstant  --  Internal
354  ;;;  ;;;
# Line 337  Line 378 
378    value, the old value is not clobbered.  The third argument is an optional    value, the old value is not clobbered.  The third argument is an optional
379    documentation string for the variable."    documentation string for the variable."
380    `(progn    `(progn
381      (proclaim '(special ,var))      (declaim (special ,var))
382       ,@(when valp       ,@(when valp
383           `((unless (boundp ',var)           `((unless (boundp ',var)
384               (setq ,var ,val))))               (setq ,var ,val))))
# Line 351  Line 392 
392    variable special and sets its value to VAL.  The third argument is    variable special and sets its value to VAL.  The third argument is
393    an optional documentation string for the parameter."    an optional documentation string for the parameter."
394    `(progn    `(progn
395      (proclaim '(special ,var))      (declaim (special ,var))
396      (setq ,var ,val)      (setq ,var ,val)
397      ,@(when docp      ,@(when docp
398          `((setf (documentation ',var 'variable) ',doc)))          `((setf (documentation ',var 'variable) ',doc)))
# Line 497  Line 538 
538             (declare (ignore ,@dummy-list))             (declare (ignore ,@dummy-list))
539             ,keeper))             ,keeper))
540        (once-only ((n n))        (once-only ((n n))
541          `(case (the fixnum ,n)          `(case (the (values fixnum &rest t) ,n)
542             (0 (nth-value 0 ,form))             (0 (nth-value 0 ,form))
543             (1 (nth-value 1 ,form))             (1 (nth-value 1 ,form))
544             (2 (nth-value 2 ,form))             (2 (nth-value 2 ,form))
545             (T (nth (the fixnum ,n) (multiple-value-list ,form)))))))             (T (nth (the (values fixnum &rest t) ,n)
546                            (multiple-value-list ,form)))))))
547    
548    
549  ;;;; SETF and friends.  ;;;; SETF and friends.
# Line 519  Line 561 
561  ;;; new-value arg at the end.  ;;; new-value arg at the end.
562  ;;;  ;;;
563  ;;; 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
564  ;;; 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
565  ;;; 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
566  ;;; 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,
567  ;;; and an accessing function.  ;;; and an accessing function.
# Line 824  Line 866 
866                `(let* ,(nreverse let-list)                `(let* ,(nreverse let-list)
867                   ,setter)))))))                   ,setter)))))))
868    
   
   
869  (defmacro push (obj place &environment env)  (defmacro push (obj place &environment env)
870    "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
871    the list, returning the modified list."    the list, returning the modified list.  OBJ is evaluated before PLACE."
872    (if (symbolp place)    (if (symbolp place)
873        `(setq ,place (cons ,obj ,place))        `(setq ,place (cons ,obj ,place))
874        (multiple-value-bind (dummies vals newval setter getter)        (multiple-value-bind (dummies vals newval setter getter)
875                             (get-setf-method place env)            (get-setf-method place env)
876          (do* ((d dummies (cdr d))          (let ((g (gensym)))
877                (v vals (cdr v))            `(let* ((,g ,obj)
878                (let-list nil))                    ,@(mapcar #'list dummies vals)
879               ((null d)                    (,(car newval) (cons ,g ,getter)))
880                (push (list (car newval) `(cons ,obj ,getter))              ,setter)))))
                     let-list)  
               `(let* ,(nreverse let-list)  
                  ,setter))  
           (push (list (car d) (car v)) let-list)))))  
   
881    
882  (defmacro pushnew (obj place &rest keys &environment env)  (defmacro pushnew (obj place &rest keys &environment env)
883    "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 1017 
1017  (defsetf symbol-value set)  (defsetf symbol-value set)
1018  (defsetf symbol-function fset)  (defsetf symbol-function fset)
1019  (defsetf symbol-plist %set-symbol-plist)  (defsetf symbol-plist %set-symbol-plist)
 (defsetf documentation %set-documentation)  
1020  (defsetf nth %setnth)  (defsetf nth %setnth)
1021  (defsetf fill-pointer %set-fill-pointer)  (defsetf fill-pointer %set-fill-pointer)
1022  (defsetf search-list %set-search-list)  (defsetf search-list %set-search-list)
# Line 993  Line 1027 
1027  (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)  (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
1028  (defsetf sap-ref-32 %set-sap-ref-32)  (defsetf sap-ref-32 %set-sap-ref-32)
1029  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
 #+alpha  
1030  (defsetf sap-ref-64 %set-sap-ref-64)  (defsetf sap-ref-64 %set-sap-ref-64)
 #+alpha  
1031  (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)  (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
1032  (defsetf sap-ref-sap %set-sap-ref-sap)  (defsetf sap-ref-sap %set-sap-ref-sap)
1033  (defsetf sap-ref-single %set-sap-ref-single)  (defsetf sap-ref-single %set-sap-ref-single)
1034  (defsetf sap-ref-double %set-sap-ref-double)  (defsetf sap-ref-double %set-sap-ref-double)
1035    #+long-float
1036    (defsetf sap-ref-long %set-sap-ref-long)
1037    
1038  (define-setf-method getf (place prop &optional default &environment env)  (define-setf-expander getf (place prop &optional default &environment env)
1039    (multiple-value-bind (temps values stores set get)    (multiple-value-bind (temps values stores set get)
1040                         (get-setf-method place env)                         (get-setf-method place env)
1041      (let ((newval (gensym))      (let ((newval (gensym))
# Line 1015  Line 1049 
1049                   ,newval)                   ,newval)
1050                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
1051    
1052  (define-setf-method get (symbol prop &optional default)  (define-setf-expander get (symbol prop &optional default)
1053    (let ((symbol-temp (gensym))    (let ((symbol-temp (gensym))
1054          (prop-temp (gensym))          (prop-temp (gensym))
1055          (def-temp (gensym))          (def-temp (gensym))
# Line 1026  Line 1060 
1060              `(%put ,symbol-temp ,prop-temp ,newval)              `(%put ,symbol-temp ,prop-temp ,newval)
1061              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
1062    
1063  (define-setf-method gethash (key hashtable &optional default)  (define-setf-expander gethash (key hashtable &optional default)
1064    (let ((key-temp (gensym))    (let ((key-temp (gensym))
1065          (hashtable-temp (gensym))          (hashtable-temp (gensym))
1066          (default-temp (gensym))          (default-temp (gensym))
# Line 1047  Line 1081 
1081  ;;; 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
1082  ;;; APPLY of ther SETF function, which ought to exist.  ;;; APPLY of ther SETF function, which ought to exist.
1083  ;;;  ;;;
1084  (define-setf-method apply (function &rest args)  (define-setf-expander apply (function &rest args)
1085    (unless (and (listp function)    (unless (and (listp function)
1086                 (= (list-length function) 2)                 (= (list-length function) 2)
1087                 (eq (first function) 'function)                 (eq (first function) 'function)
# Line 1066  Line 1100 
1100    
1101  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
1102  ;;;  ;;;
1103  (define-setf-method ldb (bytespec place &environment env)  (define-setf-expander ldb (bytespec place &environment env)
1104    "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
1105    acceptable to SETF.  Replaces the specified byte of the number in this    acceptable to SETF.  Replaces the specified byte of the number in this
1106    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 1129 
1129                    `(ldb ,btemp ,getter))))))                    `(ldb ,btemp ,getter))))))
1130    
1131    
1132  (define-setf-method mask-field (bytespec place &environment env)  (define-setf-expander mask-field (bytespec place &environment env)
1133    "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
1134    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
1135    with bits from the corresponding position in the new value."    with bits from the corresponding position in the new value."
# Line 1112  Line 1146 
1146                `(mask-field ,btemp ,getter)))))                `(mask-field ,btemp ,getter)))))
1147    
1148    
1149  (define-setf-method the (type place &environment env)  (define-setf-expander the (type place &environment env)
1150    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1151                         (get-setf-method place env)                         (get-setf-method place env)
1152        (values dummies        (values dummies
# Line 1121  Line 1155 
1155                (subst `(the ,type ,(car newval)) (car newval) setter)                (subst `(the ,type ,(car newval)) (car newval) setter)
1156                `(the ,type ,getter))))                `(the ,type ,getter))))
1157    
1158    (define-setf-expander values (&rest places &environment env)
1159      (collect ((setters) (getters))
1160        (let ((all-dummies '())
1161              (all-vals '())
1162              (newvals '()))
1163          (dolist (place places)
1164            (multiple-value-bind (dummies vals newval setter getter)
1165                (get-setf-expansion place env)
1166              (setf all-dummies (append all-dummies dummies))
1167              (setf all-vals (append all-vals vals))
1168              (setf newvals (append newvals newval))
1169              (setters setter)
1170              (getters getter)))
1171          (values all-dummies all-vals newvals
1172                  `(values ,@(setters)) `(values ,@(getters))))))
1173    
1174    
1175  ;;;; CASE, TYPECASE, & Friends.  ;;;; CASE, TYPECASE, & Friends.
1176    
# Line 1392  Line 1442 
1442  (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))
1443    "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
1444    executes the body.  See manual for details."    executes the body.  See manual for details."
1445    `(let ((,var    ;; The once-only inhibits compiler note for unreachable code when 'end' is true.
1446            ,(cond ((null end)    (once-only ((string string))
1447                    `(make-string-input-stream ,string ,(or start 0)))      `(let ((,var
1448                   ((symbolp end)              ,(cond ((null end)
1449                    `(if ,end                      `(make-string-input-stream ,string ,(or start 0)))
1450                         (make-string-input-stream ,string ,(or start 0) ,end)                     ((symbolp end)
1451                       (make-string-input-stream ,string ,(or start 0))))                      `(if ,end
1452                   (t                           (make-string-input-stream ,string ,(or start 0) ,end)
1453                    `(make-string-input-stream ,string ,(or start 0) ,end)))))                           (make-string-input-stream ,string ,(or start 0))))
1454       ,@decls                     (t
1455       (unwind-protect                      `(make-string-input-stream ,string ,(or start 0) ,end)))))
1456         (progn ,@forms)         ,@decls
1457         (close ,var)         (unwind-protect
1458         ,@(if index `((setf ,index (string-input-stream-current ,var)))))))             (progn ,@forms)
1459             (close ,var)
1460             ,@(if index `((setf ,index (string-input-stream-current ,var))))))))
1461    
1462    
1463  (defmacro with-output-to-string ((var &optional string) &body (forms decls))  (defmacro with-output-to-string ((var &optional string) &body (forms decls))
# Line 1432  Line 1484 
1484    (cond ((numberp count)    (cond ((numberp count)
1485           `(do ((,var 0 (1+ ,var)))           `(do ((,var 0 (1+ ,var)))
1486                ((>= ,var ,count) ,result)                ((>= ,var ,count) ,result)
1487              (declare (type unsigned-byte ,var))              (declare (type (integer 0 ,count) ,var))
1488              ,@body))              ,@body))
1489          (t (let ((v1 (gensym)))          (t (let ((v1 (gensym)))
1490               `(do ((,var 0 (1+ ,var)) (,v1 ,count))               `(do ((,var 0 (1+ ,var)) (,v1 ,count))
# Line 1466  Line 1518 
1518    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
1519    specified Init form.  On subsequent iterations, the Vars are assigned the    specified Init form.  On subsequent iterations, the Vars are assigned the
1520    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
1521    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
1522    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
1523    named NIL is established around the entire expansion, allowing RETURN to be    named NIL is established around the entire expansion, allowing RETURN to be
1524    used as an laternate exit mechanism."    used as an laternate exit mechanism."
# Line 1480  Line 1532 
1532    value of the specified Init form.  On subsequent iterations, the Vars are    value of the specified Init form.  On subsequent iterations, the Vars are
1533    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
1534    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,
1535    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
1536    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,
1537    allowing RETURN to be used as an laternate exit mechanism."    allowing RETURN to be used as an laternate exit mechanism."
1538    (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 1540 
1540    
1541  ;;;; Miscellaneous macros:  ;;;; Miscellaneous macros:
1542    
 (defmacro locally (&rest forms)  
   "A form providing a container for locally-scoped variables."  
   `(let () ,@forms))  
   
1543  (defmacro psetq (&rest pairs)  (defmacro psetq (&rest pairs)
1544    (do ((lets nil)    (do ((lets nil)
1545         (setqs nil)         (setqs nil)
1546         (pairs pairs (cddr pairs)))         (pairs pairs (cddr pairs)))
1547        ((atom (cdr pairs))        ((atom (cdr pairs))
1548         `(let ,(nreverse lets) (setq ,@(nreverse setqs))))         `(let ,(nreverse lets) (setq ,@(nreverse setqs)) nil))
1549      (let ((gen (gensym)))      (let ((gen (gensym)))
1550        (push `(,gen ,(cadr pairs)) lets)        (push `(,gen ,(cadr pairs)) lets)
1551        (push (car pairs) setqs)        (push (car pairs) setqs)

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

  ViewVC Help
Powered by ViewVC 1.1.5