From: Alexey D. <ade...@us...> - 2002-10-10 07:16:20
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory usw-pr-cvs1:/tmp/cvs-serv31829/src/compiler Modified Files: ir1-translators.lisp ir1util.lisp lexenv.lisp macros.lisp main.lisp target-main.lisp Log Message: 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. Index: ir1-translators.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v retrieving revision 1.28 retrieving revision 1.29 diff -u -d -r1.28 -r1.29 --- ir1-translators.lisp 6 Oct 2002 09:15:51 -0000 1.28 +++ ir1-translators.lisp 10 Oct 2002 07:16:15 -0000 1.29 @@ -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)) Index: ir1util.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v retrieving revision 1.44 retrieving revision 1.45 diff -u -d -r1.44 -r1.45 --- ir1util.lisp 27 Sep 2002 11:30:58 -0000 1.44 +++ ir1util.lisp 10 Oct 2002 07:16:15 -0000 1.45 @@ -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 Index: lexenv.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/lexenv.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- lexenv.lisp 15 Jan 2002 01:06:10 -0000 1.9 +++ lexenv.lisp 10 Oct 2002 07:16:15 -0000 1.10 @@ -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 Index: macros.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/macros.lisp,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- macros.lisp 21 Sep 2002 10:24:08 -0000 1.29 +++ macros.lisp 10 Oct 2002 07:16:15 -0000 1.30 @@ -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) Index: main.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v retrieving revision 1.59 retrieving revision 1.60 diff -u -d -r1.59 -r1.60 --- main.lisp 31 Aug 2002 01:19:51 -0000 1.59 +++ main.lisp 10 Oct 2002 07:16:15 -0000 1.60 @@ -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)) Index: target-main.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/target-main.lisp,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- target-main.lisp 19 May 2002 22:49:37 -0000 1.11 +++ target-main.lisp 10 Oct 2002 07:16:15 -0000 1.12 @@ -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))) |