From 3eb39e017e52b5d704e7d33405c873af52a533fd Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 27 Oct 2002 14:52:48 +0000 Subject: [PATCH] 0.7.9.6: Fix bug 185 (top level forms at the REPL) ... implement a LOCALLY method for EVAL-IN-LEXENV ... factor out MACROLET-DEFINITIONIZE-FUN and SYMBOL-MACROLET-DEFINITIONIZE-FUN from the IR1 translators for same ... implement SYMBOL-MACROLET and MACROLET for EVAL-IN-LEXENV in terms of said DEFINITIONIZE-FUN macros and LOCALLY ... set compilation policy in make-target-2 to avoid file scope limitations ... set interaction policy by hard-coding it in MAKE-NULL-INTERACTIVE-LEXENV ... throw it together and hope it all still works. --- BUGS | 24 ++++++---- make-target-2.sh | 11 +++++ package-data-list.lisp-expr | 3 +- src/code/eval.lisp | 81 ++++++++++++++++++++++++++-------- src/code/toplevel.lisp | 5 ++- src/cold/warm.lisp | 11 ----- src/compiler/ir1-translators.lisp | 88 +++++++++++++++++++++++-------------- src/compiler/lexenv.lisp | 7 +++ src/compiler/target-main.lisp | 1 + tests/pathnames.impure.lisp | 26 ++++++----- version.lisp-expr | 2 +- 11 files changed, 173 insertions(+), 86 deletions(-) diff --git a/BUGS b/BUGS index 20cb300..d6d3cd7 100644 --- a/BUGS +++ b/BUGS @@ -979,14 +979,6 @@ WORKAROUND: :ACCRUED-EXCEPTIONS (:INEXACT) :FAST-MODE NIL) -185: "top-level forms at the REPL" - * (locally (defstruct foo (a 0 :type fixnum))) - gives an error: - ; caught ERROR: - ; (in macroexpansion of (SB-KERNEL::%DELAYED-GET-COMPILER-LAYOUT BAR)) - however, compiling and loading the same expression in a file works - as expected. - 187: "type inference confusion around DEFTRANSFORM time" (reported even more verbosely on sbcl-devel 2002-06-28 as "strange bug in DEFTRANSFORM") @@ -1386,6 +1378,22 @@ 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 DEFUNCT CATEGORIES OF BUGS IR1-#: diff --git a/make-target-2.sh b/make-target-2.sh index bb0f113..0a51ab9 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -67,6 +67,17 @@ echo //doing warm init (sb-int:/show "done with warm.lisp, about to GC :FULL T") (gc :full t)) + ;; resetting compilation policy to neutral values in + ;; preparation for SAVE-LISP-AND-DIE as final SBCL core (not + ;; in warm.lisp because SB-C::*POLICY* has file scope) + (sb-int:/show "setting compilation policy to neutral values") + (proclaim '(optimize (compilation-speed 1) + (debug 1) + (inhibit-warnings 1) + (safety 1) + (space 1) + (speed 1))) + (sb-int:/show "done with warm.lisp, about to SAVE-LISP-AND-DIE") ;; Even if /SHOW output was wanted during build, it's probably ;; not wanted by default after build is complete. (And if it's diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ff61204..b44e9f8 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1097,7 +1097,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "MAKE-KEY-INFO" "MAKE-LISP-OBJ" #!+long-float "MAKE-LONG-FLOAT" "MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE" - "MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE" + "MAKE-NULL-LEXENV" "MAKE-NULL-INTERACTIVE-LEXENV" + "MAKE-NUMERIC-TYPE" "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY" "%MAKE-INSTANCE" "MAKE-VALUE-CELL" diff --git a/src/code/eval.lisp b/src/code/eval.lisp index abd46dd..e9721f2 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -17,22 +17,6 @@ (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))) - - ;; 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))) - ,expr) lexenv))) @@ -91,7 +75,7 @@ (let ((name (first exp)) (n-args (1- (length exp)))) (case name - (function + ((function) (unless (= n-args 1) (error "wrong number of args to FUNCTION:~% ~S" exp)) (let ((name (second exp))) @@ -102,7 +86,7 @@ (sb!c:lexenv-find name funs))))) (fdefinition name) (%eval original-exp lexenv)))) - (quote + ((quote) (unless (= n-args 1) (error "wrong number of args to QUOTE:~% ~S" exp)) (second exp)) @@ -154,12 +138,71 @@ (declare (ignore ct lt)) (when e (eval-progn-body body lexenv))))) + ((locally) + (multiple-value-bind (body decls) (parse-body (rest exp) nil) + (let ((lexenv + ;; KLUDGE: Uh, yeah. I'm not anticipating + ;; winning any prizes for this code, which was + ;; written on a "let's get it to work" basis. + ;; These seem to be the variables that need + ;; bindings for PROCESS-DECLS to work + ;; (*FREE-FUNS* and *FREE-VARS* so that + ;; references to free functions and variables in + ;; the declarations can be noted; + ;; *UNDEFINED-WARNINGS* so that warnings about + ;; undefined things can be accumulated [and then + ;; thrown away, as it happens]). -- CSR, 2002-10-24 + (let ((sb!c:*lexenv* lexenv) + (sb!c::*free-funs* (make-hash-table :test 'equal)) + (sb!c::*free-vars* (make-hash-table :test 'eq)) + (sb!c::*undefined-warnings* nil)) + (sb!c::process-decls decls + nil nil + (sb!c::make-continuation) + lexenv)))) + (eval-progn-body body lexenv)))) + ((macrolet) + (destructuring-bind (definitions &rest body) + (rest exp) + ;; FIXME: shared code with FUNCALL-IN-FOOMACROLET-LEXENV + (declare (type list definitions)) + (unless (= (length definitions) + (length (remove-duplicates definitions :key #'first))) + (style-warn "duplicate definitions in ~S" definitions)) + (let ((lexenv + (sb!c::make-lexenv + :default lexenv + :funs (mapcar + (sb!c::macrolet-definitionize-fun + :eval + ;; I'm not sure that this is the correct + ;; LEXENV to be compiling local macros + ;; in... + lexenv) + definitions)))) + (eval-in-lexenv `(locally ,@body) lexenv)))) + ((symbol-macrolet) + (destructuring-bind (definitions &rest body) + (rest exp) + ;; FIXME: shared code with FUNCALL-IN-FOOMACROLET-LEXENV + (declare (type list definitions)) + (unless (= (length definitions) + (length (remove-duplicates definitions :key #'first))) + (style-warn "duplicate definitions in ~S" definitions)) + (let ((lexenv + (sb!c::make-lexenv + :default lexenv + :vars (mapcar + (sb!c::symbol-macrolet-definitionize-fun + :eval) + definitions)))) + (eval-in-lexenv `(locally ,@body) lexenv)))) (t (if (and (symbolp name) (eq (info :function :kind name) :function)) (collect ((args)) (dolist (arg (rest exp)) - (args (eval arg))) + (args (eval-in-lexenv arg lexenv))) (apply (symbol-function name) (args))) (%eval original-exp lexenv)))))) (t diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 9cc5f67..f4baf40 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -260,7 +260,10 @@ "Evaluate FORM, returning whatever it returns and adjusting ***, **, *, +++, ++, +, ///, //, /, and -." (setf - form) - (let ((results (multiple-value-list (eval form)))) + (let ((results + (multiple-value-list + (eval-in-lexenv form + (make-null-interactive-lexenv))))) (setf /// // // / / results diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index a89de69..91bd152 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -269,14 +269,3 @@ ;;; through the cold boot process. They need to be set somewhere. Maybe the ;;; easiest thing to do is to read them out of package-data-list.lisp-expr ;;; now? - -;;;; resetting compilation policy to neutral values in preparation for -;;;; SAVE-LISP-AND-DIE as final SBCL core - -(sb-int:/show "setting compilation policy to neutral values") -(proclaim '(optimize (compilation-speed 1) - (debug 1) - (inhibit-warnings 1) - (safety 1) - (space 1) - (speed 1))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 14823c9..09ad701 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -252,35 +252,44 @@ (*lexenv* (make-lexenv definitionize-keyword processed-definitions))) (funcall fun definitionize-keyword processed-definitions))) -;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then +;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then ;;; call FUN (with no arguments). ;;; ;;; This is split off from the IR1 convert method so that it can be -;;; shared by the special-case top level MACROLET processing code. +;;; shared by the special-case top level MACROLET processing code, and +;;; further split so that the special-case MACROLET processing code in +;;; EVAL can likewise make use of it. +(defmacro macrolet-definitionize-fun (context lexenv) + (flet ((make-error-form (control &rest args) + (ecase context + (:compile `(compiler-error ,control ,@args)) + (:eval `(error 'simple-program-error + :format-control ,control + :format-arguments (list ,@args)))))) + `(lambda (definition) + (unless (list-of-length-at-least-p definition 2) + ,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition)) + (destructuring-bind (name arglist &body body) definition + (unless (symbolp name) + ,(make-error-form "The local macro name ~S is not a symbol." 'name)) + (unless (listp arglist) + ,(make-error-form "The local macro argument list ~S is not a list." 'arglist)) + (let ((whole (gensym "WHOLE")) + (environment (gensym "ENVIRONMENT"))) + (multiple-value-bind (body local-decls) + (parse-defmacro arglist whole body name 'macrolet + :environment environment) + `(,name macro . + ,(compile-in-lexenv + nil + `(lambda (,whole ,environment) + ,@local-decls + (block ,name ,body)) + ,lexenv)))))))) + (defun funcall-in-macrolet-lexenv (definitions fun) (%funcall-in-foomacrolet-lexenv - (lambda (definition) - (unless (list-of-length-at-least-p definition 2) - (compiler-error - "The list ~S is too short to be a legal local macro definition." - definition)) - (destructuring-bind (name arglist &body body) definition - (unless (symbolp name) - (compiler-error "The local macro name ~S is not a symbol." name)) - (unless (listp arglist) - (compiler-error "The local macro argument list ~S is not a list." arglist)) - (let ((whole (gensym "WHOLE")) - (environment (gensym "ENVIRONMENT"))) - (multiple-value-bind (body local-decls) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - `(,name macro . - ,(compile-in-lexenv - nil - `(lambda (,whole ,environment) - ,@local-decls - (block ,name ,body)) - (make-restricted-lexenv *lexenv*))))))) + (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*)) :funs definitions fun)) @@ -298,20 +307,31 @@ (declare (ignore funs)) (ir1-translate-locally body start cont)))) -(defun funcall-in-symbol-macrolet-lexenv (definitions fun) - (%funcall-in-foomacrolet-lexenv - (lambda (definition) - (unless (proper-list-of-length-p definition 2) - (compiler-error "malformed symbol/expansion pair: ~S" definition)) +(defmacro symbol-macrolet-definitionize-fun (context) + (flet ((make-error-form (control &rest args) + (ecase context + (:compile `(compiler-error ,control ,@args)) + (:eval `(error 'simple-program-error + :format-control ,control + :format-arguments (list ,@args)))))) + `(lambda (definition) + (unless (proper-list-of-length-p definition 2) + ,(make-error-form "malformed symbol/expansion pair: ~S" 'definition)) (destructuring-bind (name expansion) definition (unless (symbolp name) - (compiler-error - "The local symbol macro name ~S is not a symbol." - name)) + ,(make-error-form + "The local symbol macro name ~S is not a symbol." + 'name)) (let ((kind (info :variable :kind name))) (when (member kind '(:special :constant)) - (compiler-error "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name))) - `(,name . (MACRO . ,expansion)))) + ,(make-error-form + "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" + 'kind 'name))) + `(,name . (MACRO . ,expansion))))))1 + +(defun funcall-in-symbol-macrolet-lexenv (definitions fun) + (%funcall-in-foomacrolet-lexenv + (symbol-macrolet-definitionize-fun :compile) :vars definitions fun)) diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 5a94a63..033a4fa 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -18,6 +18,13 @@ #!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place (def!struct (lexenv (:constructor make-null-lexenv ()) + (:constructor make-null-interactive-lexenv + (&aux (policy (list '(safety . 3) + '(compilation-speed . 2) + '(speed . 1) + '(space . 1) + '(debug . 1) + '(inhibit-warnings . 1))))) (:constructor internal-make-lexenv (funs vars blocks tags type-restrictions lambda cleanup policy))) diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index d455fbc..6edf906 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -61,6 +61,7 @@ (*last-format-args* nil) (*last-message-count* 0) (*gensym-counter* 0) + (*policy* (lexenv-policy *lexenv*)) ;; FIXME: ANSI doesn't say anything about CL:COMPILE ;; interacting with these variables, so we shouldn't. As ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 2219012..d177230 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -79,17 +79,21 @@ ;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be ;;; a TYPE-ERROR? -(assert (not (ignore-errors - (make-pathname :host "FOO" :directory "!bla" :name "bar")))) - -;; error: name-component not valid -(assert (not (ignore-errors - (make-pathname :host "FOO" :directory "bla" :name "!bar")))) - -;; error: type-component not valid. -(assert (not (ignore-errors - (make-pathname :host "FOO" :directory "bla" :name "bar" - :type "&baz")))) +(locally + ;; MAKE-PATHNAME is UNSAFELY-FLUSHABLE + (declare (optimize safety)) + + (assert (not (ignore-errors + (make-pathname :host "FOO" :directory "!bla" :name "bar")))) + + ;; error: name-component not valid + (assert (not (ignore-errors + (make-pathname :host "FOO" :directory "bla" :name "!bar")))) + + ;; error: type-component not valid. + (assert (not (ignore-errors + (make-pathname :host "FOO" :directory "bla" :name "bar" + :type "&baz"))))) ;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The ;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC diff --git a/version.lisp-expr b/version.lisp-expr index 5d8a38b..3b9c16b 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.9.5" +"0.7.9.6" -- 1.7.10.4