1.0.42.32: fix for lp#611361

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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 12467fa..ecb3bcf 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -353,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))))

@@ -379,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.

@@ -733,6 +733,7 @@ bootstrapping.
                                            ,call-next-method-p
                                            :next-method-p-p ,next-method-p-p
                                            :setq-p ,setq-p
                                            ,call-next-method-p
                                            :next-method-p-p ,next-method-p-p
                                            :setq-p ,setq-p

+                                           :parameters-setqd ,parameters-setqd

                                            :method-cell ,method-cell
                                            :closurep ,closurep
                                            :applyp ,applyp)
                                            :method-cell ,method-cell
                                            :closurep ,closurep
                                            :applyp ,applyp)

@@ -754,15 +755,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)

@@ -857,7 +864,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

@@ -908,7 +915,7 @@ bootstrapping.
                   ;; the user defines a type and calls (SETF
                   ;; FIND-CLASS) in a consistent way.
                  (when (and class (typep class 'built-in-class))
                   ;; the user defines a type and calls (SETF
                   ;; FIND-CLASS) in a consistent way.
                  (when (and class (typep class 'built-in-class))

-                   `(type ,specializer-nameoid ,parameter))))
+                   `(type ,(class-name class) ,parameter))))

               ((:instance nil)
                (let ((class (specializer-nameoid-class)))
                  (cond
               ((:instance nil)
                (let ((class (specializer-nameoid-class)))
                  (cond

@@ -961,7 +968,7 @@ bootstrapping.
 
 (defmacro bind-simple-lexical-method-functions
     ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p
 
 (defmacro bind-simple-lexical-method-functions
     ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p

-                                     closurep applyp method-cell))
+                                     parameters-setqd closurep applyp method-cell))

      &body body
      &environment env)
   (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
      &body body
      &environment env)
   (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))

@@ -995,9 +1002,25 @@ bootstrapping.
 (defun call-no-next-method (method-cell &rest args)
   (let ((method (car method-cell)))
     (aver method)
 (defun call-no-next-method (method-cell &rest args)
   (let ((method (car method-cell)))
     (aver method)

+    ;; Can't easily provide a RETRY restart here, as the return value here is
+    ;; for the method, not the generic function.

     (apply #'no-next-method (method-generic-function method)
            method args)))
 
     (apply #'no-next-method (method-generic-function method)
            method args)))
 

+(defun call-no-applicable-method (gf args)
+  (restart-case
+          (apply #'no-applicable-method gf args)
+    (retry ()
+      :report "Retry calling the generic function."
+      (apply gf args))))
+
+(defun call-no-primary-method (gf args)
+  (restart-case
+      (apply #'no-primary-method gf args)
+    (retry ()
+      :report "Retry calling the generic function."
+      (apply gf args))))
+

 (defstruct (method-call (:copier nil))
   (function #'identity :type function)
   call-method-args)
 (defstruct (method-call (:copier nil))
   (function #'identity :type function)
   call-method-args)

@@ -1296,6 +1319,7 @@ bootstrapping.
     ((args rest-arg next-method-call (&key
                                       call-next-method-p
                                       setq-p
     ((args rest-arg next-method-call (&key
                                       call-next-method-p
                                       setq-p

+                                      parameters-setqd

                                       method-cell
                                       next-method-p-p
                                       closurep
                                       method-cell
                                       next-method-p-p
                                       closurep

@@ -1469,23 +1493,6 @@ bootstrapping.
                     (setq next-method-p-p t)
                     form)
                    ((memq (car form) '(setq multiple-value-setq))
                     (setq next-method-p-p t)
                     form)
                    ((memq (car form) '(setq multiple-value-setq))

-                    ;; FIXME: this is possibly a little strong as
-                    ;; conditions go.  Ideally we would want to detect
-                    ;; which, if any, of the method parameters are
-                    ;; being set, and communicate that information to
-                    ;; e.g. SPLIT-DECLARATIONS.  However, the brute
-                    ;; force method doesn't really cost much; a little
-                    ;; loss of discrimination over IGNORED variables
-                    ;; should be all.  -- CSR, 2004-07-01
-                    ;;
-                    ;; As of 2006-09-18 modified parameter bindings
-                    ;; are now tracked with more granularity than just
-                    ;; one SETQ-P flag, in order to disable SLOT-VALUE
-                    ;; optimizations for parameters that are SETQd.
-                    ;; The old binary SETQ-P flag is still used for
-                    ;; all other purposes, since as noted above, the
-                    ;; extra cost is minimal. -- JES, 2006-09-18
-                    ;;

                     ;; The walker will split (SETQ A 1 B 2) to
                     ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
                     ;; only need to handle the simple case of SETQ
                     ;; The walker will split (SETQ A 1 B 2) to
                     ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
                     ;; only need to handle the simple case of SETQ

@@ -1543,7 +1550,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

@@ -1573,7 +1580,7 @@ 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)
              (fboundp gf-spec))
     (let* ((gf (fdefinition gf-spec))
            (method (and (generic-function-p gf)

@@ -1721,7 +1728,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)

@@ -1750,32 +1757,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

@@ -1821,10 +1828,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)))

@@ -1903,21 +1910,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)

@@ -1925,34 +1930,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))

@@ -1965,16 +1967,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*)

@@ -2002,7 +2004,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)

@@ -2023,7 +2025,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

@@ -2113,12 +2115,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)))
 

@@ -2127,44 +2129,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)

@@ -2208,6 +2210,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

@@ -2222,11 +2261,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
-      (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
 
 (defun real-ensure-gf-using-class--null
        (existing

@@ -2241,16 +2276,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
-      (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*)
       (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

@@ -2681,12 +2712,20 @@ bootstrapping.
           (t
            (multiple-value-bind (parameters lambda-list specializers required)
                (parse-specialized-lambda-list (cdr arglist))
           (t
            (multiple-value-bind (parameters lambda-list specializers required)
                (parse-specialized-lambda-list (cdr arglist))

+             ;; Check for valid arguments.
+             (unless (or (and (symbolp arg) (not (null arg)))
+                         (and (consp arg)
+                              (consp (cdr arg))
+                              (null (cddr arg))))
+               (error 'specialized-lambda-list-error
+                      :format-control "arg is not a non-NIL symbol or a list of two elements: ~A"
+                      :format-arguments (list arg)))

              (values (cons (if (listp arg) (car arg) arg) parameters)
                      (cons (if (listp arg) (car arg) arg) lambda-list)
                      (cons (if (listp arg) (cadr arg) t) specializers)
                      (cons (if (listp arg) (car arg) arg) required)))))))
 \f
              (values (cons (if (listp arg) (car arg) arg) parameters)
                      (cons (if (listp arg) (car arg) arg) lambda-list)
                      (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

@@ -2695,7 +2734,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)))