(defun test (x y) (the (values integer) (truncate x y)))
(test 10 4) => 2
-219: "DEFINE-COMPILER-MACRO in non-toplevel contexts evaluated at compile-time"
- In sbcl-0.7.9:
-
- * (defun foo (x)
- (when x
- (define-compiler-macro bar (&whole whole)
- (declare (ignore whole))
- (print "expanding compiler macro")
- 1)))
- FOO
- * (defun baz (x) (bar))
- [ ... ]
- "expanding compiler macro"
- BAZ
- * (baz t)
- 1
-
220:
Sbcl 0.7.9 fails to compile
to Lutz Euler)
* support for the upcoming FreeBSD-5.0 release has been included.
(thanks to Dag-Erling Smorgrav)
+ * fixed bug 219: DEFINE-COMPILER-MACRO no longer has compile-time
+ effect when it is not in a toplevel context.
* fixed some more bugs revealed by Paul Dietz' test suite:
** As required by ANSI, LOOP now disallows anonymous collection
clauses such as COLLECT I in conjunction with aggregate boolean
conditional loop clause;
** FILE-STREAM now names the class previously known as FD-STREAM;
* incremented fasl file version number, because of the incompatible
- change to the DEFSTRUCT-DESCRIPTION structure.
+ change to the DEFSTRUCT-DESCRIPTION structure, and again because
+ of the new implementation of DEFINE-COMPILER-MACRO.
planned incompatible changes in 0.7.x:
* (not done yet, but planned:) When the profiling interface settles
"LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P"
"POSITIVE-PRIMEP"
"EVAL-IN-LEXENV"
+ "DEBUG-NAMIFY"
;; These could be moved back into SB!EXT if someone has
;; compelling reasons, but hopefully we can get by
:environment environment)
(let ((def `(lambda (,whole ,environment)
,@local-decs
- (block ,name
- ,new-body))))
+ (block ,name
+ ,new-body)))
+ ;; if we want to move over to list-style names
+ ;; [e.g. (DEFMACRO FOO), maybe to support some XREF-like
+ ;; functionality] here might be a good place to start.
+ (debug-name (debug-namify "DEFMACRO ~S" name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%defmacro ',name #',def ',lambda-list ,doc)))))))
+ (sb!c::%defmacro ',name #',def ',lambda-list ,doc ,debug-name)))))))
(macrolet
- ((def (times set-args-p)
+ ((def (times set-p)
`(eval-when (,@times)
- (defun sb!c::%defmacro (name definition lambda-list doc)
+ (defun sb!c::%defmacro (name definition lambda-list doc debug-name)
;; old note (ca. 1985, maybe:-): "Eventually %%DEFMACRO
;; should deal with clearing old compiler information for
;; the functional value."
- ,@(unless set-args-p
- '((declare (ignore lambda-list))))
+ ,@(unless set-p
+ '((declare (ignore lambda-list debug-name))))
(ecase (info :function :kind name)
((nil))
(:function
(style-warn "redefining ~S in DEFMACRO" name))
(setf (sb!xc:macro-function name) definition
(fdocumentation name 'function) doc)
- ,(when set-args-p
+ ,(when set-p
`(case (widetag-of definition)
(#.sb!vm:closure-header-widetag
(setf (%simple-fun-arglist (%closure-fun definition))
- lambda-list))
+ lambda-list
+ (%simple-fun-name (%closure-fun definition))
+ debug-name))
((#.sb!vm:simple-fun-header-widetag
#.sb!vm:closure-fun-header-widetag)
- (setf (%simple-fun-arglist definition) lambda-list))))
+ (setf (%simple-fun-arglist definition) lambda-list
+ (%simple-fun-name definition) debug-name))))
name))))
(progn
(def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
;;; versions which break binary compatibility. But it certainly should
;;; be incremented for release versions which break binary
;;; compatibility.
-(def!constant +fasl-file-version+ 36)
+(def!constant +fasl-file-version+ 37)
;;; (record of versions before 0.7.0 deleted in 0.7.1.41)
;;; 23 = sbcl-0.7.0.1 deleted no-longer-used EVAL-STACK stuff,
;;; causing changes in *STATIC-SYMBOLS*.
;;; for STANDARD-OBJECT
;;; 36: (2002-12-04) DEFSTRUCT-DESCRIPTION layout changed to accommodate
;;; correct behaviour of colliding accessors
+;;; 37: (2002-12-09) changed implementation of DEFINE-COMPILER-MACRO,
+;;; deleting %%DEFINE-COMPILER-MACRO
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
;; spec, so at least we can warn him...
(sb!c::compiler-style-warn
"defining compiler macro of (SETF ...), which will not be expanded"))
+ (when (and (symbolp name) (special-operator-p name))
+ (error 'simple-program-error
+ :format-control "cannot define a compiler-macro for a special operator: ~S"
+ :format-arguments (list name)))
(let ((whole (gensym "WHOLE-"))
(environment (gensym "ENV-")))
(multiple-value-bind (body local-decs doc)
(let ((def `(lambda (,whole ,environment)
,@local-decs
(block ,(fun-name-block-name name)
- ,body))))
- `(sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))
-(defun sb!c::%define-compiler-macro (name definition lambda-list doc)
- (declare (ignore lambda-list))
- (sb!c::%%define-compiler-macro name definition doc))
-(defun sb!c::%%define-compiler-macro (name definition doc)
- (setf (sb!xc:compiler-macro-function name) definition)
- ;; FIXME: Add support for (SETF FDOCUMENTATION) when object is a list
- ;; and type is COMPILER-MACRO. (Until then, we have to discard any
- ;; compiler macro documentation for (SETF FOO).)
- (unless (listp name)
- (setf (fdocumentation name 'compiler-macro) doc))
- name)
+ ,body)))
+ (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc ,debug-name))))))
+
+;;; FIXME: This will look remarkably similar to those who have already
+;;; seen the code for %DEFMACRO in src/code/defmacro.lisp. Various
+;;; bits of logic should be shared (notably arglist setting).
+(macrolet
+ ((def (times set-p)
+ `(eval-when (,@times)
+ (defun sb!c::%define-compiler-macro
+ (name definition lambda-list doc debug-name)
+ ,@(unless set-p
+ '((declare (ignore lambda-list debug-name))))
+ ;; FIXME: warn about incompatible lambda list with
+ ;; respect to parent function?
+ (setf (sb!xc:compiler-macro-function name) definition)
+ ;; FIXME: Add support for (SETF FDOCUMENTATION) when
+ ;; object is a list and type is COMPILER-MACRO. (Until
+ ;; then, we have to discard any compiler macro
+ ;; documentation for (SETF FOO).)
+ (unless (listp name)
+ (setf (fdocumentation name 'compiler-macro) doc))
+ ,(when set-p
+ `(case (widetag-of definition)
+ (#.sb!vm:closure-header-widetag
+ (setf (%simple-fun-arglist (%closure-fun definition))
+ lambda-list
+ (%simple-fun-name (%closure-fun definition))
+ debug-name))
+ ((#.sb!vm:simple-fun-header-widetag
+ #.sb!vm:closure-fun-header-widetag)
+ (setf (%simple-fun-arglist definition) lambda-list
+ (%simple-fun-name definition) debug-name))))
+ name))))
+ (progn
+ (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
+ (def (:compile-toplevel) nil)))
\f
;;;; CASE, TYPECASE, and friends
dynamic binding, even though the symbol name follows the usual naming~@
convention (names like *FOO*) for special variables" symbol))
(values))
+
+;;; shorthand for creating debug names from source names or other
+;;; stems, e.g.
+;;; (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME)
+;;; (DEBUG-NAMIFY "top level form ~S" FORM)
+;;;
+;;; FIXME: This function seems to have a lot in common with
+;;; STRINGIFY-FORM, and perhaps there's some way to merge the two
+;;; functions.
+(defun debug-namify (format-string &rest format-arguments)
+ (with-standard-io-syntax
+ (let ((*print-readably* nil)
+ (*package* *cl-package*)
+ (*print-length* 3)
+ (*print-level* 2))
+ (apply #'format nil format-string format-arguments))))
\f
;;;; interface to defining macros
-;;;; FIXME:
-;;;; classic CMU CL comment:
-;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions
-;;;; so that we get a chance to see what is going on. We define
-;;;; IR1 translators for these functions which look at the
-;;;; definition and then generate a call to the %%DEFxxx function.
-;;;; Alas, this implementation doesn't do the right thing for
-;;;; non-toplevel uses of these forms, so this should probably
-;;;; be changed to use EVAL-WHEN instead.
-
-;;; Return a new source path with any stuff intervening between the
-;;; current path and the first form beginning with NAME stripped off.
-;;; This is used to hide the guts of DEFmumble macros to prevent
-;;; annoying error messages.
+;;; Old CMUCL comment:
+;;;
+;;; Return a new source path with any stuff intervening between the
+;;; current path and the first form beginning with NAME stripped
+;;; off. This is used to hide the guts of DEFmumble macros to
+;;; prevent annoying error messages.
+;;;
+;;; Now that we have implementations of DEFmumble macros in terms of
+;;; EVAL-WHEN, this function is no longer used. However, it might be
+;;; worth figuring out why it was used, and maybe doing analogous
+;;; munging to the functions created in the expanders for the macros.
(defun revert-source-path (name)
(do ((path *current-path* (cdr path)))
((null path) *current-path*)
(when (or (eq first name)
(eq first 'original-source-start))
(return path)))))
-
-(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
- start cont
- :kind :function)
- (let ((name (eval name))
- (def (second def))) ; We don't want to make a function just yet...
-
- (when (eq (info :function :kind name) :special-form)
- (compiler-error "attempt to define a compiler-macro for special form ~S"
- name))
-
- (setf (info :function :compiler-macro-function name)
- (coerce def 'function))
-
- (let* ((*current-path* (revert-source-path 'define-compiler-macro))
- (fun (ir1-convert-lambda def
- :debug-name (debug-namify
- "DEFINE-COMPILER-MACRO ~S"
- name))))
- (setf (functional-arg-documentation fun) (eval lambda-list))
-
- (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
-
- (when sb!xc:*compile-print*
- (compiler-mumble "~&; converted ~S~%" name))))
(format nil "~<~@; ~S~:>" (list form))
(prin1-to-string form)))))
-;;; shorthand for creating debug names from source names or other
-;;; stems, e.g.
-;;; (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME)
-;;; (DEBUG-NAMIFY "top level form ~S" FORM)
-;;;
-;;; FIXME: This function seems to have a lot in common with
-;;; STRINGIFY-FORM, and perhaps there's some way to merge the two
-;;; functions.
-(defun debug-namify (format-string &rest format-arguments)
- (with-standard-io-syntax
- (let ((*print-readably* nil)
- (*package* *cl-package*)
- (*print-length* 3)
- (*print-level* 2))
- (apply #'format nil format-string format-arguments))))
-
;;; shorthand for a repeated idiom in creating debug names
;;;
;;; the problem, part I: We want to create debug names that look like
(+ y 5))
(assert (= (call-inlined 3) 6))
\f
+;;; DEFINE-COMPILER-MACRO to work as expected, not via weird magical
+;;; IR1 pseudo-:COMPILE-TOPLEVEL handling
+(defvar *bug219-a-expanded-p* nil)
+(defun bug219-a (x)
+ (+ x 1))
+(define-compiler-macro bug219-a (&whole form y)
+ (setf *bug219-a-expanded-p* t)
+ (if (constantp y)
+ (+ (eval y) 2)
+ form))
+(defun bug219-a-aux ()
+ (bug219-a 2))
+(assert (= (bug219-a-aux)
+ (if *bug219-a-expanded-p* 4 3)))
+(defvar *bug219-a-temp* 3)
+(assert (= (bug219-a *bug219-a-temp*) 4))
+
+(defvar *bug219-b-expanded-p* nil)
+(defun bug219-b-aux1 (x)
+ (when x
+ (define-compiler-macro bug219-b (y)
+ (setf *bug219-b-expanded-p* t)
+ `(+ ,y 2))))
+(defun bug219-b-aux2 (z)
+ (bug219-b z))
+(assert (not *bug219-b-expanded-p*))
+(assert (raises-error? (bug219-b-aux2 1) undefined-function))
+(bug219-b-aux1 t)
+(defun bug219-b-aux2 (z)
+ (bug219-b z))
+(defun bug219-b (x)
+ x)
+(assert (= (bug219-b-aux2 1)
+ (if *bug219-b-expanded-p* 3 1)))
+\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.10.13"
+"0.7.10.14"
projects / sbcl.git / commitdiff