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)
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-#:
"*BACKEND-SUBFEATURES*"
"*BACKEND-T-PRIMITIVE-TYPE*"
- "*CODE-SEGMENT*"
+ "*CODE-SEGMENT*"
"*COUNT-VOP-USAGES*" "*ELSEWHERE*" "*FREE-FUNS*"
+ "*LEXENV*"
"*SETF-ASSUMED-FBOUNDP*"
"*SUPPRESS-VALUES-DECLARATION*"
"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"
"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"
;; weak pointers and finalization
"CANCEL-FINALIZATION"
- "FINALIZE"
+ "FINALIZE"
"HASH-TABLE-WEAK-P" "MAKE-WEAK-POINTER"
"WEAK-POINTER" "WEAK-POINTER-P" "WEAK-POINTER-VALUE"
;; 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
;; stuff for hinting to the compiler
"NAMED-LAMBDA"
-
+
;; other variations on DEFFOO stuff useful for bootstrapping
;; and cross-compiling
"DEFMACRO-MUNDANELY"
"FASTBIG-INCF-PCOUNTER-OR-FIXNUM"
"INCF-PCOUNTER"
"INCF-PCOUNTER-OR-FIXNUM"
- "MAKE-PCOUNTER"
+ "MAKE-PCOUNTER"
"PCOUNTER"
"PCOUNTER->INTEGER"
"PCOUNTER-OR-FIXNUM->INTEGER"
;; 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"
;; ..and CONDITIONs..
"BUG"
"UNSUPPORTED-OPERATOR"
-
+
;; ..and DEFTYPEs..
"INDEX" "LOAD/STORE-INDEX"
"SIGNED-BYTE-WITH-A-BITE-OUT"
"SINGLE-FLOATP"
"FIXNUMP"
"BIGNUMP"
- "RATIOP"
+ "RATIOP"
;; encapsulation
"ARG-LIST"
;; 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:
"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
;; 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"))
"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"
;;; 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
(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)
;; 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))))
(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))
;; 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
;; 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))))
\f
(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))
(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
+ )))
\f
;;;; flow/DFO/component hackery
;; 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
;;; :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)
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))
\f
(when circular-ref
(setf (cdr circular-ref)
(append (cdr circular-ref) (cdr info))))))))))))
+
+\f
+;;;; 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))
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
;; 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* ())
: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))
(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)))
--- /dev/null
+;;;; 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)))
(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)
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
(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)))))
--- /dev/null
+(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))
;;; 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"
projects / sbcl.git / commitdiff