/[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.2.9 by dtc, Fri Oct 6 15:20:38 2000 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 221  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-EXPANDER."      (error "~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER."
# Line 335  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 365  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 379  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 1471  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))

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

  ViewVC Help
Powered by ViewVC 1.1.5