X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=c836f803603f5ae9119545a9fb1577e2ba29c359;hb=342b4bc80d748ced4f8b949ddb3e5b290520fe7d;hp=bea7cd3838f86d1edde45787fa1d44135fd53221;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index bea7cd3..c836f80 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -132,9 +132,9 @@
     (let ((check-qualifiers    (legal-qualifiers-p method qualifiers))
 	  (check-lambda-list   (legal-lambda-list-p method lambda-list))
 	  (check-specializers  (legal-specializers-p method specializers))
-	  (check-function      (legal-method-function-p method
-							(or function
-							    fast-function)))
+	  (check-fun (legal-method-function-p method
+					      (or function
+						  fast-function)))
 	  (check-documentation (legal-documentation-p method documentation)))
       (unless (eq check-qualifiers t)
 	(lose :qualifiers qualifiers check-qualifiers))
@@ -142,8 +142,8 @@
 	(lose :lambda-list lambda-list check-lambda-list))
       (unless (eq check-specializers t)
 	(lose :specializers specializers check-specializers))
-      (unless (eq check-function t)
-	(lose :function function check-function))
+      (unless (eq check-fun t)
+	(lose :function function check-fun))
       (unless (eq check-documentation t)
 	(lose :documentation documentation check-documentation)))))
 
@@ -317,10 +317,12 @@
 					 &optional (errorp t))
   (let ((hit 
 	  (dolist (method (generic-function-methods generic-function))
-	    (when (and (equal qualifiers (method-qualifiers method))
-		       (every #'same-specializer-p specializers
-			      (method-specializers method)))
-	      (return method)))))
+	    (let ((mspecializers (method-specializers method)))
+	      (when (and (equal qualifiers (method-qualifiers method))
+			 (= (length specializers) (length mspecializers))
+			 (every #'same-specializer-p specializers
+				(method-specializers method)))
+		(return method))))))
     (cond (hit hit)
 	  ((null errorp) nil)
 	  (t
@@ -380,10 +382,11 @@
     ;; in the usual sort of way. For efficiency don't bother to
     ;; keep specialized-argument-positions sorted, rather depend
     ;; on our caller to do that.
-    (iterate ((type-spec (list-elements (method-specializers method)))
-	      (pos (interval :from 0)))
-      (unless (eq type-spec *the-class-t*)
-	(pushnew pos specialized-argument-positions)))
+    (let ((pos 0))
+      (dolist (type-spec (method-specializers method))
+        (unless (eq type-spec *the-class-t*)
+          (pushnew pos specialized-argument-positions))
+        (incf pos)))
     ;; Finally merge the values for this method into the values
     ;; for the exisiting methods and return them. Note that if
     ;; num-of-requireds is NIL it means this is the first method
@@ -394,13 +397,22 @@
 	    specialized-argument-positions)))
 
 (defun make-discriminating-function-arglist (number-required-arguments restp)
-  (nconc (gathering ((args (collecting)))
-	   (iterate ((i (interval :from 0 :below number-required-arguments)))
-	     (gather (intern (format nil "Discriminating Function Arg ~D" i))
-		     args)))
+  (nconc (let ((args nil))
+           (dotimes (i number-required-arguments)
+             (push (intern (format nil "Discriminating Function Arg ~D" i))
+                   args))
+           (nreverse args))
 	 (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))
 
@@ -448,12 +460,20 @@
 	(real-add-method gf (pop methods) methods)))
 
 (defun real-add-method (generic-function method &optional skip-dfun-update-p)
-  (if (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))
-
+  (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)
+	   (multiple-value-bind (a-nreq a-nopt a-keyp a-restp)
+	       (analyze-lambda-list (method-lambda-list method-a))
+	     (multiple-value-bind (b-nreq b-nopt b-keyp b-restp)
+		 (analyze-lambda-list (method-lambda-list method-b))
+	       (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))
@@ -462,17 +482,31 @@
 				   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 existing (remove-method generic-function existing))
+	;; 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))
 
 	(setf (method-generic-function method) generic-function)
 	(pushnew method (generic-function-methods generic-function))
 	(dolist (specializer specializers)
 	  (add-direct-method specializer method))
-	(set-arg-info generic-function :new-method 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))))
 	(unless skip-dfun-update-p
 	  (when (member name
 			'(make-instance default-initargs
@@ -506,25 +540,25 @@
 (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)
-			    (if (symbolp class)
-				(find-class class)
-				class))
+  (setq classes (mapcar (lambda (class)
+			  (if (symbolp class)
+			      (find-class class)
+			      class))
 			classes))
   (dolist (class classes)
     (dolist (other-class classes)
@@ -585,7 +619,7 @@
 		 (make-internal-reader-method-function
 		  'standard-generic-function 'arg-info)
 		 t)))
-	#'(lambda (&rest args) (funcall mf args nil))))
+	(lambda (&rest args) (funcall mf args nil))))
 
 
 (defun error-need-at-least-n-args (function n)
@@ -593,10 +627,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)
@@ -637,13 +670,13 @@
 			 :constant-value)))
 
 (defun default-secondary-dispatch-function (generic-function)
-  #'(lambda (&rest args)
-      (let ((methods (compute-applicable-methods generic-function args)))
-	(if methods
-	    (let ((emf (get-effective-method-function generic-function
-						      methods)))
-	      (invoke-emf emf args))
-	    (apply #'no-applicable-method generic-function args)))))
+  (lambda (&rest args)
+    (let ((methods (compute-applicable-methods generic-function args)))
+      (if methods
+	  (let ((emf (get-effective-method-function generic-function
+						    methods)))
+	    (invoke-emf emf args))
+	  (apply #'no-applicable-method generic-function args)))))
 
 (defun list-eq (x y)
   (loop (when (atom x) (return (eq x y)))
@@ -674,8 +707,8 @@
 (defun update-all-c-a-m-gf-info (c-a-m-gf)
   (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))
+	     (every (lambda (old-method)
+		      (member old-method methods))
 		    *old-c-a-m-gf-methods*))
 	(let ((gfs-to-do nil)
 	      (gf-classes-to-do nil))
@@ -686,12 +719,12 @@
 		    (pushnew (specializer-object specl) gfs-to-do)
 		    (pushnew (specializer-class specl) gf-classes-to-do)))))
 	  (map-all-generic-functions
-	   #'(lambda (gf)
-	       (when (or (member gf gfs-to-do)
-			 (dolist (class gf-classes-to-do nil)
-			   (member class
-				   (class-precedence-list (class-of gf)))))
-		 (update-c-a-m-gf-info gf)))))
+	   (lambda (gf)
+	     (when (or (member gf gfs-to-do)
+		       (dolist (class gf-classes-to-do nil)
+			 (member class
+				 (class-precedence-list (class-of gf)))))
+	       (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)))
 
@@ -839,8 +872,8 @@
 		      (eq spec *the-class-structure-object*)))
 	     (let ((sc (class-direct-subclasses spec)))
 	       (when sc
-		 (mapcan #'(lambda (class)
-			     (mec-all-classes-internal class precompute-p))
+		 (mapcan (lambda (class)
+			   (mec-all-classes-internal class precompute-p))
 			 sc))))))
 
 (defun mec-all-classes (spec precompute-p)
@@ -865,8 +898,8 @@
 					       precompute-p))
 	     (all-class-lists (mec-all-class-lists (cdr spec-list)
 						   precompute-p)))
-	(mapcan #'(lambda (list)
-		    (mapcar #'(lambda (c) (cons c list)) car-all-classes))
+	(mapcan (lambda (list)
+		  (mapcar (lambda (c) (cons c list)) car-all-classes))
 		all-class-lists))))
 
 (defun make-emf-cache (generic-function valuep cache classes-list new-class)
@@ -925,21 +958,21 @@
 ;;; This is CASE, but without gensyms.
 (defmacro scase (arg &rest clauses)
   `(let ((.case-arg. ,arg))
-     (cond ,@(mapcar #'(lambda (clause)
-			 (list* (cond ((null (car clause))
-				       nil)
-				      ((consp (car clause))
-				       (if (null (cdar clause))
-					   `(eql .case-arg.
-						 ',(caar clause))
-					   `(member .case-arg.
-						    ',(car clause))))
-				      ((member (car clause) '(t otherwise))
-				       `t)
-				      (t
-				       `(eql .case-arg. ',(car clause))))
-				nil
-				(cdr clause)))
+     (cond ,@(mapcar (lambda (clause)
+		       (list* (cond ((null (car clause))
+				     nil)
+				    ((consp (car clause))
+				     (if (null (cdar clause))
+					 `(eql .case-arg.
+					       ',(caar clause))
+					 `(member .case-arg.
+						  ',(car clause))))
+				    ((member (car clause) '(t otherwise))
+				     `t)
+				    (t
+				     `(eql .case-arg. ',(car clause))))
+			      nil
+			      (cdr clause)))
 		     clauses))))
 
 (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses))
@@ -949,45 +982,45 @@
 	 (precedence (arg-info-precedence arg-info)))
     (generate-discrimination-net-internal
      generic-function methods types
-     #'(lambda (methods known-types)
-	 (if (or sorted-p
-		 (block one-order-p
-		   (let ((sorted-methods nil))
-		     (map-all-orders
-		      (copy-list methods) precedence
-		      #'(lambda (methods)
-			  (when sorted-methods (return-from one-order-p nil))
-			  (setq sorted-methods methods)))
-		     (setq methods sorted-methods))
-		   t))
-	     `(methods ,methods ,known-types)
-	     `(unordered-methods ,methods ,known-types)))
-     #'(lambda (position type true-value false-value)
-	 (let ((arg (dfun-arg-symbol position)))
-	   (if (eq (car type) 'eql)
-	       (let* ((false-case-p (and (consp false-value)
-					 (or (eq (car false-value) 'scase)
-					     (eq (car false-value) 'mcase))
-					 (eq arg (cadr false-value))))
-		      (false-clauses (if false-case-p
-					 (cddr false-value)
-					 `((t ,false-value))))
-		      (case-sym (if (and (dnet-methods-p true-value)
-					 (if false-case-p
-					     (eq (car false-value) 'mcase)
-					     (dnet-methods-p false-value)))
-				    'mcase
-				    'scase))
-		      (type-sym `(,(cadr type))))
-		 `(,case-sym ,arg
-		    (,type-sym ,true-value)
-		    ,@false-clauses))
-	       `(if ,(let ((arg (dfun-arg-symbol position)))
-		       (case (car type)
-			 (class    `(class-test    ,arg ,(cadr type)))
-			 (class-eq `(class-eq-test ,arg ,(cadr type)))))
-		    ,true-value
-		    ,false-value))))
+     (lambda (methods known-types)
+       (if (or sorted-p
+	       (block one-order-p
+		 (let ((sorted-methods nil))
+		   (map-all-orders
+		    (copy-list methods) precedence
+		    (lambda (methods)
+		      (when sorted-methods (return-from one-order-p nil))
+		      (setq sorted-methods methods)))
+		   (setq methods sorted-methods))
+		 t))
+	   `(methods ,methods ,known-types)
+	   `(unordered-methods ,methods ,known-types)))
+     (lambda (position type true-value false-value)
+       (let ((arg (dfun-arg-symbol position)))
+	 (if (eq (car type) 'eql)
+	     (let* ((false-case-p (and (consp false-value)
+				       (or (eq (car false-value) 'scase)
+					   (eq (car false-value) 'mcase))
+				       (eq arg (cadr false-value))))
+		    (false-clauses (if false-case-p
+				       (cddr false-value)
+				       `((t ,false-value))))
+		    (case-sym (if (and (dnet-methods-p true-value)
+				       (if false-case-p
+					   (eq (car false-value) 'mcase)
+					   (dnet-methods-p false-value)))
+				  'mcase
+				  'scase))
+		    (type-sym `(,(cadr type))))
+	       `(,case-sym ,arg
+			   (,type-sym ,true-value)
+			   ,@false-clauses))
+	     `(if ,(let ((arg (dfun-arg-symbol position)))
+		     (case (car type)
+		       (class    `(class-test    ,arg ,(cadr type)))
+		       (class-eq `(class-eq-test ,arg ,(cadr type)))))
+		  ,true-value
+		  ,false-value))))
      #'identity)))
 
 (defun class-from-type (type)
@@ -1010,25 +1043,25 @@
 	 (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)))
+     (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).
@@ -1041,16 +1074,16 @@
 			(list known-type))))
 	(unless (eq (car new-type) 'not)
 	  (setq so-far
-		(mapcan #'(lambda (type)
-			    (unless (*subtypep new-type type)
-			      (list type)))
+		(mapcan (lambda (type)
+			  (unless (*subtypep new-type type)
+			    (list type)))
 			so-far)))
 	(if (null so-far)
 	    new-type
 	    `(and ,new-type ,@so-far)))))
 
 (defun generate-discrimination-net-internal
-    (gf methods types methods-function test-function type-function)
+    (gf methods types methods-function test-fun type-function)
   (let* ((arg-info (gf-arg-info gf))
 	 (precedence (arg-info-precedence arg-info))
 	 (nreq (arg-info-number-required arg-info))
@@ -1107,7 +1140,7 @@
 				    known-types))))
 			 (cond ((determined-to-be nil) (do-if nil t))
 			       ((determined-to-be t)   (do-if t   t))
-			       (t (funcall test-function position type
+			       (t (funcall test-fun position type
 					   (do-if t) (do-if nil))))))))))
       (do-column precedence methods ()))))
 
@@ -1194,15 +1227,15 @@
 	  (case (car form)
 	    (mcase
 	     (let* ((mp (compute-mcase-parameters (cddr form)))
-		    (list (mapcar #'(lambda (clause)
-				      (let ((key (car clause))
-					    (meth (cadr clause)))
-					(cons (if (consp key) (car key) key)
-					      (methods-converter
-					       meth generic-function))))
+		    (list (mapcar (lambda (clause)
+				    (let ((key (car clause))
+					  (meth (cadr clause)))
+				      (cons (if (consp key) (car key) key)
+					    (methods-converter
+					     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))))))
@@ -1222,12 +1255,12 @@
 
 (defun convert-table (constant method-alist wrappers)
   (cond ((and (consp constant)
-	      (eq (car constant) ':mcase))
-	 (let ((alist (mapcar #'(lambda (k+m)
-				  (cons (car k+m)
-					(convert-methods (cdr k+m)
-							 method-alist
-							 wrappers)))
+	      (eq (car constant) :mcase))
+	 (let ((alist (mapcar (lambda (k+m)
+				(cons (car k+m)
+				      (convert-methods (cdr k+m)
+						       method-alist
+						       wrappers)))
 			      (cddr constant)))
 	       (mp (cadr constant)))
 	   (ecase (cadr mp)
@@ -1256,41 +1289,41 @@
 			(make-dfun-lambda-list metatypes applyp)
 			(make-fast-method-call-lambda-list metatypes applyp))))
       (multiple-value-bind (cfunction constants)
-	  (get-function1 `(,(if function-p
-				      'sb-kernel:instance-lambda
-				      'lambda)
-			   ,arglist
-				 ,@(unless function-p
-				     `((declare (ignore .pv-cell.
-							.next-method-call.))))
-				 (locally (declare #.*optimize-speed*)
-				   (let ((emf ,net))
-				     ,(make-emf-call metatypes applyp 'emf))))
-			 #'net-test-converter
-			 #'net-code-converter
-			 #'(lambda (form)
-			     (net-constant-converter form generic-function)))
-	#'(lambda (method-alist wrappers)
-	    (let* ((alist (list nil))
-		   (alist-tail alist))
-	      (dolist (constant constants)
-		(let* ((a (or (dolist (a alist nil)
-				(when (eq (car a) constant)
-				  (return a)))
-			      (cons constant
-				    (or (convert-table
-					 constant method-alist wrappers)
-					(convert-methods
-					 constant method-alist wrappers)))))
-		       (new (list a)))
-		  (setf (cdr alist-tail) new)
-		  (setf alist-tail new)))
-	      (let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
-		(if function-p
-		    function
-		    (make-fast-method-call
-		     :function (set-fun-name function `(sdfun-method ,name))
-		     :arg-info fmc-arg-info))))))))))
+	  (get-fun1 `(,(if function-p
+			   'sb-kernel:instance-lambda
+			   'lambda)
+		      ,arglist
+		      ,@(unless function-p
+			  `((declare (ignore .pv-cell.
+					     .next-method-call.))))
+		      (locally (declare #.*optimize-speed*)
+			       (let ((emf ,net))
+				 ,(make-emf-call metatypes applyp 'emf))))
+		    #'net-test-converter
+		    #'net-code-converter
+		    (lambda (form)
+		      (net-constant-converter form generic-function)))
+	(lambda (method-alist wrappers)
+	  (let* ((alist (list nil))
+		 (alist-tail alist))
+	    (dolist (constant constants)
+	      (let* ((a (or (dolist (a alist nil)
+			      (when (eq (car a) constant)
+				(return a)))
+			    (cons constant
+				  (or (convert-table
+				       constant method-alist wrappers)
+				      (convert-methods
+				       constant method-alist wrappers)))))
+		     (new (list a)))
+		(setf (cdr alist-tail) new)
+		(setf alist-tail new)))
+	    (let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
+	      (if function-p
+		  function
+		  (make-fast-method-call
+		   :function (set-fun-name function `(sdfun-method ,name))
+		   :arg-info fmc-arg-info))))))))))
 
 (defvar *show-make-unordered-methods-emf-calls* nil)
 
@@ -1298,13 +1331,13 @@
   (when *show-make-unordered-methods-emf-calls*
     (format t "~&make-unordered-methods-emf ~S~%"
 	    (generic-function-name generic-function)))
-  #'(lambda (&rest args)
-      (let* ((types (types-from-arguments generic-function args 'eql))
-	     (smethods (sort-applicable-methods generic-function
-						methods
-						types))
-	     (emf (get-effective-method-function generic-function smethods)))
-	(invoke-emf emf args))))
+  (lambda (&rest args)
+    (let* ((types (types-from-args generic-function args 'eql))
+	   (smethods (sort-applicable-methods generic-function
+					      methods
+					      types))
+	   (emf (get-effective-method-function generic-function smethods)))
+      (invoke-emf emf args))))
 
 ;;; The value returned by compute-discriminating-function is a function
 ;;; object. It is called a discriminating function because it is called
@@ -1332,7 +1365,7 @@
 ;;;
 ;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
 ;;;     (let ((std (call-next-method)))
-;;;       #'(lambda (arg)
+;;;       (lambda (arg)
 ;;;	    (print (list 'call-to-gf gf arg))
 ;;;	    (funcall std arg))))
 ;;;
@@ -1359,7 +1392,7 @@
 ;;; itself in accordance with this protocol:
 ;;;
 ;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
-;;;     #'(lambda (arg)
+;;;     (lambda (arg)
 ;;;	 (cond (<some condition>
 ;;;		<store some info in the generic function>
 ;;;		(set-funcallable-instance-fun
@@ -1372,11 +1405,11 @@
 ;;; Whereas this code would not be legal:
 ;;;
 ;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
-;;;     #'(lambda (arg)
+;;;     (lambda (arg)
 ;;;	 (cond (<some condition>
 ;;;		(set-funcallable-instance-fun
 ;;;		  gf
-;;;		  #'(lambda (a) ..))
+;;;		  (lambda (a) ..))
 ;;;		(funcall gf arg))
 ;;;	       (t
 ;;;		<call-a-method-of-gf>))))
@@ -1449,9 +1482,9 @@
       (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
       (analyze-lambda-list ll)
     (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
-    (remove-if #'(lambda (s)
-		   (or (memq s keyword-parameters)
-		       (eq s '&allow-other-keys)))
+    (remove-if (lambda (s)
+		 (or (memq s keyword-parameters)
+		     (eq s '&allow-other-keys)))
 	       ll)))
 
 ;;; This is based on the rules of method lambda list congruency defined in
@@ -1460,31 +1493,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 ())