Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler ir1-translators.lisp,1.28,1.29 ir1util.lisp,1.44,1.45 lexenv.lisp,1.9,1.10 macros.lisp,1.29,1.30 main.lisp,1.59,1.60 target-main.lisp,1.11,1.12
|
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)))
|