1.0.32.10: fix timer starvation caused by setting the system clock back

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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 47e270a..e9eb7a6 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -252,8 +252,9 @@ bootstrapping.
 
 (defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
   (when (fboundp fun-name)
 
 (defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
   (when (fboundp fun-name)

-    (style-warn "redefining ~S in DEFGENERIC" fun-name)

     (let ((fun (fdefinition fun-name)))
     (let ((fun (fdefinition fun-name)))

+      (warn 'sb-kernel:redefinition-with-defgeneric :name fun-name
+            :old fun :new-location source-location)

       (when (generic-function-p fun)
         (loop for method in (generic-function-initial-methods fun)
               do (remove-method fun method))
       (when (generic-function-p fun)
         (loop for method in (generic-function-initial-methods fun)
               do (remove-method fun method))

@@ -352,7 +353,7 @@ bootstrapping.
 
 
 (defun prototypes-for-make-method-lambda (name)
 
 
 (defun prototypes-for-make-method-lambda (name)

-  (if (not (eq *boot-state* 'complete))
+  (if (not (eq **boot-state** 'complete))

       (values nil nil)
       (let ((gf? (and (fboundp name)
                       (gdefinition name))))
       (values nil nil)
       (let ((gf? (and (fboundp name)
                       (gdefinition name))))

@@ -378,7 +379,7 @@ bootstrapping.
 (defun method-prototype-for-gf (name)
   (let ((gf? (and (fboundp name)
                   (gdefinition name))))
 (defun method-prototype-for-gf (name)
   (let ((gf? (and (fboundp name)
                   (gdefinition name))))

-    (cond ((neq *boot-state* 'complete) nil)
+    (cond ((neq **boot-state** 'complete) nil)

           ((or (null gf?)
                (not (generic-function-p gf?)))          ; Someone else MIGHT
                                                         ; error at load time.
           ((or (null gf?)
                (not (generic-function-p gf?)))          ; Someone else MIGHT
                                                         ; error at load time.

@@ -589,6 +590,12 @@ bootstrapping.
   (setf (gdefinition 'make-method-lambda)
         (symbol-function 'real-make-method-lambda)))
 
   (setf (gdefinition 'make-method-lambda)
         (symbol-function 'real-make-method-lambda)))
 

+(defun declared-specials (declarations)
+  (loop for (declare . specifiers) in declarations
+        append (loop for specifier in specifiers
+                     when (eq 'special (car specifier))
+                     append (cdr specifier))))
+

 (defun make-method-lambda-internal (proto-gf proto-method method-lambda env)
   (declare (ignore proto-gf proto-method))
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
 (defun make-method-lambda-internal (proto-gf proto-method method-lambda env)
   (declare (ignore proto-gf proto-method))
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))

@@ -640,9 +647,12 @@ bootstrapping.
                   ;; KLUDGE: when I tried moving these to
                   ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
                   ;; why.  -- CSR, 2004-06-16
                   ;; KLUDGE: when I tried moving these to
                   ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
                   ;; why.  -- CSR, 2004-06-16

-                  ,@(mapcar #'parameter-specializer-declaration-in-defmethod
-                            parameters
-                            specializers)))
+                  ,@(let ((specials (declared-specials declarations)))
+                      (mapcar (lambda (par spec)
+                                (parameter-specializer-declaration-in-defmethod
+                                 par spec specials env))
+                              parameters
+                              specializers))))

                (method-lambda
                 ;; Remove the documentation string and insert the
                 ;; appropriate class declarations. The documentation
                (method-lambda
                 ;; Remove the documentation string and insert the
                 ;; appropriate class declarations. The documentation

@@ -744,15 +754,21 @@ bootstrapping.
   (declare (ignore env proto-gf proto-method))
   (flet ((parse (name)
            (cond
   (declare (ignore env proto-gf proto-method))
   (flet ((parse (name)
            (cond

-             ((and (eq *boot-state* 'complete)
+             ((and (eq **boot-state** 'complete)

                    (specializerp name))
               name)
              ((symbolp name) `(find-class ',name))
              ((consp name) (ecase (car name)
                              ((eql) `(intern-eql-specializer ,(cadr name)))
                    (specializerp name))
               name)
              ((symbolp name) `(find-class ',name))
              ((consp name) (ecase (car name)
                              ((eql) `(intern-eql-specializer ,(cadr name)))

-                             ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))
-                             ((prototype) `(fixme))))
-             (t (bug "Foo")))))
+                             ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))))
+             (t
+              ;; FIXME: Document CLASS-EQ specializers.
+              (error 'simple-reference-error
+                     :format-control
+                     "~@<~S is not a valid parameter specializer name.~@:>"
+                     :format-arguments (list name)
+                     :references (list '(:ansi-cl :macro defmethod)
+                                       '(:ansi-cl :glossary "parameter specializer name")))))))

     `(list ,@(mapcar #'parse specializer-names))))
 
 (unless (fboundp 'make-method-specializers-form)
     `(list ,@(mapcar #'parse specializer-names))))
 
 (unless (fboundp 'make-method-specializers-form)

@@ -798,8 +814,12 @@ bootstrapping.
         (symbol-function 'real-unparse-specializer-using-class)))
 
 ;;; a helper function for creating Python-friendly type declarations
         (symbol-function 'real-unparse-specializer-using-class)))
 
 ;;; a helper function for creating Python-friendly type declarations

-;;; in DEFMETHOD forms
-(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
+;;; in DEFMETHOD forms.
+;;;
+;;; We're too lazy to cons up a new environment for this, so we just pass in
+;;; the list of locally declared specials in addition to the old environment.
+(defun parameter-specializer-declaration-in-defmethod
+    (parameter specializer specials env)

   (cond ((and (consp specializer)
               (eq (car specializer) 'eql))
          ;; KLUDGE: ANSI, in its wisdom, says that
   (cond ((and (consp specializer)
               (eq (car specializer) 'eql))
          ;; KLUDGE: ANSI, in its wisdom, says that

@@ -843,7 +863,7 @@ bootstrapping.
                  ;; cases by blacklisting them here. -- WHN 2001-01-19
                  (list 'slot-object #+nil (find-class 'slot-object)))
          '(ignorable))
                  ;; cases by blacklisting them here. -- WHN 2001-01-19
                  (list 'slot-object #+nil (find-class 'slot-object)))
          '(ignorable))

-        ((not (eq *boot-state* 'complete))
+        ((not (eq **boot-state** 'complete))

          ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
          ;; types which don't match their specializers. (Specifically,
          ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL
          ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
          ;; types which don't match their specializers. (Specifically,
          ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL

@@ -852,16 +872,10 @@ bootstrapping.
          '(ignorable))
         ((typep specializer 'eql-specializer)
          `(type (eql ,(eql-specializer-object specializer)) ,parameter))
          '(ignorable))
         ((typep specializer 'eql-specializer)
          `(type (eql ,(eql-specializer-object specializer)) ,parameter))

-        ((var-globally-special-p parameter)
-         ;; KLUDGE: Don't declare types for global special variables
-         ;; -- our rebinding magic for SETQ cases don't work right
-         ;; there.
-         ;;
-         ;; FIXME: It would be better to detect the SETQ earlier and
-         ;; skip declarations for specials only when needed, not
-         ;; always.
-         ;;
-         ;; --NS 2004-10-14
+        ((or (var-special-p parameter env) (member parameter specials))
+         ;; Don't declare types for special variables -- our rebinding magic
+         ;; for SETQ cases don't work right there as SET, (SETF SYMBOL-VALUE),
+         ;; etc. make things undecidable.

          '(ignorable))
         (t
          ;; Otherwise, we can usually make Python very happy.
          '(ignorable))
         (t
          ;; Otherwise, we can usually make Python very happy.

@@ -1535,7 +1549,7 @@ bootstrapping.
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)
        (fboundp name)
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)
        (fboundp name)

-       (if (eq *boot-state* 'complete)
+       (if (eq **boot-state** 'complete)

            (standard-generic-function-p (gdefinition name))
            (funcallable-instance-p (gdefinition name)))))
 \f
            (standard-generic-function-p (gdefinition name))
            (funcallable-instance-p (gdefinition name)))))
 \f

@@ -1565,15 +1579,17 @@ bootstrapping.
 (defun load-defmethod-internal
     (method-class gf-spec qualifiers specializers lambda-list
                   initargs source-location)
 (defun load-defmethod-internal
     (method-class gf-spec qualifiers specializers lambda-list
                   initargs source-location)

-  (when (and (eq *boot-state* 'complete)
+  (when (and (eq **boot-state** 'complete)

              (fboundp gf-spec))
     (let* ((gf (fdefinition gf-spec))
            (method (and (generic-function-p gf)
                         (generic-function-methods gf)
                         (find-method gf qualifiers specializers nil))))
       (when method
              (fboundp gf-spec))
     (let* ((gf (fdefinition gf-spec))
            (method (and (generic-function-p gf)
                         (generic-function-methods gf)
                         (find-method gf qualifiers specializers nil))))
       (when method

-        (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
-                    gf-spec qualifiers specializers))))
+        (style-warn 'sb-kernel:redefinition-with-defmethod
+                    :generic-function gf-spec :old-method method
+                    :qualifiers qualifiers :specializers specializers
+                    :new-location source-location))))

   (let ((method (apply #'add-named-method
                        gf-spec qualifiers specializers lambda-list
                        :definition-source source-location
   (let ((method (apply #'add-named-method
                        gf-spec qualifiers specializers lambda-list
                        :definition-source source-location

@@ -1698,9 +1714,6 @@ bootstrapping.
                                     (when (or allow-other-keys-p old-allowp)
                                       '(&allow-other-keys)))))
                  *))))
                                     (when (or allow-other-keys-p old-allowp)
                                       '(&allow-other-keys)))))
                  *))))

-
-(defun defgeneric-declaration (spec lambda-list)
-  `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))

 \f
 ;;;; early generic function support
 
 \f
 ;;;; early generic function support
 

@@ -1714,7 +1727,7 @@ bootstrapping.
   (let ((existing (and (fboundp fun-name)
                        (gdefinition fun-name))))
     (cond ((and existing
   (let ((existing (and (fboundp fun-name)
                        (gdefinition fun-name))))
     (cond ((and existing

-                (eq *boot-state* 'complete)
+                (eq **boot-state** 'complete)

                 (null (generic-function-p existing)))
            (generic-clobbers-function fun-name)
            (fmakunbound fun-name)
                 (null (generic-function-p existing)))
            (generic-clobbers-function fun-name)
            (fmakunbound fun-name)

@@ -1743,32 +1756,32 @@ bootstrapping.
                       +slot-unbound+))))
           (early-collect-inheritance 'standard-generic-function)))
 
                       +slot-unbound+))))
           (early-collect-inheritance 'standard-generic-function)))
 

-(defvar *sgf-method-class-index*
+(defconstant +sgf-method-class-index+

   (!bootstrap-slot-index 'standard-generic-function 'method-class))
 
 (defun early-gf-p (x)
   (and (fsc-instance-p x)
   (!bootstrap-slot-index 'standard-generic-function 'method-class))
 
 (defun early-gf-p (x)
   (and (fsc-instance-p x)

-       (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*)
+       (eq (clos-slots-ref (get-slots x) +sgf-method-class-index+)

            +slot-unbound+)))
 
            +slot-unbound+)))
 

-(defvar *sgf-methods-index*
+(defconstant +sgf-methods-index+

   (!bootstrap-slot-index 'standard-generic-function 'methods))
 
 (defmacro early-gf-methods (gf)
   (!bootstrap-slot-index 'standard-generic-function 'methods))
 
 (defmacro early-gf-methods (gf)

-  `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
+  `(clos-slots-ref (get-slots ,gf) +sgf-methods-index+))

 
 (defun safe-generic-function-methods (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
 
 (defun safe-generic-function-methods (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)

-      (clos-slots-ref (get-slots generic-function) *sgf-methods-index*)
+      (clos-slots-ref (get-slots generic-function) +sgf-methods-index+)

       (generic-function-methods generic-function)))
 
       (generic-function-methods generic-function)))
 

-(defvar *sgf-arg-info-index*
+(defconstant +sgf-arg-info-index+

   (!bootstrap-slot-index 'standard-generic-function 'arg-info))
 
 (defmacro early-gf-arg-info (gf)
   (!bootstrap-slot-index 'standard-generic-function 'arg-info))
 
 (defmacro early-gf-arg-info (gf)

-  `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
+  `(clos-slots-ref (get-slots ,gf) +sgf-arg-info-index+))

 
 

-(defvar *sgf-dfun-state-index*
+(defconstant +sgf-dfun-state-index+

   (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
 
 (defstruct (arg-info
   (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
 
 (defstruct (arg-info

@@ -1814,10 +1827,10 @@ bootstrapping.
 
 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
                         argument-precedence-order)
 
 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
                         argument-precedence-order)

-  (let* ((arg-info (if (eq *boot-state* 'complete)
+  (let* ((arg-info (if (eq **boot-state** 'complete)

                        (gf-arg-info gf)
                        (early-gf-arg-info gf)))
                        (gf-arg-info gf)
                        (early-gf-arg-info gf)))

-         (methods (if (eq *boot-state* 'complete)
+         (methods (if (eq **boot-state** 'complete)

                       (generic-function-methods gf)
                       (early-gf-methods gf)))
          (was-valid-p (integerp (arg-info-number-optional arg-info)))
                       (generic-function-methods gf)
                       (early-gf-methods gf)))
          (was-valid-p (integerp (arg-info-number-optional arg-info)))

@@ -1896,21 +1909,19 @@ bootstrapping.
                    ~S."
                   gf-keywords)))))))
 
                    ~S."
                   gf-keywords)))))))
 

-(defvar *sm-specializers-index*
+(defconstant +sm-specializers-index+

   (!bootstrap-slot-index 'standard-method 'specializers))
   (!bootstrap-slot-index 'standard-method 'specializers))

-(defvar *sm-%function-index*
+(defconstant +sm-%function-index+

   (!bootstrap-slot-index 'standard-method '%function))
   (!bootstrap-slot-index 'standard-method '%function))

-(defvar *sm-qualifiers-index*
+(defconstant +sm-qualifiers-index+

   (!bootstrap-slot-index 'standard-method 'qualifiers))
   (!bootstrap-slot-index 'standard-method 'qualifiers))

-(defvar *sm-plist-index*
-  (!bootstrap-slot-index 'standard-method 'plist))

 
 ;;; FIXME: we don't actually need this; we could test for the exact
 ;;; class and deal with it as appropriate.  In fact we probably don't
 ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
 ;;; the standard reader method for METHOD-SPECIALIZERS.  Probably.
 
 ;;; FIXME: we don't actually need this; we could test for the exact
 ;;; class and deal with it as appropriate.  In fact we probably don't
 ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
 ;;; the standard reader method for METHOD-SPECIALIZERS.  Probably.

-(dolist (s '(specializers %function plist))
-  (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
+(dolist (s '(specializers %function))
+  (aver (= (symbol-value (intern (format nil "+SM-~A-INDEX+" s)))

            (!bootstrap-slot-index 'standard-reader-method s)
            (!bootstrap-slot-index 'standard-writer-method s)
            (!bootstrap-slot-index 'standard-boundp-method s)
            (!bootstrap-slot-index 'standard-reader-method s)
            (!bootstrap-slot-index 'standard-writer-method s)
            (!bootstrap-slot-index 'standard-boundp-method s)

@@ -1918,34 +1929,31 @@ bootstrapping.
            (!bootstrap-slot-index 'global-writer-method s)
            (!bootstrap-slot-index 'global-boundp-method s))))
 
            (!bootstrap-slot-index 'global-writer-method s)
            (!bootstrap-slot-index 'global-boundp-method s))))
 

-(define-symbol-macro *standard-method-classes*
-  (list *the-class-standard-method* *the-class-standard-reader-method*
-        *the-class-standard-writer-method* *the-class-standard-boundp-method*
-        *the-class-global-reader-method* *the-class-global-writer-method*
-        *the-class-global-boundp-method*))
+(defvar *standard-method-class-names*
+  '(standard-method standard-reader-method
+    standard-writer-method standard-boundp-method
+    global-reader-method global-writer-method
+    global-boundp-method))
+
+(declaim (list **standard-method-classes**))
+(defglobal **standard-method-classes** nil)

 
 (defun safe-method-specializers (method)
 
 (defun safe-method-specializers (method)

-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-specializers-index*)
-        (method-specializers method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-specializers-index+)
+      (method-specializers method)))

 (defun safe-method-fast-function (method)
   (let ((mf (safe-method-function method)))
     (and (typep mf '%method-function)
          (%method-function-fast-function mf))))
 (defun safe-method-function (method)
 (defun safe-method-fast-function (method)
   (let ((mf (safe-method-function method)))
     (and (typep mf '%method-function)
          (%method-function-fast-function mf))))
 (defun safe-method-function (method)

-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-%function-index*)
-        (method-function method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-%function-index+)
+      (method-function method)))

 (defun safe-method-qualifiers (method)
 (defun safe-method-qualifiers (method)

-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
-        (method-qualifiers method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-qualifiers-index+)
+      (method-qualifiers method)))

 
 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
   (let* ((existing-p (and methods (cdr methods) new-method))
 
 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
   (let* ((existing-p (and methods (cdr methods) new-method))

@@ -1958,16 +1966,16 @@ bootstrapping.
                    nil)))
     (when (arg-info-valid-p arg-info)
       (dolist (method (if new-method (list new-method) methods))
                    nil)))
     (when (arg-info-valid-p arg-info)
       (dolist (method (if new-method (list new-method) methods))

-        (let* ((specializers (if (or (eq *boot-state* 'complete)
+        (let* ((specializers (if (or (eq **boot-state** 'complete)

                                      (not (consp method)))
                                  (safe-method-specializers method)
                                  (early-method-specializers method t)))
                                      (not (consp method)))
                                  (safe-method-specializers method)
                                  (early-method-specializers method t)))

-               (class (if (or (eq *boot-state* 'complete) (not (consp method)))
+               (class (if (or (eq **boot-state** 'complete) (not (consp method)))

                           (class-of method)
                           (early-method-class method)))
                (new-type
                 (when (and class
                           (class-of method)
                           (early-method-class method)))
                (new-type
                 (when (and class

-                           (or (not (eq *boot-state* 'complete))
+                           (or (not (eq **boot-state** 'complete))

                                (eq (generic-function-method-combination gf)
                                    *standard-method-combination*)))
                   (cond ((or (eq class *the-class-standard-reader-method*)
                                (eq (generic-function-method-combination gf)
                                    *standard-method-combination*)))
                   (cond ((or (eq class *the-class-standard-reader-method*)

@@ -1995,7 +2003,7 @@ bootstrapping.
       (unless (gf-info-c-a-m-emf-std-p arg-info)
         (setf (gf-info-simple-accessor-type arg-info) t))))
   (unless was-valid-p
       (unless (gf-info-c-a-m-emf-std-p arg-info)
         (setf (gf-info-simple-accessor-type arg-info) t))))
   (unless was-valid-p

-    (let ((name (if (eq *boot-state* 'complete)
+    (let ((name (if (eq **boot-state** 'complete)

                     (generic-function-name gf)
                     (!early-gf-name gf))))
       (setf (gf-precompute-dfun-and-emf-p arg-info)
                     (generic-function-name gf)
                     (!early-gf-name gf))))
       (setf (gf-precompute-dfun-and-emf-p arg-info)

@@ -2016,7 +2024,7 @@ bootstrapping.
                         ;; remain.
                         (not (find #\Space (symbol-name symbol))))))))))
   (setf (gf-info-fast-mf-p arg-info)
                         ;; remain.
                         (not (find #\Space (symbol-name symbol))))))))))
   (setf (gf-info-fast-mf-p arg-info)

-        (or (not (eq *boot-state* 'complete))
+        (or (not (eq **boot-state** 'complete))

             (let* ((method-class (generic-function-method-class gf))
                    (methods (compute-applicable-methods
                              #'make-method-lambda
             (let* ((method-class (generic-function-method-class gf))
                    (methods (compute-applicable-methods
                              #'make-method-lambda

@@ -2093,7 +2101,10 @@ bootstrapping.
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)
       (when lambda-list-p
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)
       (when lambda-list-p

-        (proclaim (defgeneric-declaration spec lambda-list))
+        (setf (info :function :type spec)
+              (specifier-type
+               (ftype-declaration-from-lambda-list lambda-list spec))
+              (info :function :where-from spec) :defined-method)

         (if argument-precedence-order
             (set-arg-info fin
                           :lambda-list lambda-list
         (if argument-precedence-order
             (set-arg-info fin
                           :lambda-list lambda-list

@@ -2103,12 +2114,12 @@ bootstrapping.
 
 (defun safe-gf-dfun-state (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
 
 (defun safe-gf-dfun-state (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)

-      (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*)
+      (clos-slots-ref (fsc-instance-slots generic-function) +sgf-dfun-state-index+)

       (gf-dfun-state generic-function)))
 (defun (setf safe-gf-dfun-state) (new-value generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
       (gf-dfun-state generic-function)))
 (defun (setf safe-gf-dfun-state) (new-value generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)

-      (setf (clos-slots-ref (get-slots generic-function)
-                            *sgf-dfun-state-index*)
+      (setf (clos-slots-ref (fsc-instance-slots generic-function)
+                            +sgf-dfun-state-index+)

             new-value)
       (setf (gf-dfun-state generic-function) new-value)))
 
             new-value)
       (setf (gf-dfun-state generic-function) new-value)))
 

@@ -2117,44 +2128,44 @@ bootstrapping.
                        (list* dfun cache info)
                        dfun)))
     (cond
                        (list* dfun cache info)
                        dfun)))
     (cond

-      ((eq *boot-state* 'complete)
+      ((eq **boot-state** 'complete)

        ;; Check that we are under the lock.
        #+sb-thread
        (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
        (setf (safe-gf-dfun-state gf) new-state))
       (t
        ;; Check that we are under the lock.
        #+sb-thread
        (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
        (setf (safe-gf-dfun-state gf) new-state))
       (t

-       (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
+       (setf (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)

              new-state))))
   dfun)
 
 (defun gf-dfun-cache (gf)
              new-state))))
   dfun)
 
 (defun gf-dfun-cache (gf)

-  (let ((state (if (eq *boot-state* 'complete)
+  (let ((state (if (eq **boot-state** 'complete)

                    (safe-gf-dfun-state gf)
                    (safe-gf-dfun-state gf)

-                   (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
+                   (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+))))

     (typecase state
       (function nil)
       (cons (cadr state)))))
 
 (defun gf-dfun-info (gf)
     (typecase state
       (function nil)
       (cons (cadr state)))))
 
 (defun gf-dfun-info (gf)

-  (let ((state (if (eq *boot-state* 'complete)
+  (let ((state (if (eq **boot-state** 'complete)

                    (safe-gf-dfun-state gf)
                    (safe-gf-dfun-state gf)

-                   (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
+                   (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+))))

     (typecase state
       (function nil)
       (cons (cddr state)))))
 
     (typecase state
       (function nil)
       (cons (cddr state)))))
 

-(defvar *sgf-name-index*
+(defconstant +sgf-name-index+

   (!bootstrap-slot-index 'standard-generic-function 'name))
 
 (defun !early-gf-name (gf)
   (!bootstrap-slot-index 'standard-generic-function 'name))
 
 (defun !early-gf-name (gf)

-  (clos-slots-ref (get-slots gf) *sgf-name-index*))
+  (clos-slots-ref (get-slots gf) +sgf-name-index+))

 
 (defun gf-lambda-list (gf)
 
 (defun gf-lambda-list (gf)

-  (let ((arg-info (if (eq *boot-state* 'complete)
+  (let ((arg-info (if (eq **boot-state** 'complete)

                       (gf-arg-info gf)
                       (early-gf-arg-info gf))))
     (if (eq :no-lambda-list (arg-info-lambda-list arg-info))
                       (gf-arg-info gf)
                       (early-gf-arg-info gf))))
     (if (eq :no-lambda-list (arg-info-lambda-list arg-info))

-        (let ((methods (if (eq *boot-state* 'complete)
+        (let ((methods (if (eq **boot-state** 'complete)

                            (generic-function-methods gf)
                            (early-gf-methods gf))))
           (if (null methods)
                            (generic-function-methods gf)
                            (early-gf-methods gf))))
           (if (null methods)

@@ -2198,6 +2209,43 @@ bootstrapping.
                      method-class)
                     (t (find-class method-class t ,env))))))))
 
                      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
 (defun real-ensure-gf-using-class--generic-function
        (existing
         fun-name

@@ -2212,8 +2260,7 @@ bootstrapping.
     (change-class existing generic-function-class))
   (prog1
       (apply #'reinitialize-instance existing all-keys)
     (change-class existing generic-function-class))
   (prog1
       (apply #'reinitialize-instance existing all-keys)

-    (when lambda-list-p
-      (proclaim (defgeneric-declaration fun-name lambda-list)))))
+    (note-gf-signature fun-name lambda-list-p lambda-list)))

 
 (defun real-ensure-gf-using-class--null
        (existing
 
 (defun real-ensure-gf-using-class--null
        (existing

@@ -2228,13 +2275,12 @@ bootstrapping.
       (setf (gdefinition fun-name)
             (apply #'make-instance generic-function-class
                    :name fun-name all-keys))
       (setf (gdefinition fun-name)
             (apply #'make-instance generic-function-class
                    :name fun-name all-keys))

-    (when lambda-list-p
-      (proclaim (defgeneric-declaration fun-name lambda-list)))))
+    (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*)
       (clos-slots-ref (fsc-instance-slots generic-function)
 \f
 (defun safe-gf-arg-info (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
       (clos-slots-ref (fsc-instance-slots generic-function)

-                      *sgf-arg-info-index*)
+                      +sgf-arg-info-index+)

       (gf-arg-info generic-function)))
 
 ;;; FIXME: this function took on a slightly greater role than it
       (gf-arg-info generic-function)))
 
 ;;; FIXME: this function took on a slightly greater role than it

@@ -2670,7 +2716,7 @@ bootstrapping.
                      (cons (if (listp arg) (cadr arg) t) specializers)
                      (cons (if (listp arg) (car arg) arg) required)))))))
 \f
                      (cons (if (listp arg) (cadr arg) t) specializers)
                      (cons (if (listp arg) (car arg) arg) required)))))))
 \f

-(setq *boot-state* 'early)
+(setq **boot-state** 'early)

 \f
 ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
 ;;; which used %WALKER stuff. That suggests to me that maybe the code
 \f
 ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
 ;;; which used %WALKER stuff. That suggests to me that maybe the code

@@ -2679,7 +2725,7 @@ bootstrapping.
 
 (defun extract-the (form)
   (cond ((and (consp form) (eq (car form) 'the))
 
 (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)))
          (third form))
         (t
          form)))