From c831b2828176641e93a45d3fd643e9f58cd44a3f Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Thu, 10 Oct 2002 07:16:14 +0000 Subject: [PATCH] 0.7.8.23: * Fixed bug 204: (EVAL-WHEN (:COMPILE-TOPLEVEL) ...) inside MACROLET. * Expanders, introduced by MACROLET, are defined in a restricted lexical environment. * SB-C:LEXENV-FIND works in any package. --- BUGS | 26 ++-- package-data-list.lisp-expr | 34 +++--- src/code/eval.lisp | 76 ++++++------ src/compiler/ir1-translators.lisp | 10 +- src/compiler/ir1util.lisp | 33 ++++- src/compiler/lexenv.lisp | 4 +- src/compiler/macros.lisp | 4 +- src/compiler/main.lisp | 243 ++++++++++++++++++++----------------- src/compiler/target-main.lisp | 26 ++-- tests/bug204-test.lisp | 10 ++ tests/compiler.impure.lisp | 38 ++++++ tests/compiler.pure.lisp | 8 ++ tests/symbol-macrolet-test.lisp | 6 + version.lisp-expr | 2 +- 14 files changed, 324 insertions(+), 196 deletions(-) create mode 100644 tests/bug204-test.lisp create mode 100644 tests/symbol-macrolet-test.lisp diff --git a/BUGS b/BUGS index c0b8f47..c664390 100644 --- a/BUGS +++ b/BUGS @@ -649,6 +649,12 @@ WORKAROUND: but actual specification quoted above says that the actual behavior is undefined. + (Since 0.7.8.23 macroexpanders are defined in a restricted version + of the lexical environment, containing no lexical variables and + functions, which seems to conform to ANSI and CLtL2, but signalling + a STYLE-WARNING for references to variables similar to locals might + be a good thing.) + 125: (as reported by Gabe Garza on cmucl-help 2001-09-21) (defvar *tmp* 3) @@ -1222,19 +1228,13 @@ WORKAROUND: This situation may appear during optimizing away degenerate cases of certain functions: see bugs 54, 192b. -204: - (EVAL-WHEN (:COMPILE-TOPLEVEL) ...) inside MACROLET evaluates its - argument in the null lexical environment. E.g. compiling file with - - (macrolet ((def (x) `(print ,x))) - (eval-when (:compile-toplevel) - (def 'hello))) - - causes - - debugger invoked on condition of type UNDEFINED-FUNCTION: - The function DEF is undefined. - +205: "environment issues in cross compiler" + (These bugs have no impact on user code, but should be fixed or + documented.) + a. Macroexpanders introduced with MACROLET are defined in the null + lexical environment. + b. The body of (EVAL-WHEN (:COMPILE-TOPLEVEL) ...) is evaluated in + the null lexical environment. DEFUNCT CATEGORIES OF BUGS IR1-#: diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 20b0950..a5d0e1e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -192,8 +192,9 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "*BACKEND-SUBFEATURES*" "*BACKEND-T-PRIMITIVE-TYPE*" - "*CODE-SEGMENT*" + "*CODE-SEGMENT*" "*COUNT-VOP-USAGES*" "*ELSEWHERE*" "*FREE-FUNS*" + "*LEXENV*" "*SETF-ASSUMED-FBOUNDP*" "*SUPPRESS-VALUES-DECLARATION*" @@ -209,12 +210,13 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "CHECK-FIXNUM" "CHECK-FUN" "CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32" "CLOSURE-INIT" "CLOSURE-REF" - "CODE-CONSTANT-REF" "CODE-CONSTANT-SET" + "CODE-CONSTANT-REF" "CODE-CONSTANT-SET" + "COMPILE-IN-LEXENV" "COMPILE-LAMBDA-FOR-DEFUN" "%COMPILER-DEFUN" "COMPILER-ERROR" "COMPONENT" "COMPONENT-HEADER-LENGTH" "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUN" - "COMPUTE-OLD-NFP" "COPY-MORE-ARG" + "COMPUTE-OLD-NFP" "COPY-MORE-ARG" "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN" "CURRENT-STACK-POINTER" "DEALLOC-ALIEN-STACK-SPACE" "DEALLOC-NUMBER-STACK-SPACE" "DEF-BOOLEAN-ATTRIBUTE" @@ -238,7 +240,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "IR2-PHYSENV-NUMBER-STACK-P" "KNOWN-CALL-LOCAL" "KNOWN-RETURN" "LAMBDA-INDEPENDENT-OF-LEXENV-P" - "LAMBDA-WITH-LEXENV" "LOCATION=" "LTN-ANNOTATE" + "LAMBDA-WITH-LEXENV" "LEXENV-FIND" + "LOCATION=" "LTN-ANNOTATE" "MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK" "MAKE-CLOSURE" "MAKE-CONSTANT-TN" "MAKE-FIXNUM" "MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN" @@ -574,7 +577,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; weak pointers and finalization "CANCEL-FINALIZATION" - "FINALIZE" + "FINALIZE" "HASH-TABLE-WEAK-P" "MAKE-WEAK-POINTER" "WEAK-POINTER" "WEAK-POINTER-P" "WEAK-POINTER-VALUE" @@ -678,7 +681,7 @@ retained, possibly temporariliy, because it might be used internally." ;; hash mixing operations "MIX" "MIXF" - + ;; I'm not convinced that FDEFINITIONs are the ideal ;; solution, so exposing ways to peek into the system ;; seems undesirable, since it makes it harder to get @@ -699,7 +702,7 @@ retained, possibly temporariliy, because it might be used internally." ;; stuff for hinting to the compiler "NAMED-LAMBDA" - + ;; other variations on DEFFOO stuff useful for bootstrapping ;; and cross-compiling "DEFMACRO-MUNDANELY" @@ -714,7 +717,7 @@ retained, possibly temporariliy, because it might be used internally." "FASTBIG-INCF-PCOUNTER-OR-FIXNUM" "INCF-PCOUNTER" "INCF-PCOUNTER-OR-FIXNUM" - "MAKE-PCOUNTER" + "MAKE-PCOUNTER" "PCOUNTER" "PCOUNTER->INTEGER" "PCOUNTER-OR-FIXNUM->INTEGER" @@ -724,7 +727,7 @@ retained, possibly temporariliy, because it might be used internally." ;; miscellaneous non-standard but handy user-level functions.. "ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ" "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE" - "SANE-PACKAGE" + "SANE-PACKAGE" "CYCLIC-LIST-P" "COMPOUND-OBJECT-P" "SWAPPED-ARGS-FUN" @@ -748,7 +751,7 @@ retained, possibly temporariliy, because it might be used internally." ;; ..and CONDITIONs.. "BUG" "UNSUPPORTED-OPERATOR" - + ;; ..and DEFTYPEs.. "INDEX" "LOAD/STORE-INDEX" "SIGNED-BYTE-WITH-A-BITE-OUT" @@ -762,7 +765,7 @@ retained, possibly temporariliy, because it might be used internally." "SINGLE-FLOATP" "FIXNUMP" "BIGNUMP" - "RATIOP" + "RATIOP" ;; encapsulation "ARG-LIST" @@ -818,7 +821,7 @@ retained, possibly temporariliy, because it might be used internally." ;; cross-compilation bootstrap hacks which turn into ;; placeholders in a target system - "UNCROSS" + "UNCROSS" ;; might as well be shared among the various files which ;; need it: @@ -849,7 +852,8 @@ retained, possibly temporariliy, because it might be used internally." "SYMBOL-SELF-EVALUATING-P" "PRINT-PRETTY-ON-STREAM-P" "LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P" - "POSITIVE-PRIMEP" + "POSITIVE-PRIMEP" + "EVAL-IN-LEXENV" ;; These could be moved back into SB!EXT if someone has ;; compelling reasons, but hopefully we can get by @@ -884,7 +888,7 @@ retained, possibly temporariliy, because it might be used internally." ;; hackery to help set up for cold init "!BEGIN-COLLECTING-COLD-INIT-FORMS" - "!COLD-INIT-FORMS" + "!COLD-INIT-FORMS" "COLD-FSET" "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS")) @@ -1306,7 +1310,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "SHOW-CONDITION" "CASE-FAILURE" "NAMESTRING-PARSE-ERROR" "NAMESTRING-PARSE-ERROR-OFFSET" "DESCRIBE-CONDITION" - + "!COLD-INIT" "!UNINTERN-INIT-ONLY-STUFF" "!GLOBALDB-COLD-INIT" "!FDEFN-COLD-INIT" "!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT" diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 6e8b10f..abd46dd 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -13,29 +13,31 @@ ;;; general case of EVAL (except in that it can't handle toplevel ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE. -(defun %eval (expr) - (funcall (compile (gensym "EVAL-TMPFUN-") - `(lambda () +(defun %eval (expr lexenv) + (funcall (sb!c:compile-in-lexenv + (gensym "EVAL-TMPFUN-") + `(lambda () - ;; The user can reasonably expect that the - ;; interpreter will be safe. - (declare (optimize (safety 3))) + ;; The user can reasonably expect that the + ;; interpreter will be safe. + (declare (optimize (safety 3))) - ;; It's also good if the interpreter doesn't - ;; spend too long thinking about each input - ;; form, since if the user'd wanted the - ;; tradeoff to favor quality of compiled code - ;; over compilation speed, he'd've explicitly - ;; asked for compilation. - (declare (optimize (compilation-speed 2))) + ;; It's also good if the interpreter doesn't + ;; spend too long thinking about each input + ;; form, since if the user'd wanted the + ;; tradeoff to favor quality of compiled code + ;; over compilation speed, he'd've explicitly + ;; asked for compilation. + (declare (optimize (compilation-speed 2))) - ;; Other properties are relatively unimportant. - (declare (optimize (speed 1) (debug 1) (space 1))) + ;; Other properties are relatively unimportant. + (declare (optimize (speed 1) (debug 1) (space 1))) - ,expr)))) + ,expr) + lexenv))) ;;; Handle PROGN and implicit PROGN. -(defun eval-progn-body (progn-body) +(defun eval-progn-body (progn-body lexenv) (unless (list-with-length-p progn-body) (let ((*print-circle* t)) (error 'simple-program-error @@ -52,17 +54,21 @@ (rest-i (rest i) (rest i))) (nil) (if rest-i ; if not last element of list - (eval (first i)) - (return (eval (first i)))))) + (eval-in-lexenv (first i) lexenv) + (return (eval-in-lexenv (first i) lexenv))))) -;;; Pick off a few easy cases, and the various top level EVAL-WHEN -;;; magical cases, and call %EVAL for the rest. (defun eval (original-exp) #!+sb-doc "Evaluate the argument in a null lexical environment, returning the result or results." + (eval-in-lexenv original-exp (make-null-lexenv))) + +;;; Pick off a few easy cases, and the various top level EVAL-WHEN +;;; magical cases, and call %EVAL for the rest. +(defun eval-in-lexenv (original-exp lexenv) (declare (optimize (safety 1))) - (let ((exp (macroexpand original-exp))) + ;; (aver (lexenv-simple-p lexenv)) + (let ((exp (macroexpand original-exp lexenv))) (typecase exp (symbol (ecase (info :variable :kind exp) @@ -80,7 +86,7 @@ ;; compatibility, it can be implemented with ;; DEFINE-SYMBOL-MACRO, keeping the code walkers happy. (:alien - (%eval original-exp)))) + (%eval original-exp lexenv)))) (list (let ((name (first exp)) (n-args (1- (length exp)))) @@ -89,11 +95,13 @@ (unless (= n-args 1) (error "wrong number of args to FUNCTION:~% ~S" exp)) (let ((name (second exp))) - (if (or (atom name) - (and (consp name) - (eq (car name) 'setf))) + (if (and (or (atom name) + (and (consp name) + (eq (car name) 'setf))) + (not (consp (let ((sb!c:*lexenv* lexenv)) + (sb!c:lexenv-find name funs))))) (fdefinition name) - (%eval original-exp)))) + (%eval original-exp lexenv)))) (quote (unless (= n-args 1) (error "wrong number of args to QUOTE:~% ~S" exp)) @@ -117,9 +125,9 @@ ;; variable; the code should now act as though that ;; variable is NIL. This should be tested.. (:special) - (t (return (%eval original-exp)))))))) + (t (return (%eval original-exp lexenv)))))))) ((progn) - (eval-progn-body (rest exp))) + (eval-progn-body (rest exp) lexenv)) ((eval-when) ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR ;; instead of PROGRAM-ERROR when there's something wrong @@ -145,15 +153,15 @@ ;; otherwise, the EVAL-WHEN form returns NIL. (declare (ignore ct lt)) (when e - (eval-progn-body body))))) + (eval-progn-body body lexenv))))) (t (if (and (symbolp name) (eq (info :function :kind name) :function)) (collect ((args)) - (dolist (arg (rest exp)) - (args (eval arg))) - (apply (symbol-function name) (args))) - (%eval original-exp)))))) + (dolist (arg (rest exp)) + (args (eval arg))) + (apply (symbol-function name) (args))) + (%eval original-exp lexenv)))))) (t exp)))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 76b2edc..f2e860e 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -275,10 +275,12 @@ (parse-defmacro arglist whole body name 'macrolet :environment environment) `(,name macro . - ,(compile nil - `(lambda (,whole ,environment) - ,@local-decls - (block ,name ,body)))))))) + ,(compile-in-lexenv + nil + `(lambda (,whole ,environment) + ,@local-decls + (block ,name ,body)) + (make-restricted-lexenv *lexenv*))))))) :funs definitions fun)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index c608b66..6e1e798 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -402,8 +402,39 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup policy + lambda cleanup policy (frob options lexenv-options)))) + +;;; Makes a LEXENV, suitable for using in a MACROLET introduced +;;; macroexpander +(defun make-restricted-lexenv (lexenv) + (flet ((fun-good-p (fun) + (destructuring-bind (name . thing) fun + (declare (ignore name)) + (etypecase thing + (functional nil) + (global-var t) + (cons (aver (eq (car thing) 'macro)) + t)))) + (var-good-p (var) + (destructuring-bind (name . thing) var + (declare (ignore name)) + (etypecase thing + (leaf nil) + (cons (aver (eq (car thing) 'macro)) + t) + (heap-alien-info nil))))) + (internal-make-lexenv + (remove-if-not #'fun-good-p (lexenv-funs lexenv)) + (remove-if-not #'var-good-p (lexenv-vars lexenv)) + nil + nil + (lexenv-type-restrictions lexenv) ; XXX + nil + nil + (lexenv-policy lexenv) + nil ; XXX + ))) ;;;; flow/DFO/component hackery diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 0b1f956..da6c4fc 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -50,10 +50,10 @@ ;; type declaration. (type-restrictions nil :type list) ;; the lexically enclosing lambda, if any - ;; + ;; ;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard ;; to get CLAMBDA defined in time for the cross-compiler. - (lambda nil) + (lambda nil) ;; the lexically enclosing cleanup, or NIL if none enclosing within Lambda (cleanup nil) ;; the current OPTIMIZE policy diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 197ffbe..941cef4 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -666,7 +666,9 @@ ;;; :TEST keyword may be used to determine the name equality ;;; predicate. (defmacro lexenv-find (name slot &key test) - (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) *lexenv*) + (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs))) + (symbolicate "LEXENV-" slot)) + *lexenv*) :test ,(or test '#'eq)))) `(if ,n-res (values (cdr ,n-res) t) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index b01695d..af3cf93 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1005,125 +1005,130 @@ path) (throw 'process-toplevel-form-error-abort nil)))) - (if (atom form) - ;; (There are no EVAL-WHEN issues in the ATOM case until - ;; SBCL gets smart enough to handle global - ;; DEFINE-SYMBOL-MACRO.) - (convert-and-maybe-compile form path) - (flet ((need-at-least-one-arg (form) - (unless (cdr form) - (compiler-error "~S form is too short: ~S" - (car form) - form)))) - (case (car form) - ;; In the cross-compiler, top level COLD-FSET arranges - ;; for static linking at cold init time. - #+sb-xc-host - ((cold-fset) - (aver (not compile-time-too)) - (destructuring-bind (cold-fset fun-name lambda-expression) form - (declare (ignore cold-fset)) - (process-toplevel-cold-fset fun-name - lambda-expression - path))) - ((eval-when macrolet symbol-macrolet);things w/ 1 arg before body - (need-at-least-one-arg form) - (destructuring-bind (special-operator magic &rest body) form - (ecase special-operator - ((eval-when) - ;; CT, LT, and E here are as in Figure 3-7 of ANSI - ;; "3.2.3.1 Processing of Top Level Forms". - (multiple-value-bind (ct lt e) - (parse-eval-when-situations magic) - (let ((new-compile-time-too (or ct - (and compile-time-too - e)))) - (cond (lt (process-toplevel-progn - body path new-compile-time-too)) - (new-compile-time-too (eval - `(progn ,@body))))))) - ((macrolet) - (funcall-in-macrolet-lexenv - magic - (lambda () - (process-toplevel-locally body - path - compile-time-too)))) - ((symbol-macrolet) - (funcall-in-symbol-macrolet-lexenv - magic - (lambda () - (process-toplevel-locally body - path - compile-time-too))))))) - ((locally) - (process-toplevel-locally (rest form) path compile-time-too)) - ((progn) - (process-toplevel-progn (rest form) path compile-time-too)) - ;; When we're cross-compiling, consider: what should we - ;; do when we hit e.g. - ;; (EVAL-WHEN (:COMPILE-TOPLEVEL) - ;; (DEFUN FOO (X) (+ 7 X)))? - ;; DEFUN has a macro definition in the cross-compiler, - ;; and a different macro definition in the target - ;; compiler. The only sensible thing is to use the - ;; target compiler's macro definition, since the - ;; cross-compiler's macro is in general into target - ;; functions which can't meaningfully be executed at - ;; cross-compilation time. So make sure we do the EVAL - ;; here, before we macroexpand. - ;; - ;; Then things get even dicier with something like - ;; (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..) - ;; where we have to make sure that we don't uncross - ;; the SB!XC: prefix before we do EVAL, because otherwise - ;; we'd be trying to redefine the cross-compilation host's - ;; constants. - ;; - ;; (Isn't it fun to cross-compile Common Lisp?:-) - #+sb-xc-host - (t - (when compile-time-too - (eval form)) ; letting xc host EVAL do its own macroexpansion - (let* (;; (We uncross the operator name because things - ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE - ;; should be equivalent to their CL: counterparts - ;; when being compiled as target code. We leave - ;; the rest of the form uncrossed because macros - ;; might yet expand into EVAL-WHEN stuff, and - ;; things inside EVAL-WHEN can't be uncrossed - ;; until after we've EVALed them in the - ;; cross-compilation host.) - (slightly-uncrossed (cons (uncross (first form)) - (rest form))) - (expanded (preprocessor-macroexpand-1 - slightly-uncrossed))) - (if (eq expanded slightly-uncrossed) - ;; (Now that we're no longer processing toplevel - ;; forms, and hence no longer need to worry about - ;; EVAL-WHEN, we can uncross everything.) - (convert-and-maybe-compile expanded path) - ;; (We have to demote COMPILE-TIME-TOO to NIL - ;; here, no matter what it was before, since - ;; otherwise we'd tend to EVAL subforms more than - ;; once, because of WHEN COMPILE-TIME-TOO form - ;; above.) - (process-toplevel-form expanded path nil)))) - ;; When we're not cross-compiling, we only need to - ;; macroexpand once, so we can follow the 1-thru-6 - ;; sequence of steps in ANSI's "3.2.3.1 Processing of - ;; Top Level Forms". - #-sb-xc-host - (t - (let ((expanded (preprocessor-macroexpand-1 form))) + (flet ((default-processor (form) + ;; When we're cross-compiling, consider: what should we + ;; do when we hit e.g. + ;; (EVAL-WHEN (:COMPILE-TOPLEVEL) + ;; (DEFUN FOO (X) (+ 7 X)))? + ;; DEFUN has a macro definition in the cross-compiler, + ;; and a different macro definition in the target + ;; compiler. The only sensible thing is to use the + ;; target compiler's macro definition, since the + ;; cross-compiler's macro is in general into target + ;; functions which can't meaningfully be executed at + ;; cross-compilation time. So make sure we do the EVAL + ;; here, before we macroexpand. + ;; + ;; Then things get even dicier with something like + ;; (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..) + ;; where we have to make sure that we don't uncross + ;; the SB!XC: prefix before we do EVAL, because otherwise + ;; we'd be trying to redefine the cross-compilation host's + ;; constants. + ;; + ;; (Isn't it fun to cross-compile Common Lisp?:-) + #+sb-xc-host + (progn + (when compile-time-too + (eval form)) ; letting xc host EVAL do its own macroexpansion + (let* (;; (We uncross the operator name because things + ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE + ;; should be equivalent to their CL: counterparts + ;; when being compiled as target code. We leave + ;; the rest of the form uncrossed because macros + ;; might yet expand into EVAL-WHEN stuff, and + ;; things inside EVAL-WHEN can't be uncrossed + ;; until after we've EVALed them in the + ;; cross-compilation host.) + (slightly-uncrossed (cons (uncross (first form)) + (rest form))) + (expanded (preprocessor-macroexpand-1 + slightly-uncrossed))) + (if (eq expanded slightly-uncrossed) + ;; (Now that we're no longer processing toplevel + ;; forms, and hence no longer need to worry about + ;; EVAL-WHEN, we can uncross everything.) + (convert-and-maybe-compile expanded path) + ;; (We have to demote COMPILE-TIME-TOO to NIL + ;; here, no matter what it was before, since + ;; otherwise we'd tend to EVAL subforms more than + ;; once, because of WHEN COMPILE-TIME-TOO form + ;; above.) + (process-toplevel-form expanded path nil)))) + ;; When we're not cross-compiling, we only need to + ;; macroexpand once, so we can follow the 1-thru-6 + ;; sequence of steps in ANSI's "3.2.3.1 Processing of + ;; Top Level Forms". + #-sb-xc-host + (let ((expanded (preprocessor-macroexpand-1 form))) (cond ((eq expanded form) (when compile-time-too - (eval form)) + (eval-in-lexenv form *lexenv*)) (convert-and-maybe-compile form path)) (t (process-toplevel-form expanded path - compile-time-too)))))))))) + compile-time-too)))))) + (if (atom form) + #+sb-xc-host + ;; (There are no EVAL-WHEN issues in the ATOM case until + ;; SBCL gets smart enough to handle global + ;; DEFINE-SYMBOL-MACRO or SYMBOL-MACROLET.) + (convert-and-maybe-compile form path) + #-sb-xc-host + (default-processor form) + (flet ((need-at-least-one-arg (form) + (unless (cdr form) + (compiler-error "~S form is too short: ~S" + (car form) + form)))) + (case (car form) + ;; In the cross-compiler, top level COLD-FSET arranges + ;; for static linking at cold init time. + #+sb-xc-host + ((cold-fset) + (aver (not compile-time-too)) + (destructuring-bind (cold-fset fun-name lambda-expression) form + (declare (ignore cold-fset)) + (process-toplevel-cold-fset fun-name + lambda-expression + path))) + ((eval-when macrolet symbol-macrolet);things w/ 1 arg before body + (need-at-least-one-arg form) + (destructuring-bind (special-operator magic &rest body) form + (ecase special-operator + ((eval-when) + ;; CT, LT, and E here are as in Figure 3-7 of ANSI + ;; "3.2.3.1 Processing of Top Level Forms". + (multiple-value-bind (ct lt e) + (parse-eval-when-situations magic) + (let ((new-compile-time-too (or ct + (and compile-time-too + e)))) + (cond (lt (process-toplevel-progn + body path new-compile-time-too)) + (new-compile-time-too (eval-in-lexenv + `(progn ,@body) + *lexenv*)))))) + ((macrolet) + (funcall-in-macrolet-lexenv + magic + (lambda () + (process-toplevel-locally body + path + compile-time-too)))) + ((symbol-macrolet) + (funcall-in-symbol-macrolet-lexenv + magic + (lambda () + (process-toplevel-locally body + path + compile-time-too))))))) + ((locally) + (process-toplevel-locally (rest form) path compile-time-too)) + ((progn) + (process-toplevel-progn (rest form) path compile-time-too)) + (t (default-processor form)))))))) (values)) @@ -1667,3 +1672,15 @@ (when circular-ref (setf (cdr circular-ref) (append (cdr circular-ref) (cdr info)))))))))))) + + +;;;; Host compile time definitions +#+sb-xc-host +(defun compile-in-lexenv (name lambda lexenv) + (declare (ignore lexenv)) + (compile name lambda)) + +#+sb-xc-host +(defun eval-in-lexenv (form lexenv) + (declare (ignore lexenv)) + (eval form)) diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 23bfb23..d455fbc 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -28,7 +28,7 @@ definition))) ;;; Handle the nontrivial case of CL:COMPILE. -(defun actually-compile (name definition) +(defun actually-compile (name definition *lexenv*) (with-compilation-values (sb!xc:with-compilation-unit () ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with @@ -44,7 +44,6 @@ ;; rebinding to itself is needed now that SBCL doesn't ;; need *BACKEND-INFO-ENVIRONMENT*. (*info-environment* *info-environment*) - (*lexenv* (make-null-lexenv)) (form (get-lambda-to-compile definition)) (*source-info* (make-lisp-source-info form)) (*toplevel-lambdas* ()) @@ -76,19 +75,11 @@ :name name :path '(original-source-start 0 0)))))) -(defun compile (name &optional (definition (or (macro-function name) - (fdefinition name)))) - #!+sb-doc - "Coerce DEFINITION (by default, the function whose name is NAME) - to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P), - where if NAME is NIL, THING is the result of compilation, and - otherwise THING is NAME. When NAME is not NIL, the compiled function - is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into - (FDEFINITION NAME) otherwise." +(defun compile-in-lexenv (name definition lexenv) (multiple-value-bind (compiled-definition warnings-p failure-p) (if (compiled-function-p definition) (values definition nil nil) - (actually-compile name definition)) + (actually-compile name definition lexenv)) (cond (name (if (and (symbolp name) (macro-function name)) @@ -97,3 +88,14 @@ (values name warnings-p failure-p)) (t (values compiled-definition warnings-p failure-p))))) + +(defun compile (name &optional (definition (or (macro-function name) + (fdefinition name)))) + #!+sb-doc + "Coerce DEFINITION (by default, the function whose name is NAME) + to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P), + where if NAME is NIL, THING is the result of compilation, and + otherwise THING is NAME. When NAME is not NIL, the compiled function + is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into + (FDEFINITION NAME) otherwise." + (compile-in-lexenv name definition (make-null-lexenv))) diff --git a/tests/bug204-test.lisp b/tests/bug204-test.lisp new file mode 100644 index 0000000..c11cda9 --- /dev/null +++ b/tests/bug204-test.lisp @@ -0,0 +1,10 @@ +;;;; Test of EVAL-WHEN inside a local environment +(cl:in-package :cl-user) + +(macrolet ((def (x) + (push `(:expanded ,x) *bug204-test-status*) + `(push `(:called ,',x) *bug204-test-status*))) + (eval-when (:compile-toplevel) + (def :compile-toplevel)) + (eval-when (:load-toplevel) + (def :load-toplevel))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index a9dd138..b72c7cc 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -461,6 +461,44 @@ BUG 48c, not yet fixed: (defmacro-test) +;;; bug 204: EVAL-WHEN inside a local environment +(defvar *bug204-test-status*) + +(defun bug204-test () + (let* ((src "bug204-test.lisp") + (obj (compile-file-pathname src))) + (unwind-protect + (progn + (setq *bug204-test-status* nil) + (compile-file src) + (assert (equal *bug204-test-status* '((:expanded :load-toplevel) + (:called :compile-toplevel) + (:expanded :compile-toplevel)))) + (setq *bug204-test-status* nil) + (load obj) + (assert (equal *bug204-test-status* '((:called :load-toplevel))))) + (ignore-errors (delete-file obj))))) + +(bug204-test) + +;;; toplevel SYMBOL-MACROLET +(defvar *symbol-macrolet-test-status*) + +(defun symbol-macrolet-test () + (let* ((src "symbol-macrolet-test.lisp") + (obj (compile-file-pathname src))) + (unwind-protect + (progn + (setq *symbol-macrolet-test-status* nil) + (compile-file src) + (assert (equal *symbol-macrolet-test-status* + '(2 1))) + (setq *symbol-macrolet-test-status* nil) + (load obj) + (assert (equal *symbol-macrolet-test-status* '(2)))) + (ignore-errors (delete-file obj))))) + +(symbol-macrolet-test) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d120ba4..c36dbea 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -203,3 +203,11 @@ (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3)))) (assert (null result)) (assert (typep error 'error))) + +;;; bug 124: environment of MACROLET-introduced macro expanders +(assert (equal + (macrolet ((mext (x) `(cons :mext ,x))) + (macrolet ((mint (y) `'(:mint ,(mext y)))) + (list (mext '(1 2)) + (mint (1 2))))) + '((:MEXT 1 2) (:MINT (:MEXT 1 2))))) diff --git a/tests/symbol-macrolet-test.lisp b/tests/symbol-macrolet-test.lisp new file mode 100644 index 0000000..0343065 --- /dev/null +++ b/tests/symbol-macrolet-test.lisp @@ -0,0 +1,6 @@ +(symbol-macrolet ((s1 (push 1 *symbol-macrolet-test-status*)) + (s2 (push 2 *symbol-macrolet-test-status*))) + (eval-when (:compile-toplevel) + s1) + (eval-when (:compile-toplevel :load-toplevel) + s2)) diff --git a/version.lisp-expr b/version.lisp-expr index 5e50aa0..50dfb70 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; internal versions off the main CVS branch, it gets hairier, e.g. ;;; "0.pre7.14.flaky4.13".) -"0.7.8.22" +"0.7.8.23" -- 1.7.10.4