Fix cut-to-width in the presence of bad constants in dead code.

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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 11dfa03..6a8cc46 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -171,25 +171,33 @@ bootstrapping.
           (let ((car-option (car option)))
             (case car-option
               (declare
           (let ((car-option (car option)))
             (case car-option
               (declare

-               (when (and
-                      (consp (cadr option))
-                      (member (first (cadr option))
-                              ;; FIXME: this list is slightly weird.
-                              ;; ANSI (on the DEFGENERIC page) in one
-                              ;; place allows only OPTIMIZE; in
-                              ;; another place gives this list of
-                              ;; disallowed declaration specifiers.
-                              ;; This seems to be the only place where
-                              ;; the FUNCTION declaration is
-                              ;; mentioned; TYPE seems to be missing.
-                              ;; Very strange.  -- CSR, 2002-10-21
-                              '(declaration ftype function
-                                inline notinline special)))
-                 (error 'simple-program-error
-                        :format-control "The declaration specifier ~S ~
+               (dolist (spec (cdr option))
+                 (unless (consp spec)
+                   (error 'simple-program-error
+                          :format-control "~@<Invalid declaration specifier in ~
+                                           DEFGENERIC: ~S~:@>"
+                          :format-arguments (list spec)))
+                 (when (member (first spec)
+                               ;; FIXME: this list is slightly weird.
+                               ;; ANSI (on the DEFGENERIC page) in one
+                               ;; place allows only OPTIMIZE; in
+                               ;; another place gives this list of
+                               ;; disallowed declaration specifiers.
+                               ;; This seems to be the only place where
+                               ;; the FUNCTION declaration is
+                               ;; mentioned; TYPE seems to be missing.
+                               ;; Very strange.  -- CSR, 2002-10-21
+                               '(declaration ftype function
+                                 inline notinline special))
+                   (error 'simple-program-error
+                          :format-control "The declaration specifier ~S ~

                                          is not allowed inside DEFGENERIC."
                                          is not allowed inside DEFGENERIC."

-                        :format-arguments (list (cadr option))))
-               (push (cadr option) (initarg :declarations)))
+                          :format-arguments (list spec)))
+                 (if (or (eq 'optimize (first spec))
+                         (info :declaration :recognized (first spec)))
+                     (push spec (initarg :declarations))
+                     (warn "Ignoring unrecognized declaration in DEFGENERIC: ~S"
+                           spec))))

               (:method-combination
                (when (initarg car-option)
                  (duplicate-option car-option))
               (:method-combination
                (when (initarg car-option)
                  (duplicate-option car-option))

@@ -239,8 +247,8 @@ bootstrapping.
            (compile-or-load-defgeneric ',fun-name))
          (load-defgeneric ',fun-name ',lambda-list
                           (sb-c:source-location) ,@initargs)
            (compile-or-load-defgeneric ',fun-name))
          (load-defgeneric ',fun-name ',lambda-list
                           (sb-c:source-location) ,@initargs)

-        ,@(mapcar #'expand-method-definition methods)
-        (fdefinition ',fun-name)))))
+         ,@(mapcar #'expand-method-definition methods)
+         (fdefinition ',fun-name)))))

 
 (defun compile-or-load-defgeneric (fun-name)
   (proclaim-as-fun-name fun-name)
 
 (defun compile-or-load-defgeneric (fun-name)
   (proclaim-as-fun-name fun-name)

@@ -252,9 +260,10 @@ 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)

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

     (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))

@@ -309,40 +318,44 @@ bootstrapping.
       ;; belong here!
       (aver (not morep)))))
 \f
       ;; belong here!
       (aver (not morep)))))
 \f

-(defmacro defmethod (&rest args)
-  (multiple-value-bind (name qualifiers lambda-list body)
+(defmacro defmethod (name &rest args)
+  (multiple-value-bind (qualifiers lambda-list body)

       (parse-defmethod args)
     `(progn
       (parse-defmethod args)
     `(progn

-      ;; KLUDGE: this double expansion is quite a monumental
-      ;; workaround: it comes about because of a fantastic interaction
-      ;; between the processing rules of CLHS 3.2.3.1 and the
-      ;; bizarreness of MAKE-METHOD-LAMBDA.
-      ;;
-      ;; MAKE-METHOD-LAMBDA can be called by the user, and if the
-      ;; lambda itself doesn't refer to outside bindings the return
-      ;; value must be compileable in the null lexical environment.
-      ;; However, the function must also refer somehow to the
-      ;; associated method object, so that it can call NO-NEXT-METHOD
-      ;; with the appropriate arguments if there is no next method --
-      ;; but when the function is generated, the method object doesn't
-      ;; exist yet.
-      ;;
-      ;; In order to resolve this issue, we insert a literal cons cell
-      ;; into the body of the method lambda, return the same cons cell
-      ;; as part of the second (initargs) return value of
-      ;; MAKE-METHOD-LAMBDA, and a method on INITIALIZE-INSTANCE fills
-      ;; in the cell when the method is created.  However, this
-      ;; strategy depends on having a fresh cons cell for every method
-      ;; lambda, which (without the workaround below) is skewered by
-      ;; the processing in CLHS 3.2.3.1, which permits implementations
-      ;; to macroexpand the bodies of EVAL-WHEN forms with both
-      ;; :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL only once.  The
-      ;; expansion below forces the double expansion in those cases,
-      ;; while expanding only once in the common case.
-      (eval-when (:load-toplevel)
-        (%defmethod-expander ,name ,qualifiers ,lambda-list ,body))
-      (eval-when (:execute)
-        (%defmethod-expander ,name ,qualifiers ,lambda-list ,body)))))
+       (eval-when (:compile-toplevel :execute)
+         ;; :compile-toplevel is needed for subsequent forms
+         ;; :execute is needed for references to itself inside the body
+         (compile-or-load-defgeneric ',name))
+       ;; KLUDGE: this double expansion is quite a monumental
+       ;; workaround: it comes about because of a fantastic interaction
+       ;; between the processing rules of CLHS 3.2.3.1 and the
+       ;; bizarreness of MAKE-METHOD-LAMBDA.
+       ;;
+       ;; MAKE-METHOD-LAMBDA can be called by the user, and if the
+       ;; lambda itself doesn't refer to outside bindings the return
+       ;; value must be compileable in the null lexical environment.
+       ;; However, the function must also refer somehow to the
+       ;; associated method object, so that it can call NO-NEXT-METHOD
+       ;; with the appropriate arguments if there is no next method --
+       ;; but when the function is generated, the method object doesn't
+       ;; exist yet.
+       ;;
+       ;; In order to resolve this issue, we insert a literal cons cell
+       ;; into the body of the method lambda, return the same cons cell
+       ;; as part of the second (initargs) return value of
+       ;; MAKE-METHOD-LAMBDA, and a method on INITIALIZE-INSTANCE fills
+       ;; in the cell when the method is created.  However, this
+       ;; strategy depends on having a fresh cons cell for every method
+       ;; lambda, which (without the workaround below) is skewered by
+       ;; the processing in CLHS 3.2.3.1, which permits implementations
+       ;; to macroexpand the bodies of EVAL-WHEN forms with both
+       ;; :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL only once.  The
+       ;; expansion below forces the double expansion in those cases,
+       ;; while expanding only once in the common case.
+       (eval-when (:load-toplevel)
+         (%defmethod-expander ,name ,qualifiers ,lambda-list ,body))
+       (eval-when (:execute)
+         (%defmethod-expander ,name ,qualifiers ,lambda-list ,body)))))

 
 (defmacro %defmethod-expander
     (name qualifiers lambda-list body &environment env)
 
 (defmacro %defmethod-expander
     (name qualifiers lambda-list body &environment env)

@@ -353,7 +366,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 +392,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.

@@ -388,6 +401,11 @@ bootstrapping.
             (class-prototype (or (generic-function-method-class gf?)
                                  (find-class 'standard-method)))))))
 \f
             (class-prototype (or (generic-function-method-class gf?)
                                  (find-class 'standard-method)))))))
 \f

+;;; These are used to communicate the method name and lambda-list to
+;;; MAKE-METHOD-LAMBDA-INTERNAL.
+(defvar *method-name* nil)
+(defvar *method-lambda-list* nil)
+

 (defun expand-defmethod (name
                          proto-gf
                          proto-method
 (defun expand-defmethod (name
                          proto-gf
                          proto-method

@@ -395,41 +413,45 @@ bootstrapping.
                          lambda-list
                          body
                          env)
                          lambda-list
                          body
                          env)

-  (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
-      (add-method-declarations name qualifiers lambda-list body env)
-    (multiple-value-bind (method-function-lambda initargs)
-        (make-method-lambda proto-gf proto-method method-lambda env)
-      (let ((initargs-form (make-method-initargs-form
-                            proto-gf proto-method method-function-lambda
-                            initargs env))
-            (specializers-form (make-method-specializers-form
-                                proto-gf proto-method specializers env)))
-        `(progn
-          ;; Note: We could DECLAIM the ftype of the generic function
-          ;; here, since ANSI specifies that we create it if it does
-          ;; not exist. However, I chose not to, because I think it's
-          ;; more useful to support a style of programming where every
-          ;; generic function has an explicit DEFGENERIC and any typos
-          ;; in DEFMETHODs are warned about. Otherwise
-          ;;
-          ;;   (DEFGENERIC FOO-BAR-BLETCH (X))
-          ;;   (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
-          ;;   (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
-          ;;   (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
-          ;;   (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
-          ;;   (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
-          ;;
-          ;; compiles without raising an error and runs without
-          ;; raising an error (since SIMPLE-VECTOR cases fall through
-          ;; to VECTOR) but still doesn't do what was intended. I hate
-          ;; that kind of bug (code which silently gives the wrong
-          ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
-          ,(make-defmethod-form name qualifiers specializers-form
-                                unspecialized-lambda-list
-                                (if proto-method
-                                    (class-name (class-of proto-method))
-                                    'standard-method)
-                                initargs-form))))))
+  (multiple-value-bind (parameters unspecialized-lambda-list specializers)
+      (parse-specialized-lambda-list lambda-list)
+    (declare (ignore parameters))
+    (let ((method-lambda `(lambda ,unspecialized-lambda-list ,@body))
+          (*method-name* `(,name ,@qualifiers ,specializers))
+          (*method-lambda-list* lambda-list))
+      (multiple-value-bind (method-function-lambda initargs)
+          (make-method-lambda proto-gf proto-method method-lambda env)
+        (let ((initargs-form (make-method-initargs-form
+                              proto-gf proto-method method-function-lambda
+                              initargs env))
+              (specializers-form (make-method-specializers-form
+                                  proto-gf proto-method specializers env)))
+          `(progn
+             ;; Note: We could DECLAIM the ftype of the generic function
+             ;; here, since ANSI specifies that we create it if it does
+             ;; not exist. However, I chose not to, because I think it's
+             ;; more useful to support a style of programming where every
+             ;; generic function has an explicit DEFGENERIC and any typos
+             ;; in DEFMETHODs are warned about. Otherwise
+             ;;
+             ;;   (DEFGENERIC FOO-BAR-BLETCH (X))
+             ;;   (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+             ;;   (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+             ;;   (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+             ;;   (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+             ;;   (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+             ;;
+             ;; compiles without raising an error and runs without
+             ;; raising an error (since SIMPLE-VECTOR cases fall through
+             ;; to VECTOR) but still doesn't do what was intended. I hate
+             ;; that kind of bug (code which silently gives the wrong
+             ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
+             ,(make-defmethod-form name qualifiers specializers-form
+                                   unspecialized-lambda-list
+                                   (if proto-method
+                                       (class-name (class-of proto-method))
+                                       'standard-method)
+                                   initargs-form)))))))

 
 (defun interned-symbol-p (x)
   (and (symbolp x) (symbol-package x)))
 
 (defun interned-symbol-p (x)
   (and (symbolp x) (symbol-package x)))

@@ -524,44 +546,6 @@ bootstrapping.
                                  initargs
                                  env))))
 
                                  initargs
                                  env))))
 

-(defun add-method-declarations (name qualifiers lambda-list body env)
-  (declare (ignore env))
-  (multiple-value-bind (parameters unspecialized-lambda-list specializers)
-      (parse-specialized-lambda-list lambda-list)
-    (multiple-value-bind (real-body declarations documentation)
-        (parse-body body)
-      (values `(lambda ,unspecialized-lambda-list
-                 ,@(when documentation `(,documentation))
-                 ;; (Old PCL code used a somewhat different style of
-                 ;; list for %METHOD-NAME values. Our names use
-                 ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the
-                 ;; method names look more like what you see in a
-                 ;; DEFMETHOD form.)
-                 ;;
-                 ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at
-                 ;; least the code to set up named BLOCKs around the
-                 ;; bodies of methods, depends on the function's base
-                 ;; name being the first element of the %METHOD-NAME
-                 ;; list. It would be good to remove this dependency,
-                 ;; perhaps by building the BLOCK here, or by using
-                 ;; another declaration (e.g. %BLOCK-NAME), so that
-                 ;; our method debug names are free to have any format,
-                 ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
-                 ;;
-                 ;; Further, as of sbcl-0.7.9.10, the code to
-                 ;; implement NO-NEXT-METHOD is coupled to the form of
-                 ;; this declaration; see the definition of
-                 ;; CALL-NO-NEXT-METHOD (and the passing of
-                 ;; METHOD-NAME-DECLARATION arguments around the
-                 ;; various CALL-NEXT-METHOD logic).
-                 (declare (%method-name (,name
-                                         ,@qualifiers
-                                         ,specializers)))
-                 (declare (%method-lambda-list ,@lambda-list))
-                 ,@declarations
-                 ,@real-body)
-              unspecialized-lambda-list specializers))))
-

 (defun real-make-method-initargs-form (proto-gf proto-method
                                        method-lambda initargs env)
   (declare (ignore proto-gf proto-method))
 (defun real-make-method-initargs-form (proto-gf proto-method
                                        method-lambda initargs env)
   (declare (ignore proto-gf proto-method))

@@ -604,11 +588,20 @@ bootstrapping.
            method-lambda))
   (multiple-value-bind (real-body declarations documentation)
       (parse-body (cddr method-lambda))
            method-lambda))
   (multiple-value-bind (real-body declarations documentation)
       (parse-body (cddr method-lambda))

-    (let* ((name-decl (get-declaration '%method-name declarations))
-           (sll-decl (get-declaration '%method-lambda-list declarations))
-           (method-name (when (consp name-decl) (car name-decl)))
+    ;; We have the %METHOD-NAME declaration in the place where we expect it only
+    ;; if there is are no non-standard prior MAKE-METHOD-LAMBDA methods -- or
+    ;; unless they're fantastically unintrusive.
+    (let* ((method-name *method-name*)
+           (method-lambda-list *method-lambda-list*)
+           ;; Macroexpansion caused by code-walking may call make-method-lambda and
+           ;; end up with wrong values
+           (*method-name* nil)
+           (*method-lambda-list* nil)

            (generic-function-name (when method-name (car method-name)))
            (generic-function-name (when method-name (car method-name)))

-           (specialized-lambda-list (or sll-decl (cadr method-lambda)))
+           (specialized-lambda-list (or method-lambda-list
+                                        (ecase (car method-lambda)
+                                          (lambda (second method-lambda))
+                                          (named-lambda (third method-lambda)))))

            ;; the method-cell is a way of communicating what method a
            ;; method-function implements, for the purpose of
            ;; NO-NEXT-METHOD.  We need something that can be shared
            ;; the method-cell is a way of communicating what method a
            ;; method-function implements, for the purpose of
            ;; NO-NEXT-METHOD.  We need something that can be shared

@@ -730,9 +723,10 @@ bootstrapping.
                          (simple-lexical-method-functions
                              (,lambda-list .method-args. .next-methods.
                                            :call-next-method-p
                          (simple-lexical-method-functions
                              (,lambda-list .method-args. .next-methods.
                                            :call-next-method-p

-                                           ,call-next-method-p
+                                           ,(when call-next-method-p t)

                                            :next-method-p-p ,next-method-p-p
                                            :setq-p ,setq-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)

@@ -746,6 +740,8 @@ bootstrapping.
                                          %parameter-binding-modified))
                                ,@walked-lambda-body))))
                       `(,@(when call-next-method-p `(method-cell ,method-cell))
                                          %parameter-binding-modified))
                                ,@walked-lambda-body))))
                       `(,@(when call-next-method-p `(method-cell ,method-cell))

+                          ,@(when (member call-next-method-p '(:simple nil))
+                                  '(simple-next-method-call t))

                           ,@(when plist `(plist ,plist))
                           ,@(when documentation `(:documentation ,documentation)))))))))))
 
                           ,@(when plist `(plist ,plist))
                           ,@(when documentation `(:documentation ,documentation)))))))))))
 

@@ -754,7 +750,7 @@ 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))
                    (specializerp name))
               name)
              ((symbolp name) `(find-class ',name))

@@ -863,7 +859,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

@@ -914,7 +910,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

@@ -967,7 +963,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))

@@ -977,33 +973,49 @@ bootstrapping.
              (,next-methods (cdr ,next-methods)))
          (declare (ignorable .next-method. ,next-methods))
          (flet (,@(and call-next-method-p
              (,next-methods (cdr ,next-methods)))
          (declare (ignorable .next-method. ,next-methods))
          (flet (,@(and call-next-method-p

-                       `((call-next-method
-                          (&rest cnm-args)
-                          ,@(if (safe-code-p env)
-                                `((%check-cnm-args cnm-args
-                                                   ,method-args
-                                                   ',method-cell))
-                                nil)
-                          (if .next-method.
-                              (funcall (if (std-instance-p .next-method.)
-                                           (method-function .next-method.)
-                                           .next-method.) ; for early methods
-                                       (or cnm-args ,method-args)
-                                       ,next-methods)
-                              (apply #'call-no-next-method
-                                     ',method-cell
-                                     (or cnm-args ,method-args))))))
+                    `((call-next-method (&rest cnm-args)
+                       (declare (dynamic-extent cnm-args))
+                       ,@(if (safe-code-p env)
+                             `((%check-cnm-args cnm-args
+                                                ,method-args
+                                                ',method-cell))
+                             nil)
+                       (if .next-method.
+                           (funcall (if (std-instance-p .next-method.)
+                                        (method-function .next-method.)
+                                        .next-method.) ; for early methods
+                                    (or cnm-args ,method-args)
+                                    ,next-methods)
+                           (apply #'call-no-next-method
+                                  ',method-cell
+                                  (or cnm-args ,method-args))))))

                 ,@(and next-method-p-p
                 ,@(and next-method-p-p

-                       '((next-method-p ()
-                          (not (null .next-method.))))))
+                    '((next-method-p ()
+                       (not (null .next-method.))))))

            ,@body))))
 
 (defun call-no-next-method (method-cell &rest args)
   (let ((method (car method-cell)))
     (aver method)
            ,@body))))
 
 (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)

@@ -1302,37 +1314,37 @@ 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
                                       applyp))
      &body body
      &environment env)
                                       method-cell
                                       next-method-p-p
                                       closurep
                                       applyp))
      &body body
      &environment env)

-  (let* ((all-params (append args (when rest-arg (list rest-arg))))
-         (rebindings (when (or setq-p call-next-method-p)
-                       (mapcar (lambda (x) (list x x)) all-params))))
+  (let* ((rebindings (when (or setq-p call-next-method-p)
+                       (mapcar (lambda (x) (list x x)) parameters-setqd))))

     (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
         `(locally
              ,@body)
         `(flet (,@(when call-next-method-p
     (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
         `(locally
              ,@body)
         `(flet (,@(when call-next-method-p

-                        `((call-next-method (&rest cnm-args)
-                            (declare (muffle-conditions code-deletion-note)
-                                     (optimize (sb-c:insert-step-conditions 0)))
-                           ,@(if (safe-code-p env)
-                                 `((%check-cnm-args cnm-args (list ,@args)
-                                                    ',method-cell))
-                                 nil)
-                           (fast-call-next-method-body (,args
-                                                        ,next-method-call
-                                                        ,rest-arg)
+                    `((call-next-method (&rest cnm-args)
+                        (declare (dynamic-extent cnm-args)
+                                 (muffle-conditions code-deletion-note)
+                                 (optimize (sb-c:insert-step-conditions 0)))
+                        ,@(if (safe-code-p env)
+                              `((%check-cnm-args cnm-args (list ,@args)
+                                                 ',method-cell))
+                              nil)
+                        (fast-call-next-method-body (,args
+                                                     ,next-method-call
+                                                     ,rest-arg)

                             ,method-cell
                             cnm-args))))
                             ,method-cell
                             cnm-args))))

-                ,@(when next-method-p-p
-                        `((next-method-p ()
-                           (declare (optimize (sb-c:insert-step-conditions 0)))
-                           (not (null ,next-method-call))))))
+                  ,@(when next-method-p-p
+                      `((next-method-p ()
+                         (declare (optimize (sb-c:insert-step-conditions 0)))
+                         (not (null ,next-method-call))))))

            (let ,rebindings
            (let ,rebindings

-             ,@(when rebindings `((declare (ignorable ,@all-params))))

              ,@body)))))
 
 ;;; CMUCL comment (Gerd Moellmann):
              ,@body)))))
 
 ;;; CMUCL comment (Gerd Moellmann):

@@ -1351,17 +1363,31 @@ bootstrapping.
 ;;; preconditions.  That looks hairy and is probably not worth it,
 ;;; because this check will never be fast.
 (defun %check-cnm-args (cnm-args orig-args method-cell)
 ;;; preconditions.  That looks hairy and is probably not worth it,
 ;;; because this check will never be fast.
 (defun %check-cnm-args (cnm-args orig-args method-cell)

+  ;; 1. Check for no arguments.

   (when cnm-args
     (let* ((gf (method-generic-function (car method-cell)))
   (when cnm-args
     (let* ((gf (method-generic-function (car method-cell)))

-           (omethods (compute-applicable-methods gf orig-args))
-           (nmethods (compute-applicable-methods gf cnm-args)))
-      (unless (equal omethods nmethods)
-        (error "~@<The set of methods ~S applicable to argument~P ~
-                ~{~S~^, ~} to call-next-method is different from ~
-                the set of methods ~S applicable to the original ~
-                method argument~P ~{~S~^, ~}.~@:>"
-               nmethods (length cnm-args) cnm-args omethods
-               (length orig-args) orig-args)))))
+           (nreq (generic-function-nreq gf)))
+      (declare (fixnum nreq))
+      ;; 2. Requirement arguments pairwise: if all are EQL, the applicable
+      ;; methods must be the same. This takes care of the relatively common
+      ;; case of twiddling with &KEY arguments without being horribly
+      ;; expensive.
+      (unless (do ((orig orig-args (cdr orig))
+                   (args cnm-args (cdr args))
+                   (n nreq (1- nreq)))
+                  ((zerop n) t)
+                (unless (and orig args (eql (car orig) (car args)))
+                  (return nil)))
+        ;; 3. Only then do the full check.
+        (let ((omethods (compute-applicable-methods gf orig-args))
+              (nmethods (compute-applicable-methods gf cnm-args)))
+          (unless (equal omethods nmethods)
+            (error "~@<The set of methods ~S applicable to argument~P ~
+                    ~{~S~^, ~} to call-next-method is different from ~
+                    the set of methods ~S applicable to the original ~
+                    method argument~P ~{~S~^, ~}.~@:>"
+                   nmethods (length cnm-args) cnm-args omethods
+                   (length orig-args) orig-args)))))))

 
 (defmacro bind-args ((lambda-list args) &body body)
   (let ((args-tail '.args-tail.)
 
 (defmacro bind-args ((lambda-list args) &body body)
   (let ((args-tail '.args-tail.)

@@ -1469,29 +1495,14 @@ bootstrapping.
                    ;; like :LOAD-TOPLEVEL.
                    ((not (listp form)) form)
                    ((eq (car form) 'call-next-method)
                    ;; like :LOAD-TOPLEVEL.
                    ((not (listp form)) form)
                    ((eq (car form) 'call-next-method)

-                    (setq call-next-method-p t)
+                    (setq call-next-method-p (if (cdr form)
+                                                 t
+                                                 :simple))

                     form)
                    ((eq (car form) 'next-method-p)
                     (setq next-method-p-p t)
                     form)
                    ((memq (car form) '(setq multiple-value-setq))
                     form)
                    ((eq (car form) 'next-method-p)
                     (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

@@ -1549,7 +1560,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

@@ -1579,17 +1590,18 @@ 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 'sb-kernel:redefinition-with-defmethod
-                    :generic-function gf-spec :old-method method
-                    :qualifiers qualifiers :specializers specializers
-                    :new-location source-location))))
+        (warn 'sb-kernel:redefinition-with-defmethod
+              :name gf-spec
+              :new-location source-location
+              :old-method method
+              :qualifiers qualifiers :specializers specializers))))

   (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

@@ -1721,13 +1733,13 @@ bootstrapping.
 
 (defun ensure-generic-function (fun-name
                                 &rest all-keys
 
 (defun ensure-generic-function (fun-name
                                 &rest all-keys

-                                &key environment source-location
+                                &key environment definition-source

                                 &allow-other-keys)
   (declare (ignore environment))
   (let ((existing (and (fboundp fun-name)
                        (gdefinition fun-name))))
     (cond ((and existing
                                 &allow-other-keys)
   (declare (ignore environment))
   (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,8 +1755,8 @@ bootstrapping.
           :format-arguments (list fun-name)))
 
 (defvar *sgf-wrapper*
           :format-arguments (list fun-name)))
 
 (defvar *sgf-wrapper*

-  (boot-make-wrapper (early-class-size 'standard-generic-function)
-                     'standard-generic-function))
+  (!boot-make-wrapper (early-class-size 'standard-generic-function)
+                      'standard-generic-function))

 
 (defvar *sgf-slots-init*
   (mapcar (lambda (canonical-slot)
 
 (defvar *sgf-slots-init*
   (mapcar (lambda (canonical-slot)

@@ -1756,32 +1768,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

@@ -1827,10 +1839,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)))

@@ -1909,21 +1921,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)

@@ -1931,34 +1941,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))

@@ -1971,16 +1978,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*)

@@ -2008,7 +2015,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)

@@ -2029,7 +2036,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

@@ -2057,7 +2064,7 @@ bootstrapping.
                                             &key (lambda-list nil
                                                               lambda-list-p)
                                             argument-precedence-order
                                             &key (lambda-list nil
                                                               lambda-list-p)
                                             argument-precedence-order

-                                            source-location
+                                            definition-source

                                             documentation
                                             &allow-other-keys)
   (declare (ignore keys))
                                             documentation
                                             &allow-other-keys)
   (declare (ignore keys))

@@ -2068,7 +2075,7 @@ bootstrapping.
         ((assoc spec *!generic-function-fixups* :test #'equal)
          (if existing
              (make-early-gf spec lambda-list lambda-list-p existing
         ((assoc spec *!generic-function-fixups* :test #'equal)
          (if existing
              (make-early-gf spec lambda-list lambda-list-p existing

-                            argument-precedence-order source-location
+                            argument-precedence-order definition-source

                             documentation)
              (bug "The function ~S is not already defined." spec)))
         (existing
                             documentation)
              (bug "The function ~S is not already defined." spec)))
         (existing

@@ -2077,7 +2084,7 @@ bootstrapping.
         (t
          (pushnew spec *!early-generic-functions* :test #'equal)
          (make-early-gf spec lambda-list lambda-list-p nil
         (t
          (pushnew spec *!early-generic-functions* :test #'equal)
          (make-early-gf spec lambda-list lambda-list-p nil

-                        argument-precedence-order source-location
+                        argument-precedence-order definition-source

                         documentation))))
 
 (defun make-early-gf (spec &optional lambda-list lambda-list-p
                         documentation))))
 
 (defun make-early-gf (spec &optional lambda-list lambda-list-p

@@ -2119,12 +2126,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)))
 

@@ -2133,44 +2140,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
        ;; Check that we are under the lock.
        #+sb-thread

-       (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
+       (aver (eq sb-thread:*current-thread* (sb-thread:mutex-owner (gf-lock gf))))

        (setf (safe-gf-dfun-state gf) new-state))
       (t
        (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)

@@ -2201,12 +2208,14 @@ bootstrapping.
            (finalize-inheritance ,gf-class)))
      (remf ,all-keys :generic-function-class)
      (remf ,all-keys :environment)
            (finalize-inheritance ,gf-class)))
      (remf ,all-keys :generic-function-class)
      (remf ,all-keys :environment)

-     (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
-       (unless (eq combin '.shes-not-there.)
-         (setf (getf ,all-keys :method-combination)
-               (find-method-combination (class-prototype ,gf-class)
-                                        (car combin)
-                                        (cdr combin)))))
+     (let ((combin (getf ,all-keys :method-combination)))
+       (etypecase combin
+         (cons
+          (setf (getf ,all-keys :method-combination)
+                (find-method-combination (class-prototype ,gf-class)
+                                         (car combin)
+                                         (cdr combin))))
+         ((or null method-combination))))

     (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
       (unless (eq method-class '.shes-not-there.)
         (setf (getf ,all-keys :method-class)
     (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
       (unless (eq method-class '.shes-not-there.)
         (setf (getf ,all-keys :method-class)

@@ -2285,7 +2294,7 @@ bootstrapping.
 (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)
 (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

@@ -2310,9 +2319,24 @@ bootstrapping.
         (values (arg-info-applyp arg-info)
                 metatypes
                 arg-info))
         (values (arg-info-applyp arg-info)
                 metatypes
                 arg-info))

-    (values (length metatypes) applyp metatypes
-            (count-if (lambda (x) (neq x t)) metatypes)
-            arg-info)))
+    (let ((nreq 0)
+          (nkeys 0))
+      (declare (fixnum nreq nkeys))
+      (dolist (x metatypes)
+        (incf nreq)
+        (unless (eq x t)
+          (incf nkeys)))
+      (values nreq applyp metatypes
+              nkeys
+              arg-info))))
+
+(defun generic-function-nreq (gf)
+  (let* ((arg-info (if (early-gf-p gf)
+                       (early-gf-arg-info gf)
+                       (safe-gf-arg-info gf)))
+         (metatypes (arg-info-metatypes arg-info)))
+    (declare (list metatypes))
+    (length metatypes)))

 
 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
                             &key slot-name object-class method-class-function
 
 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
                             &key slot-name object-class method-class-function

@@ -2597,14 +2621,13 @@ bootstrapping.
 ;;; is really implemented.
 (defun parse-defmethod (cdr-of-form)
   (declare (list cdr-of-form))
 ;;; is really implemented.
 (defun parse-defmethod (cdr-of-form)
   (declare (list cdr-of-form))

-  (let ((name (pop cdr-of-form))
-        (qualifiers ())
+  (let ((qualifiers ())

         (spec-ll ()))
     (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
               (push (pop cdr-of-form) qualifiers)
               (return (setq qualifiers (nreverse qualifiers)))))
     (setq spec-ll (pop cdr-of-form))
         (spec-ll ()))
     (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
               (push (pop cdr-of-form) qualifiers)
               (return (setq qualifiers (nreverse qualifiers)))))
     (setq spec-ll (pop cdr-of-form))

-    (values name qualifiers spec-ll cdr-of-form)))
+    (values qualifiers spec-ll cdr-of-form)))

 
 (defun parse-specializers (generic-function specializers)
   (declare (list specializers))
 
 (defun parse-specializers (generic-function specializers)
   (declare (list specializers))

@@ -2716,12 +2739,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