X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=9f43912edef5246e960ef919c442091a68c77904;hb=c41d75f1d2defd6234e644ef2b40440a5d1526c5;hp=40d501e40cdc3f0d67fa62e0011a53c866c585f7;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 40d501e..9f43912 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -403,6 +403,14 @@
 	 (when restp
 	       `(&rest ,(intern "Discriminating Function &rest Arg")))))
 
+(defmethod generic-function-argument-precedence-order
+    ((gf standard-generic-function))
+  (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)
+	collect (nth argument-position lambda-list)))
+
 (defmethod generic-function-lambda-list ((gf generic-function))
   (gf-lambda-list gf))
 
@@ -508,19 +516,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 +603,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 +1211,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 +1231,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 +1308,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 +1469,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 ())