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.
2026-09-10 07:26:40 -04:00 · 2002-10-27 14:52:48 +00:00 · 2002-10-27 14:52:48 +00:00 · 3eb39e017e
parent 50b745c43a
commit 3eb39e017e
11 changed files with 173 additions and 86 deletions
--- a/24
+++ b/24
@ -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-#:
--- 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
--- 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"
--- 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
--- 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
--- 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)))
--- 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))
--- 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)))
--- 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
--- 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
--- 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"