X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=4c08cd7c819d74905664c8e197b0a0e09a16e103;hb=35f870eecfcaaba496d54e0f290b09e63884f74c;hp=74cba285fdec75c2fd01d6d659b847d530c4c721;hpb=f68d0f59fa6f9c448b3a147b5940937af03f940a;p=sbcl.git

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 74cba28..4c08cd7 100644
--- 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)
@@ -979,6 +978,13 @@
                                   definition
                                   :source-name name)))
            (debug-name (debug-name 'tl-xep name))
+           ;; 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)))
@@ -986,6 +992,7 @@
         (assert-global-function-definition-type name locall-fun))
       (setf (functional-entry-fun fun) locall-fun
             (functional-kind fun) :external
+            (functional-has-external-references-p locall-fun) t
             (functional-has-external-references-p fun) t)
       fun)))
 
@@ -1015,6 +1022,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)))
@@ -1029,14 +1037,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
@@ -1388,10 +1392,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))
@@ -1402,7 +1406,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)
@@ -1497,6 +1501,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))