1.0.4.31: remove *internal-error-context*

[sbcl.git] / src / compiler / main.lisp

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index d13e07d..d77ff04 100644 (file)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -37,7 +37,6 @@
 (defvar *flame-on-necessarily-undefined-function* nil)
 
 (defvar *check-consistency* nil)
-(defvar *all-components*)
 
 ;;; Set to NIL to disable loop analysis for register allocation.
 (defvar *loop-analyze* t)
@@ -978,7 +977,16 @@
                          (funcall #'ir1-convert-lambdalike
                                   definition
                                   :source-name name)))
-           (debug-name (debug-name 'tl-xep name))
+           (debug-name (debug-name 'tl-xep
+                                   (or name
+                                       (functional-%source-name locall-fun))))
+           ;; Convert the XEP using the policy of the real
+           ;; function. Otherwise the wrong policy will be used for
+           ;; deciding whether to type-check the parameters of the
+           ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS).
+           ;; -- JES, 2007-02-27
+           (*lexenv* (make-lexenv :policy (lexenv-policy
+                                           (functional-lexenv locall-fun))))
            (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
                                     :source-name (or name '.anonymous.)
                                     :debug-name debug-name)))
@@ -1016,6 +1024,7 @@
                     :policy *policy*
                     :handled-conditions *handled-conditions*
                     :disabled-package-locks *disabled-package-locks*))
+         (*compiler-sset-counter* 0)
          (fun (make-functional-from-toplevel-lambda lambda-expression
                                                     :name name
                                                     :path path)))
@@ -1030,14 +1039,10 @@
 
     (locall-analyze-clambdas-until-done (list fun))
 
-    (multiple-value-bind (components-from-dfo top-components hairy-top)
-        (find-initial-dfo (list fun))
-      (declare (ignore hairy-top))
-
-      (let ((*all-components* (append components-from-dfo top-components)))
-        (dolist (component-from-dfo components-from-dfo)
-          (compile-component component-from-dfo)
-          (replace-toplevel-xeps component-from-dfo)))
+    (let ((components-from-dfo (find-initial-dfo (list fun))))
+      (dolist (component-from-dfo components-from-dfo)
+        (compile-component component-from-dfo)
+        (replace-toplevel-xeps component-from-dfo))
 
       (let ((entry-table (etypecase *compile-object*
                            (fasl-output (fasl-output-entry-table
@@ -1389,10 +1394,10 @@
   (maybe-mumble "IDFO ")
   (multiple-value-bind (components top-components hairy-top)
       (find-initial-dfo lambdas)
-    (let ((*all-components* (append components top-components)))
+    (let ((all-components (append components top-components)))
       (when *check-consistency*
         (maybe-mumble "[check]~%")
-        (check-ir1-consistency *all-components*))
+        (check-ir1-consistency all-components))
 
       (dolist (component (append hairy-top top-components))
         (pre-physenv-analyze-toplevel component))
@@ -1403,7 +1408,7 @@
 
       (when *check-consistency*
         (maybe-mumble "[check]~%")
-        (check-ir1-consistency *all-components*))
+        (check-ir1-consistency all-components))
 
       (if load-time-value-p
           (compile-load-time-value-lambda lambdas)
@@ -1498,6 +1503,7 @@
         ;; and it's not obvious whether the rebinding to itself is
         ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
         (*info-environment* *info-environment*)
+        (*compiler-sset-counter* 0)
         (*gensym-counter* 0))
     (handler-case
         (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
@@ -1519,8 +1525,8 @@
       ;; the input file.
       (fatal-compiler-error (condition)
        (signal condition)
-       (when *compile-verbose*
-         (format *standard-output*
+       (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+         (format *error-output*
                  "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
                  condition))
        (values nil t t)))))