1.0.29.5: list item seek transform needs to check for both :TEST and :TEST-NOT

[sbcl.git] / src / code / full-eval.lisp

diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp
index 56208a0..00e4e33 100644 (file)
--- a/src/code/full-eval.lisp
+++ b/src/code/full-eval.lisp
@@ -185,13 +185,13 @@
 
 ;;; Augment ENV with a local function binding
 (declaim (inline push-fun))
 
 ;;; Augment ENV with a local function binding
 (declaim (inline push-fun))

-(defun push-fun (name value env)
+(defun push-fun (name value calling-env body-env)

   (when (fboundp name)
   (when (fboundp name)

-    (let ((sb!c:*lexenv* (env-native-lexenv env)))
+    (let ((sb!c:*lexenv* (env-native-lexenv calling-env)))

       (program-assert-symbol-home-package-unlocked
        :eval name "binding ~A as a local function")))
       (program-assert-symbol-home-package-unlocked
        :eval name "binding ~A as a local function")))

-  (push (cons name value) (env-funs env))
-  (push (cons name :bogus) (sb!c::lexenv-funs (env-native-lexenv env))))
+  (push (cons name value) (env-funs body-env))
+  (push (cons name :bogus) (sb!c::lexenv-funs (env-native-lexenv body-env))))

 
 (sb!int:def!method print-object ((env env) stream)
   (print-unreadable-object (env stream :type t :identity t)))
 
 (sb!int:def!method print-object ((env env) stream)
   (print-unreadable-object (env stream :type t :identity t)))

@@ -236,7 +236,10 @@
     (cond
       ((eq type :constant)
        ;; Horrible place for this, but it works.
     (cond
       ((eq type :constant)
        ;; Horrible place for this, but it works.

-       (ip-error "Can't bind constant symbol ~S" symbol))
+       (ip-error "Can't bind constant symbol: ~S" symbol))
+      ((eq type :global)
+       ;; Ditto...
+       (ip-error "Can't bind a global variable: ~S" symbol))

       ((eq type :special) t)
       ((member symbol declared-specials :test #'eq)
        t)
       ((eq type :special) t)
       ((member symbol declared-specials :test #'eq)
        t)

@@ -279,7 +282,8 @@
 (defun parse-arguments (arguments lambda-list)
   (multiple-value-bind (required optional rest-p rest keyword-p
                         keyword allow-other-keys-p aux-p aux)
 (defun parse-arguments (arguments lambda-list)
   (multiple-value-bind (required optional rest-p rest keyword-p
                         keyword allow-other-keys-p aux-p aux)

-      (sb!int:parse-lambda-list lambda-list)
+      (handler-bind ((style-warning #'muffle-warning))
+        (sb!int:parse-lambda-list lambda-list))

     (let* ((original-arguments arguments)
            (arguments-present (length arguments))
            (required-length (length required))
     (let* ((original-arguments arguments)
            (arguments-present (length arguments))
            (required-length (length required))

@@ -681,6 +685,8 @@
           (push-fun (car function-def)
                     ;; Evaluate the function definitions in ENV.
                     (eval-local-function-def function-def env)
           (push-fun (car function-def)
                     ;; Evaluate the function definitions in ENV.
                     (eval-local-function-def function-def env)

+                    ;; Do package-lock checks in ENV.
+                    env

                     ;; But add the bindings to the child environment.
                     new-env))
         (eval-progn body new-env)))))
                     ;; But add the bindings to the child environment.
                     new-env))
         (eval-progn body new-env)))))

@@ -697,6 +703,7 @@
         (dolist (function-def local-functions)
           (push-fun (car function-def)
                     (eval-local-function-def function-def env)
         (dolist (function-def local-functions)
           (push-fun (car function-def)
                     (eval-local-function-def function-def env)

+                    old-env

                     env))
         ;; And then add an environment for the body of the LABELS.  A
         ;; separate environment from the one where we added the
                     env))
         ;; And then add an environment for the body of the LABELS.  A
         ;; separate environment from the one where we added the

@@ -893,7 +900,8 @@
          (do ((form body (cdr form)))
              ((null form) nil)
            (when (atom (car form))
          (do ((form body (cdr form)))
              ((null form) nil)
            (when (atom (car form))

-             ;; FIXME: detect duplicate tags
+             (when (assoc (car form) tags)
+               (ip-error "The tag :A appears more than once in a tagbody."))

              (push (cons (car form) (cdr form)) tags)
              (push (cons (car form) #'go-to-tag) (env-tags env)))))
        ;; And then evaluate the forms in the body, starting from the
              (push (cons (car form) (cdr form)) tags)
              (push (cons (car form) #'go-to-tag) (env-tags env)))))
        ;; And then evaluate the forms in the body, starting from the

@@ -1199,11 +1207,6 @@
           (%eval form env))
       (compiler-environment-too-complex-error (condition)
         (declare (ignore condition))
           (%eval form env))
       (compiler-environment-too-complex-error (condition)
         (declare (ignore condition))

-        ;; FIXME: this could be a really annoying warning. It should
-        ;; have its own class.
-        (sb!int:style-warn
-         "~@<Native lexical environment too complex for SB-EVAL ~
-       to evaluate ~S, falling back to SIMPLE-EVAL-IN-LEXENV.  ~
-       Lexenv: ~S~:@>"
-         form lexenv)
+        (sb!int:style-warn 'sb!kernel:lexical-environment-too-complex
+                           :form form :lexenv lexenv)

         (sb!int:simple-eval-in-lexenv form lexenv)))))
         (sb!int:simple-eval-in-lexenv form lexenv)))))