0.7.1.2:

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

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 40d501e..6dc9fd3 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -508,19 +508,19 @@
 (defun compute-applicable-methods-function (generic-function arguments)
   (values (compute-applicable-methods-using-types
           generic-function
-          (types-from-arguments generic-function arguments 'eql))))
+          (types-from-args generic-function arguments 'eql))))
 
 (defmethod compute-applicable-methods
     ((generic-function generic-function) arguments)
   (values (compute-applicable-methods-using-types
           generic-function
-          (types-from-arguments generic-function arguments 'eql))))
+          (types-from-args generic-function arguments 'eql))))
 
 (defmethod compute-applicable-methods-using-classes
     ((generic-function generic-function) classes)
   (compute-applicable-methods-using-types
    generic-function
-   (types-from-arguments generic-function classes 'class-eq)))
+   (types-from-args generic-function classes 'class-eq)))
 
 (defun proclaim-incompatible-superclasses (classes)
   (setq classes (mapcar (lambda (class)
@@ -595,10 +595,9 @@
         function
         n))
 
-(defun types-from-arguments (generic-function arguments
-                            &optional type-modifier)
+(defun types-from-args (generic-function arguments &optional type-modifier)
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore applyp metatypes nkeys))
     (let ((types-rev nil))
       (dotimes-fixnum (i nreq)
@@ -1204,7 +1203,7 @@
                                             meth generic-function))))
                                  (cddr form)))
                    (default (car (last list))))
-              (list (list* ':mcase mp (nbutlast list))
+              (list (list* :mcase mp (nbutlast list))
                     (cdr default))))
            (t
             (default-constant-converter form))))))
@@ -1224,7 +1223,7 @@
 
 (defun convert-table (constant method-alist wrappers)
   (cond ((and (consp constant)
-             (eq (car constant) ':mcase))
+             (eq (car constant) :mcase))
         (let ((alist (mapcar (lambda (k+m)
                                (cons (car k+m)
                                      (convert-methods (cdr k+m)
@@ -1301,7 +1300,7 @@
     (format t "~&make-unordered-methods-emf ~S~%"
            (generic-function-name generic-function)))
   (lambda (&rest args)
-    (let* ((types (types-from-arguments generic-function args 'eql))
+    (let* ((types (types-from-args generic-function args 'eql))
           (smethods (sort-applicable-methods generic-function
                                              methods
                                              types))
@@ -1462,31 +1461,37 @@
 ;;; into account at all yet.
 (defmethod generic-function-pretty-arglist
           ((generic-function standard-generic-function))
-  (let ((methods (generic-function-methods generic-function))
-       (arglist ()))
-    (when methods
-      (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)))))
+  (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 ())