From 269554bcae55d7e502992ea20932f71790066483 Mon Sep 17 00:00:00 2001
From: Alexey Dejneka <adejneka@comail.ru>
Date: Thu, 17 Jul 2003 12:00:35 +0000
Subject: [PATCH] 0.8.1.37:         * Cleanup of MACROLET processing;        
 ... fix bug 264: interpreted version of SYMBOL-MACROLET did
             not check for a bound SPECIAL declaration.

---
 BUGS                              |    2 +
 src/code/eval.lisp                |  105 ++++++++++++++++---------------------
 src/compiler/ir1-translators.lisp |  105 ++++++++++++++++++-------------------
 src/compiler/main.lisp            |    6 ++-
 tests/eval.impure.lisp            |   11 ++++
 version.lisp-expr                 |    2 +-
 6 files changed, 115 insertions(+), 116 deletions(-)

diff --git a/BUGS b/BUGS
index 6e31933..8163c56 100644
--- a/BUGS
+++ b/BUGS
@@ -1090,6 +1090,8 @@ WORKAROUND:
 
   does not signal an error.
 
+  (fixed in 0.8.1.37)
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.
diff --git a/src/code/eval.lisp b/src/code/eval.lisp
index 4c350e4..3f29e59 100644
--- a/src/code/eval.lisp
+++ b/src/code/eval.lisp
@@ -46,6 +46,32 @@
 	(eval-in-lexenv (first i) lexenv)
 	(return (eval-in-lexenv (first i) lexenv)))))
 
+(defun eval-locally (exp lexenv &optional vars)
+  (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
+                                  vars
+                                  nil
+                                  (sb!c::make-continuation)
+                                  lexenv))))
+      (eval-progn-body body lexenv))))
+
 (defun eval (original-exp)
   #!+sb-doc
   "Evaluate the argument in a null lexical environment, returning the
@@ -157,76 +183,37 @@
 		  (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))))
+	      (eval-locally exp 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))))
+                       (let ((sb!c:*lexenv* lexenv))
+                         (sb!c::funcall-in-macrolet-lexenv
+                          definitions
+                          (lambda (&key funs)
+                            (declare (ignore funs))
+                            sb!c:*lexenv*)
+                          :eval))))
+                  (eval-locally `(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))))
+                (multiple-value-bind (lexenv vars)
+                    (let ((sb!c:*lexenv* lexenv))
+                      (sb!c::funcall-in-symbol-macrolet-lexenv
+                       definitions
+                       (lambda (&key vars)
+                         (values sb!c:*lexenv* vars))
+                       :eval))
+                  (eval-locally `(locally ,@body) lexenv vars))))
 	     (t
 	      (if (and (symbolp name)
 		       (eq (info :function :kind name) :function))
 		  (collect ((args))
-			   (dolist (arg (rest exp))
-			     (args (eval-in-lexenv arg lexenv)))
-			   (apply (symbol-function name) (args)))
+                    (dolist (arg (rest exp))
+                      (args (eval-in-lexenv arg lexenv)))
+                    (apply (symbol-function name) (args)))
 		  (%eval exp lexenv))))))
 	(t
 	 exp)))))
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 23dfa9c..fd4aa84 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -261,40 +261,38 @@
 ;;; 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)
+(defun macrolet-definitionize-fun (context lexenv)
+  (flet ((fail (control &rest args)
 	   (ecase context
-	     (:compile `(compiler-error ,control ,@args))
-	     (:eval `(error 'simple-program-error
-		      :format-control ,control
-		      :format-arguments (list ,@args))))))
-    `(lambda (definition)
+	     (:compile (apply #'compiler-error control args))
+	     (:eval (error 'simple-program-error
+                           :format-control control
+                           :format-arguments 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))
+        (fail "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))
-	(with-unique-names (whole 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
-                  ,body)
-		,lexenv))))))))
-
-(defun funcall-in-macrolet-lexenv (definitions fun)
+        (unless (symbolp name)
+          (fail "The local macro name ~S is not a symbol." name))
+        (unless (listp arglist)
+          (fail "The local macro argument list ~S is not a list."
+                arglist))
+        (with-unique-names (whole 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
+                         ,body)
+                      lexenv))))))))
+
+(defun funcall-in-macrolet-lexenv (definitions fun context)
   (%funcall-in-foomacrolet-lexenv
-   (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*))
+   (macrolet-definitionize-fun context (make-restricted-lexenv *lexenv*))
    :funs
    definitions
    fun))
@@ -309,33 +307,31 @@
    definitions
    (lambda (&key funs)
      (declare (ignore funs))
-     (ir1-translate-locally body start cont))))
+     (ir1-translate-locally body start cont))
+   :compile))
 
-(defmacro symbol-macrolet-definitionize-fun (context)
-  (flet ((make-error-form (control &rest args)
+(defun symbol-macrolet-definitionize-fun (context)
+  (flet ((fail (control &rest args)
 	   (ecase context
-	     (:compile `(compiler-error ,control ,@args))
-	     (:eval `(error 'simple-program-error
-		      :format-control ,control
-		      :format-arguments (list ,@args))))))
-    `(lambda (definition)
+	     (:compile (apply #'compiler-error control args))
+	     (:eval (error 'simple-program-error
+                           :format-control control
+                           :format-arguments 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)
-         ,(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))
-	   ,(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)
+        (fail "malformed symbol/expansion pair: ~S" definition))
+      (destructuring-bind (name expansion) definition
+        (unless (symbolp name)
+          (fail "The local symbol macro name ~S is not a symbol." name))
+        (let ((kind (info :variable :kind name)))
+          (when (member kind '(:special :constant))
+            (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
+                  kind name)))
+        `(,name . (MACRO . ,expansion))))))
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun context)
   (%funcall-in-foomacrolet-lexenv
-   (symbol-macrolet-definitionize-fun :compile)
+   (symbol-macrolet-definitionize-fun context)
    :vars
    definitions
    fun))
@@ -348,7 +344,8 @@
   (funcall-in-symbol-macrolet-lexenv
    macrobindings
    (lambda (&key vars)
-     (ir1-translate-locally body start cont :vars vars))))
+     (ir1-translate-locally body start cont :vars vars))
+   :compile))
 
 ;;;; %PRIMITIVE
 ;;;;
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 4e0ba72..79e0c45 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -1172,7 +1172,8 @@
                          (declare (ignore funs))
                          (process-toplevel-locally body
                                                    path
-                                                   compile-time-too))))
+                                                   compile-time-too))
+                       :compile))
                      ((symbol-macrolet)
                       (funcall-in-symbol-macrolet-lexenv
                        magic
@@ -1180,7 +1181,8 @@
                          (process-toplevel-locally body
                                                    path
                                                    compile-time-too
-                                                   :vars vars)))))))
+                                                   :vars vars))
+                       :compile)))))
                 ((locally)
                  (process-toplevel-locally (rest form) path compile-time-too))
                 ((progn)
diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp
index 8b0cf57..3f7aa88 100644
--- a/tests/eval.impure.lisp
+++ b/tests/eval.impure.lisp
@@ -18,6 +18,9 @@
 
 (cl:in-package :cl-user)
 
+(load "assertoid.lisp")
+(use-package "ASSERTOID")
+
 ;;; Until sbcl-0.7.9.x, EVAL was not correctly treating LOCALLY,
 ;;; MACROLET and SYMBOL-MACROLET, which should preserve top-levelness
 ;;; of their body forms:
@@ -105,5 +108,13 @@
                               ,var))
                  '(1 2))))
 
+;;; Bug 264: SYMBOL-MACROLET did not check for a bound SPECIAL
+;;; declaration
+(assert (raises-error? (progv '(foo) '(1)
+                         (eval '(symbol-macrolet ((foo 3))
+                                 (declare (special foo))
+                                 foo)))
+                       error))
+
 ;;; success
 (sb-ext:quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index 94bd4f2..d1a92f9 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.1.36"
+"0.8.1.37"
-- 
1.7.10.4