From dc84ceb894fdbe315f82dd8336f3ba894435a669 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 9 Dec 2002 11:54:48 +0000 Subject: [PATCH] 0.7.10.14: Fix bug 219 (ANSIfying DEFINE-COMPILER-MACRO in non-toplevel contexts): ... remove IR1 implementation, converting to a macro- and EVAL-WHEN-based implementation ... increment fasl file version number also, while I'm at it, set the COMPILER-MACRO-FUNCTION name to something useful for use in the debugger; apply similar fix for the MACRO-FUNCTION of a macro: ... move DEBUG-NAMIFY to SB-INT and export it. --- BUGS | 17 ----------- NEWS | 5 +++- package-data-list.lisp-expr | 1 + src/code/defmacro.lisp | 27 +++++++++++------- src/code/early-fasl.lisp | 4 ++- src/code/macros.lisp | 56 ++++++++++++++++++++++++++++--------- src/compiler/early-c.lisp | 16 +++++++++++ src/compiler/ir1-translators.lisp | 50 ++++++++------------------------- src/compiler/ir1report.lisp | 16 ----------- tests/compiler.impure.lisp | 35 +++++++++++++++++++++++ version.lisp-expr | 2 +- 11 files changed, 131 insertions(+), 98 deletions(-) diff --git a/BUGS b/BUGS index 3c403d6..cc65d1f 100644 --- a/BUGS +++ b/BUGS @@ -1191,23 +1191,6 @@ WORKAROUND: (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 diff --git a/NEWS b/NEWS index a46cee3..384db56 100644 --- a/NEWS +++ b/NEWS @@ -1442,6 +1442,8 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10: 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 @@ -1453,7 +1455,8 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10: 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a7828a0e..69632eb 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -858,6 +858,7 @@ retained, possibly temporariliy, because it might be used internally." "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 diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index 2bc701b..ac2702f 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -30,20 +30,24 @@ :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 @@ -75,14 +79,17 @@ (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) diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 2f63d5c..2e8baca 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -42,7 +42,7 @@ ;;; 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*. @@ -73,6 +73,8 @@ ;;; 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*)) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 2574cac..b4453d1 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -124,6 +124,10 @@ ;; 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) @@ -132,19 +136,45 @@ (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))) ;;;; CASE, TYPECASE, and friends diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index e2c677a..1faa6f8 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -165,3 +165,19 @@ 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)))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index e14ed30..398e692 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -1063,20 +1063,17 @@ ;;;; 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*) @@ -1084,28 +1081,3 @@ (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)))) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 3a81b98..d12c204 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -192,22 +192,6 @@ (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 diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 9a8458c..a19fb7e 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -636,6 +636,41 @@ BUG 48c, not yet fixed: (+ y 5)) (assert (= (call-inlined 3) 6)) +;;; 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))) + ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/version.lisp-expr b/version.lisp-expr index 007c5bc..76fb233 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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" -- 1.7.10.4