1.0.31.5: WITH-SLOTS on THE forms

[sbcl.git] / src / pcl / boot.lisp

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 12467fa..8deb6c8 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -2208,6 +2208,43 @@ bootstrapping.
                      method-class)
                     (t (find-class method-class t ,env))))))))
 
+(defun note-gf-signature (fun-name lambda-list-p lambda-list)
+  (unless lambda-list-p
+    ;; Use the existing lambda-list, if any. It is reasonable to do eg.
+    ;;
+    ;;   (if (fboundp name)
+    ;;       (ensure-generic-function name)
+    ;;       (ensure-generic-function name :lambda-list '(foo)))
+    ;;
+    ;; in which case we end up here with no lambda-list in the first leg.
+    (setf (values lambda-list lambda-list-p)
+          (handler-case
+              (values (generic-function-lambda-list (fdefinition fun-name))
+                      t)
+            ((or warning error) ()
+              (values nil nil)))))
+  (let ((gf-type
+         (specifier-type
+          (if lambda-list-p
+              (ftype-declaration-from-lambda-list lambda-list fun-name)
+              'function)))
+        (old-type nil))
+    ;; FIXME: Ideally we would like to not clobber it, but because generic
+    ;; functions assert their FTYPEs callers believing the FTYPE are left with
+    ;; unsafe assumptions. Hence the clobbering. Be quiet when the new type
+    ;; is a subtype of the old one, though -- even though the type is not
+    ;; trusted anymore, the warning is still not quite as interesting.
+    (when (and (eq :declared (info :function :where-from fun-name))
+               (not (csubtypep gf-type (setf old-type (info :function :type fun-name)))))
+      (style-warn "~@<Generic function ~S clobbers an earlier ~S proclamation ~S ~
+                   for the same name with ~S.~:@>"
+                  fun-name 'ftype
+                  (type-specifier old-type)
+                  (type-specifier gf-type)))
+    (setf (info :function :type fun-name) gf-type
+          (info :function :where-from fun-name) :defined-method)
+    fun-name))
+
 (defun real-ensure-gf-using-class--generic-function
        (existing
         fun-name
@@ -2222,11 +2259,7 @@ bootstrapping.
     (change-class existing generic-function-class))
   (prog1
       (apply #'reinitialize-instance existing all-keys)
-    (when lambda-list-p
-      (setf (info :function :type fun-name)
-            (specifier-type
-             (ftype-declaration-from-lambda-list lambda-list fun-name))
-            (info :function :where-from fun-name) :defined-method))))
+    (note-gf-signature fun-name lambda-list-p lambda-list)))
 
 (defun real-ensure-gf-using-class--null
        (existing
@@ -2241,11 +2274,7 @@ bootstrapping.
       (setf (gdefinition fun-name)
             (apply #'make-instance generic-function-class
                    :name fun-name all-keys))
-    (when lambda-list-p
-      (setf (info :function :type fun-name)
-            (specifier-type
-             (ftype-declaration-from-lambda-list lambda-list fun-name))
-            (info :function :where-from fun-name) :defined-method))))
+    (note-gf-signature fun-name lambda-list-p lambda-list)))
 \f
 (defun safe-gf-arg-info (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
@@ -2695,7 +2724,7 @@ bootstrapping.
 
 (defun extract-the (form)
   (cond ((and (consp form) (eq (car form) 'the))
-         (aver (proper-list-of-length-p 3))
+         (aver (proper-list-of-length-p form 3))
          (third form))
         (t
          form)))