0.pre7.86.flaky7.2:

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

diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp
index 8f8cb16..50e9cc2 100644 (file)
--- a/src/compiler/ir1final.lisp
+++ b/src/compiler/ir1final.lisp
@@ -52,58 +52,51 @@
           ))))))
 
 ;;; For each named function with an XEP, note the definition of that
-;;; name, and add derived type information to the info environment. We
+;;; name, and add derived type information to the INFO environment. We
 ;;; also delete the FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the
 ;;; possibility that new references might be converted to it.
 (defun finalize-xep-definition (fun)
-  (let* ((leaf (functional-entry-function fun))
-        (name (leaf-name leaf))
-        (dtype (definition-type leaf)))
-    (setf (leaf-type leaf) dtype)
-    (when (or (and name (symbolp name))
-             (and (consp name) (eq (car name) 'setf)))
-      (let* ((where (info :function :where-from name))
-            (*compiler-error-context* (lambda-bind (main-entry leaf)))
-            (global-def (gethash name *free-functions*))
-            (global-p (defined-function-p global-def)))
-       (note-name-defined name :function)
-       (when global-p
-         (remhash name *free-functions*))
-       (ecase where
-         (:assumed
-          (let ((approx-type (info :function :assumed-type name)))
-            (when (and approx-type (function-type-p dtype))
-              (valid-approximate-type approx-type dtype))
-            (setf (info :function :type name) dtype)
-            (setf (info :function :assumed-type name) nil))
-          (setf (info :function :where-from name) :defined))
-         (:declared
-          ;; Check that derived type matches declared type.
-          (let ((type (info :function :type name)))
-             (when (and type (function-type-p dtype))
-               (let ((type-returns (function-type-returns type))
-                     (dtype-returns (function-type-returns dtype))
-                     (*error-function* #'compiler-warning))
-                 (unless (values-types-equal-or-intersect type-returns
-                                                         dtype-returns)
-                   (note-lossage "The result type from previous declaration:~%  ~S~@
-                                  conflicts with the result type:~%  ~S"
-                                 (type-specifier type-returns)
-                                 (type-specifier dtype-returns))))))
-          ;; (Regardless of what happens, we keep the declared type.)
-          )
-         (:defined
-           (when global-p
-             (setf (info :function :type name) dtype)))))))
+  (let* ((leaf (functional-entry-fun fun))
+        (defined-ftype (definition-type leaf)))
+    (setf (leaf-type leaf) defined-ftype)
+    (when (leaf-has-source-name-p leaf)
+      (let ((source-name (leaf-source-name leaf)))
+       (let* ((where (info :function :where-from source-name))
+              (*compiler-error-context* (lambda-bind (main-entry leaf)))
+              (global-def (gethash source-name *free-functions*))
+              (global-p (defined-fun-p global-def)))
+         (note-name-defined source-name :function)
+         (when global-p
+           (remhash source-name *free-functions*))
+         (ecase where
+           (:assumed
+            (let ((approx-type (info :function :assumed-type source-name)))
+              (when (and approx-type (fun-type-p defined-ftype))
+                (valid-approximate-type approx-type defined-ftype))
+              (setf (info :function :type source-name) defined-ftype)
+              (setf (info :function :assumed-type source-name) nil))
+            (setf (info :function :where-from source-name) :defined))
+           (:declared
+            (let ((declared-ftype (info :function :type source-name)))
+              (unless (defined-ftype-matches-declared-ftype-p
+                        defined-ftype declared-ftype)
+                (note-lossage "~@<The previously declared FTYPE~2I ~_~S~I ~_~
+                              conflicts with the definition type ~2I~_~S~:>"
+                              (type-specifier declared-ftype)
+                              (type-specifier defined-ftype)))))
+           (:defined
+            (when global-p
+              (setf (info :function :type source-name) defined-ftype))))))))
   (values))
 
-;;; Find all calls in Component to assumed functions and update the assumed
-;;; type information. This is delayed until now so that we have the best
-;;; possible information about the actual argument types.
+;;; Find all calls in COMPONENT to assumed functions and update the
+;;; assumed type information. This is delayed until now so that we
+;;; have the best possible information about the actual argument
+;;; types.
 (defun note-assumed-types (component name var)
   (when (and (eq (leaf-where-from var) :assumed)
-            (not (and (defined-function-p var)
-                      (eq (defined-function-inlinep var) :notinline)))
+            (not (and (defined-fun-p var)
+                      (eq (defined-fun-inlinep var) :notinline)))
             (eq (info :function :where-from name) :assumed)
             (eq (info :function :kind name) :function))
     (let ((atype (info :function :assumed-type name)))
@@ -115,8 +108,8 @@
            (setq atype (note-function-use dest atype)))))
       (setf (info :function :assumed-type name) atype))))
 
-;;; Do miscellaneous things that we want to do once all optimization has
-;;; been done:
+;;; Do miscellaneous things that we want to do once all optimization
+;;; has been done:
 ;;;  -- Record the derived result type before the back-end trashes the
 ;;;     flow graph.
 ;;;  -- Note definition of any entry points.