X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=c1e5fc462cb221bbf79fb6fc06d8777d7c89d06b;hb=26d8f7707843aba4ba2a071b3b2d4c91e8c0d798;hp=d0e5c0484b3bf1f583e3bde17b6462d2cdf0c8d8;hpb=d984db0864aa7ba5155ec684462840ec1a49ca5b;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index d0e5c04..c1e5fc4 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -152,10 +152,9 @@
     (check-slot-name method slot-name)))
 
 (defmethod shared-initialize :after ((method standard-method) slot-names
-                                     &rest initargs &key)
-  (declare (ignore slot-names))
+                                     &rest initargs &key ((method-cell method-cell)))
+  (declare (ignore slot-names method-cell))
   (initialize-method-function initargs method))
-
 
 (defvar *the-class-generic-function*
   (find-class 'generic-function))
@@ -217,15 +216,11 @@
       (errorp (error "No generic function named ~S." name))
       (t nil))))
 
-(defun real-add-named-method (generic-function-name
-                              qualifiers
-                              specializers
-                              lambda-list
-                              &rest other-initargs)
+(defun real-add-named-method (generic-function-name qualifiers
+                              specializers lambda-list &rest other-initargs)
   (unless (and (fboundp generic-function-name)
                (typep (fdefinition generic-function-name) 'generic-function))
-    (style-warn "implicitly creating new generic function ~S"
-                generic-function-name))
+    (warn 'implicit-generic-function-warning :name generic-function-name))
   (let* ((existing-gf (find-generic-function generic-function-name nil))
          (generic-function
           (if existing-gf
@@ -233,15 +228,15 @@
                generic-function-name
                :generic-function-class (class-of existing-gf))
               (ensure-generic-function generic-function-name)))
-         (specs (parse-specializers specializers))
-         (proto (method-prototype-for-gf generic-function-name))
-         (new (apply #'make-instance (class-of proto)
-                                     :qualifiers qualifiers
-                                     :specializers specs
-                                     :lambda-list lambda-list
-                                     other-initargs)))
-    (add-method generic-function new)
-    new))
+         (proto (method-prototype-for-gf generic-function-name)))
+    ;; FIXME: Destructive modification of &REST list.
+    (setf (getf (getf other-initargs 'plist) :name)
+          (make-method-spec generic-function qualifiers specializers))
+    (let ((new (apply #'make-instance (class-of proto)
+                      :qualifiers qualifiers :specializers specializers
+                      :lambda-list lambda-list other-initargs)))
+      (add-method generic-function new)
+      new)))
 
 (define-condition find-method-length-mismatch
     (reference-condition simple-error)
@@ -270,7 +265,7 @@
            (dolist (method methods)
              (let ((mspecializers (method-specializers method)))
                (aver (= lspec (length mspecializers)))
-               (when (and (equal qualifiers (method-qualifiers method))
+               (when (and (equal qualifiers (safe-method-qualifiers method))
                           (every #'same-specializer-p specializers
                                  (method-specializers method)))
                  (return method))))))
@@ -290,11 +285,14 @@
   ;; function, or an error is signaled."
   ;;
   ;; This error checking is done by REAL-GET-METHOD.
-  (real-get-method generic-function
-                   qualifiers
-                   (parse-specializers specializers)
-                   errorp
-                   t))
+  (real-get-method
+   generic-function qualifiers
+   ;; ANSI for FIND-METHOD seems to imply that in fact specializers
+   ;; should always be passed in parsed form instead of being parsed
+   ;; at this point.  Since there's no ANSI-blessed way of getting an
+   ;; EQL specializer, that seems unnecessarily painful, so we are
+   ;; nice to our users.  -- CSR, 2007-06-01
+   (parse-specializers generic-function specializers) errorp t))
 
 ;;; Compute various information about a generic-function's arglist by looking
 ;;; at the argument lists of the methods. The hair for trying not to use
@@ -347,7 +345,7 @@
     (let ((pos 0))
       (dolist (type-spec (method-specializers method))
         (unless (eq type-spec *the-class-t*)
-          (pushnew pos specialized-argument-positions))
+          (pushnew pos specialized-argument-positions :test #'eq))
         (incf pos)))
     ;; Finally merge the values for this method into the values
     ;; for the exisiting methods and return them. Note that if
@@ -372,7 +370,7 @@
 
 (defmethod generic-function-argument-precedence-order
     ((gf standard-generic-function))
-  (aver (eq *boot-state* 'complete))
+  (aver (eq **boot-state** 'complete))
   (loop with arg-info = (gf-arg-info gf)
         with lambda-list = (arg-info-lambda-list arg-info)
         for argument-position in (arg-info-precedence arg-info)
@@ -435,123 +433,221 @@
       (list '(:sbcl :node "Metaobject Protocol")
             '(:amop :generic-function (setf slot-value-using-class)))))
 
+(defgeneric values-for-add-method (gf method)
+  (:method ((gf standard-generic-function) (method standard-method))
+    ;; KLUDGE: Just a single generic dispatch, and everything else
+    ;; comes from permutation vectors. Would be nicer to define
+    ;; REAL-ADD-METHOD with a proper method so that we could efficiently
+    ;; use SLOT-VALUE there.
+    ;;
+    ;; Optimization note: REAL-ADD-METHOD has a lot of O(N) stuff in it (as
+    ;; does PCL as a whole). It should not be too hard to internally store
+    ;; many of the things we now keep in lists as either purely functional
+    ;; O(log N) sets, or --if we don't mind the memory cost-- using
+    ;; specialized hash-tables: most things are used to answer questions about
+    ;; set-membership, not ordering.
+    (values (slot-value gf '%lock)
+            (slot-value method 'qualifiers)
+            (slot-value method 'specializers)
+            (slot-value method 'lambda-list)
+            (slot-value method '%generic-function)
+            (slot-value gf 'name))))
+
+(define-condition print-object-stream-specializer (reference-condition simple-warning)
+  ()
+  (:default-initargs
+   :references (list '(:ansi-cl :function print-object))
+   :format-control "~@<Specializing on the second argument to ~S has ~
+                    unportable effects, and also interferes with ~
+                    precomputation of print functions for exceptional ~
+                    situations.~@:>"
+   :format-arguments (list 'print-object)))
+
 (defun real-add-method (generic-function method &optional skip-dfun-update-p)
-  (when (method-generic-function method)
-    (error "~@<The method ~S is already part of the generic ~
-            function ~S; it can't be added to another generic ~
-            function until it is removed from the first one.~@:>"
-           method (method-generic-function method)))
-  (flet ((similar-lambda-lists-p (method-a method-b)
+  (flet ((similar-lambda-lists-p (old-method new-lambda-list)
            (multiple-value-bind (a-nreq a-nopt a-keyp a-restp)
-               (analyze-lambda-list (method-lambda-list method-a))
+               (analyze-lambda-list (method-lambda-list old-method))
              (multiple-value-bind (b-nreq b-nopt b-keyp b-restp)
-                 (analyze-lambda-list (method-lambda-list method-b))
+                 (analyze-lambda-list new-lambda-list)
                (and (= a-nreq b-nreq)
                     (= a-nopt b-nopt)
                     (eq (or a-keyp a-restp)
                         (or b-keyp b-restp)))))))
-      (let* ((name (generic-function-name generic-function))
-             (qualifiers (method-qualifiers method))
-             (specializers (method-specializers method))
-             (existing (get-method generic-function
-                                   qualifiers
-                                   specializers
-                                   nil)))
-
-        ;; If there is already a method like this one then we must get
-        ;; rid of it before proceeding.  Note that we call the generic
-        ;; function REMOVE-METHOD to remove it rather than doing it in
-        ;; some internal way.
-        (when (and existing (similar-lambda-lists-p existing method))
-          (remove-method generic-function existing))
-
-        ;; KLUDGE: We have a special case here, as we disallow
-        ;; specializations of the NEW-VALUE argument to (SETF
-        ;; SLOT-VALUE-USING-CLASS).  GET-ACCESSOR-METHOD-FUNCTION is
-        ;; the optimizing function here: it precomputes the effective
-        ;; method, assuming that there is no dispatch to be done on
-        ;; the new-value argument.
-        (when (and (eq generic-function #'(setf slot-value-using-class))
-                   (not (eq *the-class-t* (first specializers))))
-          (error 'new-value-specialization
-                 :method method))
-
-        (setf (method-generic-function method) generic-function)
-        (pushnew method (generic-function-methods generic-function))
-        (dolist (specializer specializers)
-          (add-direct-method specializer method))
-
-        ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
-        ;; detecting attempts to add methods with incongruent lambda
-        ;; lists.  However, according to Gerd Moellmann on cmucl-imp,
-        ;; it also depends on the new method already having been added
-        ;; to the generic function.  Therefore, we need to remove it
-        ;; again on error:
-        (let ((remove-again-p t))
-          (unwind-protect
-               (progn
-                 (set-arg-info generic-function :new-method method)
-                 (setq remove-again-p nil))
-            (when remove-again-p
-              (remove-method generic-function method))))
-
-        ;; KLUDGE II: ANSI saith that it is not an error to add a
-        ;; method with invalid qualifiers to a generic function of the
-        ;; wrong kind; it's only an error at generic function
-        ;; invocation time; I dunno what the rationale was, and it
-        ;; sucks.  Nevertheless, it's probably a programmer error, so
-        ;; let's warn anyway. -- CSR, 2003-08-20
-        (let ((mc (generic-function-method-combination generic-functioN)))
-          (cond
-            ((eq mc *standard-method-combination*)
-             (when (and qualifiers
-                        (or (cdr qualifiers)
-                            (not (memq (car qualifiers)
-                                       '(:around :before :after)))))
-               (warn "~@<Invalid qualifiers for standard method combination ~
-                      in method ~S:~2I~_~S.~@:>"
-                     method qualifiers)))
-            ((short-method-combination-p mc)
-             (let ((mc-name (method-combination-type-name mc)))
-               (when (or (null qualifiers)
-                         (cdr qualifiers)
-                         (and (neq (car qualifiers) :around)
-                              (neq (car qualifiers) mc-name)))
-                 (warn "~@<Invalid qualifiers for ~S method combination ~
-                        in method ~S:~2I~_~S.~@:>"
-                       mc-name method qualifiers))))))
-
-        (unless skip-dfun-update-p
-          (update-ctors 'add-method
-                        :generic-function generic-function
-                        :method method)
-          (update-dfun generic-function))
-        (map-dependents generic-function
-                        (lambda (dep)
-                          (update-dependent generic-function
-                                            dep 'add-method method)))
-        generic-function)))
+    (multiple-value-bind (lock qualifiers specializers new-lambda-list
+                          method-gf name)
+        (values-for-add-method generic-function method)
+      (when method-gf
+        (error "~@<The method ~S is already part of the generic ~
+                function ~S; it can't be added to another generic ~
+                function until it is removed from the first one.~@:>"
+               method method-gf))
+      (when (and (eq name 'print-object) (not (eq (second specializers) *the-class-t*)))
+        (warn 'print-object-stream-specializer))
+      (handler-case
+          ;; System lock because interrupts need to be disabled as
+          ;; well: it would be bad to unwind and leave the gf in an
+          ;; inconsistent state.
+          (sb-thread::with-recursive-system-lock (lock)
+            (let ((existing (get-method generic-function
+                                        qualifiers
+                                        specializers
+                                        nil)))
+
+              ;; If there is already a method like this one then we must get
+              ;; rid of it before proceeding.  Note that we call the generic
+              ;; function REMOVE-METHOD to remove it rather than doing it in
+              ;; some internal way.
+              (when (and existing (similar-lambda-lists-p existing new-lambda-list))
+                (remove-method generic-function existing))
+
+              ;; KLUDGE: We have a special case here, as we disallow
+              ;; specializations of the NEW-VALUE argument to (SETF
+              ;; SLOT-VALUE-USING-CLASS).  GET-ACCESSOR-METHOD-FUNCTION is
+              ;; the optimizing function here: it precomputes the effective
+              ;; method, assuming that there is no dispatch to be done on
+              ;; the new-value argument.
+              (when (and (eq generic-function #'(setf slot-value-using-class))
+                         (not (eq *the-class-t* (first specializers))))
+                (error 'new-value-specialization :method  method))
+
+              (setf (method-generic-function method) generic-function)
+              (pushnew method (generic-function-methods generic-function) :test #'eq)
+              (dolist (specializer specializers)
+                (add-direct-method specializer method))
+
+              ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
+              ;; detecting attempts to add methods with incongruent lambda
+              ;; lists.  However, according to Gerd Moellmann on cmucl-imp,
+              ;; it also depends on the new method already having been added
+              ;; to the generic function.  Therefore, we need to remove it
+              ;; again on error:
+              (let ((remove-again-p t))
+                (unwind-protect
+                     (progn
+                       (set-arg-info generic-function :new-method method)
+                       (setq remove-again-p nil))
+                  (when remove-again-p
+                    (remove-method generic-function method))))
+
+              ;; KLUDGE II: ANSI saith that it is not an error to add a
+              ;; method with invalid qualifiers to a generic function of the
+              ;; wrong kind; it's only an error at generic function
+              ;; invocation time; I dunno what the rationale was, and it
+              ;; sucks.  Nevertheless, it's probably a programmer error, so
+              ;; let's warn anyway. -- CSR, 2003-08-20
+              (let ((mc (generic-function-method-combination generic-functioN)))
+                (cond
+                  ((eq mc *standard-method-combination*)
+                   (when (and qualifiers
+                              (or (cdr qualifiers)
+                                  (not (memq (car qualifiers)
+                                             '(:around :before :after)))))
+                     (warn "~@<Invalid qualifiers for standard method ~
+                            combination in method ~S:~2I~_~S.~@:>"
+                           method qualifiers)))
+                  ((short-method-combination-p mc)
+                   (let ((mc-name (method-combination-type-name mc)))
+                     (when (or (null qualifiers)
+                               (cdr qualifiers)
+                               (and (neq (car qualifiers) :around)
+                                    (neq (car qualifiers) mc-name)))
+                       (warn "~@<Invalid qualifiers for ~S method combination ~
+                              in method ~S:~2I~_~S.~@:>"
+                             mc-name method qualifiers))))))
+              (unless skip-dfun-update-p
+                (update-ctors 'add-method
+                              :generic-function generic-function
+                              :method method)
+                (update-dfun generic-function))
+              (setf (gf-info-needs-update generic-function) t)
+              (map-dependents generic-function
+                              (lambda (dep)
+                                (update-dependent generic-function
+                                                  dep 'add-method method)))))
+        (serious-condition (c)
+          (error c)))))
+  generic-function)
 
 (defun real-remove-method (generic-function method)
   (when (eq generic-function (method-generic-function method))
-    (let* ((name (generic-function-name generic-function))
-           (specializers (method-specializers method))
-           (methods (generic-function-methods generic-function))
-           (new-methods (remove method methods)))
-      (setf (method-generic-function method) nil)
-      (setf (generic-function-methods generic-function) new-methods)
-      (dolist (specializer (method-specializers method))
-        (remove-direct-method specializer method))
-      (set-arg-info generic-function)
-      (update-ctors 'remove-method
-                    :generic-function generic-function
-                    :method method)
-      (update-dfun generic-function)
-      (map-dependents generic-function
-                      (lambda (dep)
-                        (update-dependent generic-function
-                                          dep 'remove-method method)))))
+    (let ((lock (gf-lock generic-function)))
+      ;; System lock because interrupts need to be disabled as well:
+      ;; it would be bad to unwind and leave the gf in an inconsistent
+      ;; state.
+      (sb-thread::with-recursive-system-lock (lock)
+        (let* ((specializers (method-specializers method))
+               (methods (generic-function-methods generic-function))
+               (new-methods (remove method methods)))
+          (setf (method-generic-function method) nil
+                (generic-function-methods generic-function) new-methods)
+          (dolist (specializer (method-specializers method))
+            (remove-direct-method specializer method))
+          (set-arg-info generic-function)
+          (update-ctors 'remove-method
+                        :generic-function generic-function
+                        :method method)
+          (update-dfun generic-function)
+          (setf (gf-info-needs-update generic-function) t)
+          (map-dependents generic-function
+                          (lambda (dep)
+                            (update-dependent generic-function
+                                              dep 'remove-method method)))))))
   generic-function)
+
+
+;; Tell INFO about the generic function's methods' keys so that the
+;; compiler doesn't complain that the keys defined for some method are
+;; unrecognized.
+(sb-ext:without-package-locks
+  (defun sb-c::maybe-update-info-for-gf (name)
+    (let ((gf (if (fboundp name) (fdefinition name))))
+      (when (and gf (generic-function-p gf) (not (early-gf-p gf))
+                 (not (eq :declared (info :function :where-from name)))
+                 (gf-info-needs-update gf))
+        (let* ((methods (generic-function-methods gf))
+               (gf-lambda-list (generic-function-lambda-list gf))
+               (tfun (constantly t))
+               keysp)
+          (multiple-value-bind (gf.required gf.optional gf.restp gf.rest
+                                            gf.keyp gf.keys gf.allowp)
+              (parse-lambda-list gf-lambda-list)
+            (declare (ignore gf.rest))
+            ;; 7.6.4 point 5 probably entails that if any method says
+            ;; &allow-other-keys then the gf should be construed to
+            ;; accept any key.
+            (let* ((allowp (or gf.allowp
+                               (find '&allow-other-keys methods
+                                     :test #'find
+                                     :key #'method-lambda-list)))
+                   (ftype
+                    (specifier-type
+                     `(function
+                       (,@(mapcar tfun gf.required)
+                          ,@(if gf.optional
+                                `(&optional ,@(mapcar tfun gf.optional)))
+                          ,@(if gf.restp
+                                `(&rest t))
+                          ,@(when gf.keyp
+                              (let ((all-keys
+                                     (mapcar
+                                      (lambda (x)
+                                        (list x t))
+                                      (remove-duplicates
+                                       (nconc
+                                        (mapcan #'function-keywords methods)
+                                        (mapcar #'keyword-spec-name gf.keys))))))
+                                (when all-keys
+                                  (setq keysp t)
+                                  `(&key ,@all-keys))))
+                          ,@(when (and (not keysp) allowp)
+                              `(&key))
+                          ,@(when allowp
+                              `(&allow-other-keys)))
+                       *))))
+              (setf (info :function :type name) ftype
+                    (info :function :where-from name) :defined-method
+                    (gf-info-needs-update gf) nil)
+              ftype)))))))
 
 (defun compute-applicable-methods-function (generic-function arguments)
   (values (compute-applicable-methods-using-types
@@ -579,7 +675,7 @@
   (dolist (class classes)
     (dolist (other-class classes)
       (unless (eq class other-class)
-        (pushnew other-class (class-incompatible-superclass-list class))))))
+        (pushnew other-class (class-incompatible-superclass-list class) :test #'eq)))))
 
 (defun superclasses-compatible-p (class1 class2)
   (let ((cpl1 (cpl-or-nil class1))
@@ -610,7 +706,7 @@
    ))
 
 (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
-  nil)
+  (eql specl1 specl2))
 
 (defmethod same-specializer-p ((specl1 class) (specl2 class))
   (eq specl1 specl2))
@@ -629,6 +725,10 @@
 (defmethod specializer-class ((specializer eql-specializer))
   (class-of (slot-value specializer 'object)))
 
+(defun specializer-class-or-nil (specializer)
+  (and (standard-specializer-p specializer)
+       (specializer-class specializer)))
+
 (defun error-need-at-least-n-args (function n)
   (error 'simple-program-error
          :format-control "~@<The function ~2I~_~S ~I~_requires ~
@@ -683,7 +783,7 @@
           (let ((emf (get-effective-method-function generic-function
                                                     methods)))
             (invoke-emf emf args))
-          (apply #'no-applicable-method generic-function args)))))
+          (call-no-applicable-method generic-function args)))))
 
 (defun list-eq (x y)
   (loop (when (atom x) (return (eq x y)))
@@ -695,7 +795,7 @@
 (defvar *std-cam-methods* nil)
 
 (defun compute-applicable-methods-emf (generic-function)
-  (if (eq *boot-state* 'complete)
+  (if (eq **boot-state** 'complete)
       (let* ((cam (gdefinition 'compute-applicable-methods))
              (cam-methods (compute-applicable-methods-using-types
                            cam (list `(eql ,generic-function) t))))
@@ -716,22 +816,23 @@
   (let ((methods (generic-function-methods c-a-m-gf)))
     (if (and *old-c-a-m-gf-methods*
              (every (lambda (old-method)
-                      (member old-method methods))
+                      (member old-method methods :test #'eq))
                     *old-c-a-m-gf-methods*))
         (let ((gfs-to-do nil)
               (gf-classes-to-do nil))
           (dolist (method methods)
-            (unless (member method *old-c-a-m-gf-methods*)
+            (unless (member method *old-c-a-m-gf-methods* :test #'eq)
               (let ((specl (car (method-specializers method))))
                 (if (eql-specializer-p specl)
-                    (pushnew (specializer-object specl) gfs-to-do)
-                    (pushnew (specializer-class specl) gf-classes-to-do)))))
+                    (pushnew (specializer-object specl) gfs-to-do :test #'eq)
+                    (pushnew (specializer-class specl) gf-classes-to-do :test #'eq)))))
           (map-all-generic-functions
            (lambda (gf)
-             (when (or (member gf gfs-to-do)
+             (when (or (member gf gfs-to-do :test #'eq)
                        (dolist (class gf-classes-to-do nil)
                          (member class
-                                 (class-precedence-list (class-of gf)))))
+                                 (class-precedence-list (class-of gf))
+                                 :test #'eq)))
                (update-c-a-m-gf-info gf)))))
         (map-all-generic-functions #'update-c-a-m-gf-info))
     (setq *old-c-a-m-gf-methods* methods)))
@@ -802,8 +903,8 @@
                  (get-optimized-std-slot-value-using-class-method-function
                   class slotd type))
                 (method-alist
-                 `((,(car (or (member std-method methods)
-                              (member str-method methods)
+                 `((,(car (or (member std-method methods :test #'eq)
+                              (member str-method methods :test #'eq)
                               (bug "error in ~S"
                                    'get-accessor-method-function)))
                     ,optimized-std-fun)))
@@ -947,14 +1048,12 @@
          (nkeys (arg-info-nkeys arg-info))
          (metatypes (arg-info-metatypes arg-info))
          (wrappers (unless (eq nkeys 1) (make-list nkeys)))
-         (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
-         (default '(default)))
+         (precompute-p (gf-precompute-dfun-and-emf-p arg-info)))
     (flet ((add-class-list (classes)
              (when (or (null new-class) (memq new-class classes))
                (let ((%wrappers (get-wrappers-from-classes
                                  nkeys wrappers classes metatypes)))
-                 (when (and %wrappers
-                            (eq default (probe-cache cache %wrappers default)))
+                 (when (and %wrappers (not (probe-cache cache %wrappers)))
                    (let ((value (cond ((eq valuep t)
                                        (sdfun-for-caching generic-function
                                                           classes))
@@ -1084,35 +1183,6 @@
         (class-eq (cadr type))
         (class (cadr type)))))
 
-(defun precompute-effective-methods (gf caching-p &optional classes-list-p)
-  (let* ((arg-info (gf-arg-info gf))
-         (methods (generic-function-methods gf))
-         (precedence (arg-info-precedence arg-info))
-         (*in-precompute-effective-methods-p* t)
-         (classes-list nil))
-    (generate-discrimination-net-internal
-     gf methods nil
-     (lambda (methods known-types)
-       (when methods
-         (when classes-list-p
-           (push (mapcar #'class-from-type known-types) classes-list))
-         (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p
-                                      methods))))
-           (map-all-orders
-            methods precedence
-            (lambda (methods)
-              (get-secondary-dispatch-function1
-               gf methods known-types
-               nil caching-p no-eql-specls-p))))))
-     (lambda (position type true-value false-value)
-       (declare (ignore position type true-value false-value))
-       nil)
-     (lambda (type)
-       (if (and (consp type) (eq (car type) 'eql))
-           `(class-eq ,(class-of (cadr type)))
-           type)))
-    classes-list))
-
 ;;; We know that known-type implies neither new-type nor `(not ,new-type).
 (defun augment-type (new-type known-type)
   (if (or (eq known-type t)
@@ -1337,19 +1407,20 @@
     (let* ((name (generic-function-name generic-function))
            (arg-info (gf-arg-info generic-function))
            (metatypes (arg-info-metatypes arg-info))
+           (nargs (length metatypes))
            (applyp (arg-info-applyp arg-info))
-           (fmc-arg-info (cons (length metatypes) applyp))
+           (fmc-arg-info (cons nargs applyp))
            (arglist (if function-p
-                        (make-dfun-lambda-list metatypes applyp)
-                        (make-fast-method-call-lambda-list metatypes applyp))))
+                        (make-dfun-lambda-list nargs applyp)
+                        (make-fast-method-call-lambda-list nargs applyp))))
       (multiple-value-bind (cfunction constants)
           (get-fun1 `(lambda
                       ,arglist
                       ,@(unless function-p
-                          `((declare (ignore .pv-cell. .next-method-call.))))
+                          `((declare (ignore .pv. .next-method-call.))))
                       (locally (declare #.*optimize-speed*)
                                (let ((emf ,net))
-                                 ,(make-emf-call metatypes applyp 'emf))))
+                                 ,(make-emf-call nargs applyp 'emf))))
                     #'net-test-converter
                     #'net-code-converter
                     (lambda (form)
@@ -1470,63 +1541,92 @@
 
 (defun slot-value-using-class-dfun (class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-reader-function slotd) object))
+  (funcall (slot-info-reader (slot-definition-info slotd)) object))
 
 (defun setf-slot-value-using-class-dfun (new-value class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-writer-function slotd) new-value object))
+  (funcall (slot-info-writer (slot-definition-info slotd)) new-value object))
 
 (defun slot-boundp-using-class-dfun (class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-boundp-function slotd) object))
+  (funcall (slot-info-boundp (slot-definition-info slotd)) object))
 
 (defun special-case-for-compute-discriminating-function-p (gf)
   (or (eq gf #'slot-value-using-class)
       (eq gf #'(setf slot-value-using-class))
       (eq gf #'slot-boundp-using-class)))
 
-(defmethod compute-discriminating-function ((gf standard-generic-function))
-  (with-slots (dfun-state arg-info) gf
-    (when (special-case-for-compute-discriminating-function-p gf)
-      ;; if we have a special case for
-      ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
-      ;; special cases implemented as of 2006-05-09) any information
-      ;; in the cache is misplaced.
-      (aver (null dfun-state)))
-    (typecase dfun-state
-      (null
-       (when (eq gf #'compute-applicable-methods)
-         (update-all-c-a-m-gf-info gf))
-       (cond
-         ((eq gf #'slot-value-using-class)
-          (update-slot-value-gf-info gf 'reader)
-          #'slot-value-using-class-dfun)
-         ((eq gf #'(setf slot-value-using-class))
-          (update-slot-value-gf-info gf 'writer)
-          #'setf-slot-value-using-class-dfun)
-         ((eq gf #'slot-boundp-using-class)
-          (update-slot-value-gf-info gf 'boundp)
-          #'slot-boundp-using-class-dfun)
-         ((gf-precompute-dfun-and-emf-p arg-info)
-          (make-final-dfun gf))
-         (t
-          (make-initial-dfun gf))))
-      (function dfun-state)
-      (cons (car dfun-state)))))
-
-(defmethod update-gf-dfun ((class std-class) gf)
-  (let ((*new-class* class)
-        (arg-info (gf-arg-info gf)))
-    (cond
-      ((special-case-for-compute-discriminating-function-p gf))
-      ((gf-precompute-dfun-and-emf-p arg-info)
-       (multiple-value-bind (dfun cache info)
-           (make-final-dfun-internal gf)
-         (set-dfun gf dfun cache info) ; lest the cache be freed twice
-         (update-dfun gf dfun cache info))))))
+(let (initial-print-object-cache)
+  (defmethod compute-discriminating-function ((gf standard-generic-function))
+    (let ((dfun-state (slot-value gf 'dfun-state)))
+      (when (special-case-for-compute-discriminating-function-p gf)
+        ;; if we have a special case for
+        ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
+        ;; special cases implemented as of 2006-05-09) any information
+        ;; in the cache is misplaced.
+        (aver (null dfun-state)))
+      (typecase dfun-state
+        (null
+         (when (eq gf #'compute-applicable-methods)
+           (update-all-c-a-m-gf-info gf))
+         (cond
+           ((eq gf #'slot-value-using-class)
+            (update-slot-value-gf-info gf 'reader)
+            #'slot-value-using-class-dfun)
+           ((eq gf #'(setf slot-value-using-class))
+            (update-slot-value-gf-info gf 'writer)
+            #'setf-slot-value-using-class-dfun)
+           ((eq gf #'slot-boundp-using-class)
+            (update-slot-value-gf-info gf 'boundp)
+            #'slot-boundp-using-class-dfun)
+           ;; KLUDGE: PRINT-OBJECT is not a special-case in the sense
+           ;; of having a desperately special discriminating function.
+           ;; However, it is important that the machinery for printing
+           ;; conditions for stack and heap exhaustion, and the
+           ;; restarts offered by the debugger, work without consuming
+           ;; many extra resources.  This way (testing by name of GF
+           ;; rather than by identity) was the only way I found to get
+           ;; this to bootstrap, given that the PRINT-OBJECT generic
+           ;; function is only set up later, in
+           ;; SRC;PCL;PRINT-OBJECT.LISP.  -- CSR, 2008-06-09
+           ((eq (slot-value gf 'name) 'print-object)
+            (let ((nkeys (nth-value 3 (get-generic-fun-info gf))))
+              (cond ((/= nkeys 1)
+                     ;; KLUDGE: someone has defined a method
+                     ;; specialized on the second argument: punt.
+                     (setf initial-print-object-cache nil)
+                     (make-initial-dfun gf))
+                    (initial-print-object-cache
+                     (multiple-value-bind (dfun cache info)
+                         (make-caching-dfun gf (copy-cache initial-print-object-cache))
+                       (set-dfun gf dfun cache info)))
+                    ;; the relevant PRINT-OBJECT methods get defined
+                    ;; late, by delayed DEF!METHOD.  We mustn't cache
+                    ;; the effective method for our classes earlier
+                    ;; than the relevant PRINT-OBJECT methods are
+                    ;; defined...
+                    ((boundp 'sb-impl::*delayed-def!method-args*)
+                     (make-initial-dfun gf))
+                    (t (multiple-value-bind (dfun cache info)
+                           (make-final-dfun-internal
+                            gf
+                            (mapcar (lambda (x) (list (find-class x)))
+                                    '(sb-kernel::control-stack-exhausted
+                                      sb-kernel::binding-stack-exhausted
+                                      sb-kernel::alien-stack-exhausted
+                                      sb-kernel::heap-exhausted-error
+                                      restart)))
+                         (setq initial-print-object-cache cache)
+                         (set-dfun gf dfun (copy-cache cache) info))))))
+           ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
+            (make-final-dfun gf))
+           (t
+            (make-initial-dfun gf))))
+        (function dfun-state)
+        (cons (car dfun-state))))))
 
 (defmethod (setf class-name) (new-value class)
-  (let ((classoid (%wrapper-classoid (class-wrapper class))))
+  (let ((classoid (wrapper-classoid (class-wrapper class))))
     (if (and new-value (symbolp new-value))
         (setf (classoid-name classoid) new-value)
         (setf (classoid-name classoid) nil)))
@@ -1538,13 +1638,23 @@
   new-value)
 
 (defmethod function-keywords ((method standard-method))
-  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p
+                        keywords)
       (analyze-lambda-list (if (consp method)
                                (early-method-lambda-list method)
                                (method-lambda-list method)))
     (declare (ignore nreq nopt keysp restp))
     (values keywords allow-other-keys-p)))
 
+(defmethod function-keyword-parameters ((method standard-method))
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p
+                        keywords keyword-parameters)
+      (analyze-lambda-list (if (consp method)
+                               (early-method-lambda-list method)
+                               (method-lambda-list method)))
+    (declare (ignore nreq nopt keysp restp keywords))
+    (values keyword-parameters allow-other-keys-p)))
+
 (defun method-ll->generic-function-ll (ll)
   (multiple-value-bind
       (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
@@ -1555,67 +1665,59 @@
                      (eq s '&allow-other-keys)))
                ll)))
 
-;;; This is based on the rules of method lambda list congruency defined in
-;;; the spec. The lambda list it constructs is the pretty union of the
-;;; lambda lists of all the methods. It doesn't take method applicability
-;;; into account at all yet.
+;;; This is based on the rules of method lambda list congruency
+;;; defined in the spec. The lambda list it constructs is the pretty
+;;; union of the lambda lists of the generic function and of all its
+;;; methods.  It doesn't take method applicability into account at all
+;;; yet.
+
+;;; (Notice that we ignore &AUX variables as they're not part of the
+;;; "public interface" of a function.)
+
 (defmethod generic-function-pretty-arglist
            ((generic-function standard-generic-function))
-  (let ((methods (generic-function-methods generic-function)))
-    (if methods
-      (let ((arglist ()))
-        ;; arglist is constructed from the GF's methods - maybe with
-        ;; keys and rest stuff added
-        (multiple-value-bind (required optional rest key allow-other-keys)
-            (method-pretty-arglist (car methods))
-          (dolist (m (cdr methods))
-            (multiple-value-bind (method-key-keywords
-                                  method-allow-other-keys
-                                  method-key)
-                (function-keywords m)
-              ;; we've modified function-keywords to return what we want as
-              ;;  the third value, no other change here.
-              (declare (ignore method-key-keywords))
-              (setq key (union key method-key))
-              (setq allow-other-keys (or allow-other-keys
-                                         method-allow-other-keys))))
-          (when allow-other-keys
-            (setq arglist '(&allow-other-keys)))
-          (when key
-            (setq arglist (nconc (list '&key) key arglist)))
-          (when rest
-            (setq arglist (nconc (list '&rest rest) arglist)))
-          (when optional
-            (setq arglist (nconc (list '&optional) optional arglist)))
-          (nconc required arglist)))
-      ;; otherwise we take the lambda-list from the GF directly, with no
-      ;; other 'keys' added ...
-      (let ((lambda-list (generic-function-lambda-list generic-function)))
-        lambda-list))))
-
-(defmethod method-pretty-arglist ((method standard-method))
-  (let ((required ())
-        (optional ())
-        (rest nil)
-        (key ())
-        (allow-other-keys nil)
-        (state 'required)
-        (arglist (method-lambda-list method)))
-    (dolist (arg arglist)
-      (cond ((eq arg '&optional)         (setq state 'optional))
-            ((eq arg '&rest)             (setq state 'rest))
-            ((eq arg '&key)              (setq state 'key))
-            ((eq arg '&allow-other-keys) (setq allow-other-keys t))
-            ((memq arg lambda-list-keywords))
-            (t
-             (ecase state
-               (required (push arg required))
-               (optional (push arg optional))
-               (key      (push arg key))
-               (rest     (setq rest arg))))))
-    (values (nreverse required)
-            (nreverse optional)
-            rest
-            (nreverse key)
-            allow-other-keys)))
-
+  (let ((gf-lambda-list (generic-function-lambda-list generic-function))
+        (methods (generic-function-methods generic-function)))
+    (if (null methods)
+        gf-lambda-list
+        (multiple-value-bind (gf.required gf.optional gf.rest gf.keys gf.allowp)
+            (%split-arglist gf-lambda-list)
+          ;; Possibly extend the keyword parameters of the gf by
+          ;; additional key parameters of its methods:
+          (let ((methods.keys nil) (methods.allowp nil))
+            (dolist (m methods)
+              (multiple-value-bind (m.keyparams m.allow-other-keys)
+                  (function-keyword-parameters m)
+                (setq methods.keys (union methods.keys m.keyparams :key #'maybe-car))
+                (setq methods.allowp (or methods.allowp m.allow-other-keys))))
+            (let ((arglist '()))
+              (when (or gf.allowp methods.allowp)
+                (push '&allow-other-keys arglist))
+              (when (or gf.keys methods.keys)
+                ;; We make sure that the keys of the gf appear before
+                ;; those of its methods, since they're probably more
+                ;; generally appliable.
+                (setq arglist (nconc (list '&key) gf.keys
+                                     (nset-difference methods.keys gf.keys)
+                                     arglist)))
+              (when gf.rest
+                (setq arglist (nconc (list '&rest gf.rest) arglist)))
+              (when gf.optional
+                (setq arglist (nconc (list '&optional) gf.optional arglist)))
+              (nconc gf.required arglist)))))))
+
+(defun maybe-car (thing)
+  (if (listp thing)
+      (car thing)
+      thing))
+
+
+(defun %split-arglist (lambda-list)
+  ;; This function serves to shrink the number of returned values of
+  ;; PARSE-LAMBDA-LIST to something handier.
+  (multiple-value-bind (required optional restp rest keyp keys allowp
+                        auxp aux morep more-context more-count)
+      (parse-lambda-list lambda-list :silent t)
+    (declare (ignore restp keyp auxp aux morep))
+    (declare (ignore more-context more-count))
+    (values required optional rest keys allowp)))