/[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.32 by wlott, Thu Apr 2 02:48:54 1992 UTC revision 1.33 by wlott, Sat Apr 4 01:03:36 1992 UTC
# Line 25  Line 25 
25            locally etypecase ctypecase ecase ccase            locally etypecase ctypecase ecase ccase
26            get-setf-method get-setf-method-multiple-value            get-setf-method get-setf-method-multiple-value
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))
30    
31  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
32  (export '(do-anonymous collect iterate))  (export '(do-anonymous collect iterate))
# Line 111  Line 112 
112    (setf (documentation name 'function) doc)    (setf (documentation name 'function) doc)
113    name)    name)
114    
115    
116    
117    ;;;; DEFINE-COMPILER-MACRO
118    
119    (defmacro define-compiler-macro (name lambda-list &body body)
120      "Define a compiler-macro for NAME."
121      (let ((whole (gensym "WHOLE-"))
122            (environment (gensym "ENV-")))
123        (multiple-value-bind
124            (body local-decs doc)
125            (parse-defmacro lambda-list whole body name 'define-compiler-macro
126                            :environment environment)
127          (let ((def `(lambda (,whole ,environment)
128                        ,@local-decs
129                        (block ,name
130                          ,body))))
131            `(c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))
132    
133    (defun c::%define-compiler-macro (name definition lambda-list doc)
134      (assert (eval:interpreted-function-p definition))
135      (setf (eval:interpreted-function-name definition)
136            (let ((*print-case* :upcase))
137              (format nil "DEFINE-COMPILER-MACRO ~S" name)))
138      (setf (eval:interpreted-function-arglist definition) lambda-list)
139      (c::%%define-compiler-macro name definition doc))
140    ;;;
141    (defun c::%%define-compiler-macro (name definition doc)
142      (setf (compiler-macro-function name) definition)
143      (setf (documentation name 'compiler-macro) doc)
144      name)
145    
146    
147    
148  ;;; DEFTYPE is a lot like DEFMACRO.  ;;; DEFTYPE is a lot like DEFMACRO.
149    

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.33

  ViewVC Help
Powered by ViewVC 1.1.5