X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=dff22ed8f15d5b2428cd552069fbd56bb6bd3de6;hb=796d3abb79fdb3ac896b639b83756ef9d86007f6;hp=4fe14b3fcd2dfe65e3795d1ee83ef51ed6e90f58;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 4fe14b3..dff22ed 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -23,22 +23,6 @@
 
 (in-package "SB-PCL")
 
-(defmethod shared-initialize :after ((slotd standard-slot-definition)
-				     slot-names &key)
-  (declare (ignore slot-names))
-  (with-slots (allocation class)
-    slotd
-    (setq allocation (if (eq allocation :class) class allocation))))
-
-(defmethod shared-initialize :after ((slotd structure-slot-definition)
-				     slot-names
-				     &key (allocation :instance))
-  (declare (ignore slot-names))
-  (unless (eq allocation :instance)
-    (error "Structure slots must have :INSTANCE allocation.")))
-
-(defmethod inform-type-system-about-class ((class structure-class) (name t))
-  nil)
 
 ;;; methods
 ;;;
@@ -148,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))
@@ -158,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)))))
 
@@ -221,7 +205,7 @@
 		   lambda-list lambda-list-p))
 
   (when namep
-    (set-function-name generic-function name))
+    (set-fun-name generic-function name))
 
   (flet ((initarg-error (initarg value string)
 	   (error "when initializing the generic function ~S:~%~
@@ -291,7 +275,7 @@
     (cond ((or (null (fboundp generic-function-name))
 	       (not (generic-function-p
 		      (setq generic-function
-			    (symbol-function generic-function-name)))))
+			    (fdefinition generic-function-name)))))
 	   (error "~S does not name a generic function."
 		  generic-function-name))
 	  ((null (setq method (get-method generic-function
@@ -312,10 +296,9 @@
 			      lambda-list
 			      &rest other-initargs)
   (unless (and (fboundp generic-function-name)
-	       (typep (symbol-function generic-function-name)
-		      'generic-function))
-    (sb-kernel::style-warn "implicitly creating new generic function ~S"
-			   generic-function-name))
+	       (typep (fdefinition generic-function-name) 'generic-function))
+    (style-warn "implicitly creating new generic function ~S"
+		generic-function-name))
   ;; XXX What about changing the class of the generic function if
   ;; there is one? Whose job is that, anyway? Do we need something
   ;; kind of like CLASS-FOR-REDEFINITION?
@@ -334,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
@@ -397,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
@@ -411,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))
 
@@ -465,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))
@@ -479,69 +482,77 @@
 				   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
-			  allocate-instance shared-initialize
-			  initialize-instance))
-	    (update-make-instance-function-table (type-class
-						  (car specializers))))
+	  (update-ctors 'add-method
+			:generic-function generic-function
+			:method method)
 	  (update-dfun generic-function))
 	method)))
 
 (defun real-remove-method (generic-function method)
-  ;; Note: Error check prohibited by ANSI spec removed.
   (when  (eq generic-function (method-generic-function method))
-    (let* ((name	 (generic-function-name generic-function))
+    (let* ((name (generic-function-name generic-function))
 	   (specializers (method-specializers method))
-	   (methods      (generic-function-methods generic-function))
-	   (new-methods  (remove method methods)))
+	   (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)
-      (when (member name
-		    '(make-instance
-		      default-initargs
-		      allocate-instance shared-initialize initialize-instance))
-	(update-make-instance-function-table (type-class (car specializers))))
-      (update-dfun generic-function)
-      generic-function)))
+      (update-ctors 'remove-method
+		    :generic-function generic-function
+		    :method method)
+      (update-dfun generic-function)))
+  generic-function)
 
 (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)
@@ -549,8 +560,8 @@
 	(pushnew other-class (class-incompatible-superclass-list class))))))
 
 (defun superclasses-compatible-p (class1 class2)
-  (let ((cpl1 (class-precedence-list class1))
-	(cpl2 (class-precedence-list class2)))
+  (let ((cpl1 (cpl-or-nil class1))
+	(cpl2 (cpl-or-nil class2)))
     (dolist (sc1 cpl1 t)
       (dolist (ic (class-incompatible-superclass-list sc1))
 	(when (memq ic cpl2)
@@ -602,20 +613,24 @@
 		 (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 types-from-arguments (generic-function arguments
-			     &optional type-modifier)
+(defun error-need-at-least-n-args (function n)
+  (error "~@<The function ~2I~_~S ~I~_requires at least ~W argument~:P.~:>"
+	 function
+	 n))
+
+(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)
 	i
 	(unless arguments
-	  (error "The function ~S requires at least ~D arguments"
-		 (generic-function-name generic-function)
-		 nreq))
+	  (error-need-at-least-n-args (generic-function-name generic-function)
+				      nreq))
 	(let ((arg (pop arguments)))
 	  (push (if type-modifier `(,type-modifier ,arg) arg) types-rev)))
       (values (nreverse types-rev) arg-info))))
@@ -623,7 +638,7 @@
 (defun get-wrappers-from-classes (nkeys wrappers classes metatypes)
   (let* ((w wrappers) (w-tail w) (mt-tail metatypes))
     (dolist (class (if (listp classes) classes (list classes)))
-      (unless (eq 't (car mt-tail))
+      (unless (eq t (car mt-tail))
 	(let ((c-w (class-wrapper class)))
 	  (unless c-w (return-from get-wrappers-from-classes nil))
 	  (if (eql nkeys 1)
@@ -649,13 +664,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)))
@@ -686,8 +701,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))
@@ -698,12 +713,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)))
 
@@ -742,6 +757,22 @@
 			   *standard-method-combination*))
 	      type)))))
 
+
+;;; CMUCL (Gerd's PCL, 2002-04-25) comment:
+;;;
+;;; Return two values.  First value is a function to be stored in
+;;; effective slot definition SLOTD for reading it with
+;;; SLOT-VALUE-USING-CLASS, setting it with (SETF
+;;; SLOT-VALUE-USING-CLASS) or testing it with
+;;; SLOT-BOUNDP-USING-CLASS.  GF is one of these generic functions,
+;;; TYPE is one of the symbols READER, WRITER, BOUNDP.  CLASS is
+;;; SLOTD's class.
+;;;
+;;; Second value is true if the function returned is one of the
+;;; optimized standard functions for the purpose, which are used
+;;; when only standard methods are applicable.
+;;;
+;;; FIXME: Change all these wacky function names to something sane.
 (defun get-accessor-method-function (gf type class slotd)
   (let* ((std-method (standard-svuc-method type))
 	 (str-method (structure-svuc-method type))
@@ -752,27 +783,25 @@
     (values
      (if std-p
 	 (get-optimized-std-accessor-method-function class slotd type)
-	 (get-accessor-from-svuc-method-function
-	  class slotd
-	  (get-secondary-dispatch-function
-	   gf methods types
-	   `((,(car (or (member std-method methods)
-			(member str-method methods)
-			(error "error in get-accessor-method-function")))
-	      ,(get-optimized-std-slot-value-using-class-method-function
-		class slotd type)))
-	   (unless (and (eq type 'writer)
-			(dolist (method methods t)
-			  (unless (eq (car (method-specializers method))
-				      *the-class-t*)
-			    (return nil))))
-	     (let ((wrappers (list (wrapper-of class)
-				   (class-wrapper class)
-				   (wrapper-of slotd))))
-	       (if (eq type 'writer)
-		   (cons (class-wrapper *the-class-t*) wrappers)
-		   wrappers))))
-	  type))
+	 (let* ((optimized-std-fun
+		 (get-optimized-std-slot-value-using-class-method-function
+		  class slotd type))
+		(method-alist
+		 `((,(car (or (member std-method methods)
+			      (member str-method methods)
+			      (bug "error in ~S"
+				   'get-accessor-method-function)))
+		    ,optimized-std-fun)))
+		(wrappers
+		 (let ((wrappers (list (wrapper-of class)
+				       (class-wrapper class)
+				       (wrapper-of slotd))))
+		   (if (eq type 'writer)
+		       (cons (class-wrapper *the-class-t*) wrappers)
+		       wrappers)))
+		(sdfun (get-secondary-dispatch-function 
+			gf methods types method-alist wrappers)))
+	   (get-accessor-from-svuc-method-function class slotd sdfun type)))
      std-p)))
 
 ;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp)
@@ -851,8 +880,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)
@@ -877,8 +906,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)
@@ -900,7 +929,7 @@
 				      ((eq valuep :constant-value)
 				       (value-for-caching generic-function
 							  classes)))))
-		     (setq cache (fill-cache cache wrappers value t))))))))
+		     (setq cache (fill-cache cache wrappers value))))))))
       (if classes-list
 	  (mapc #'add-class-list classes-list)
 	  (dolist (method (generic-function-methods generic-function))
@@ -911,9 +940,10 @@
 
 (defmacro class-test (arg class)
   (cond ((eq class *the-class-t*)
-	 't)
+	 t)
 	((eq class *the-class-slot-object*)
-	 `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class)))
+	 `(not (typep (classoid-of ,arg)
+		      'built-in-classoid)))
 	((eq class *the-class-std-object*)
 	 `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
 	((eq class *the-class-standard-object*)
@@ -937,21 +967,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))
@@ -961,49 +991,49 @@
 	 (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)
-  (if (or (atom type) (eq (car type) 't))
+  (if (or (atom type) (eq (car type) t))
       *the-class-t*
       (case (car type)
 	(and (dolist (type (cdr type) *the-class-t*)
@@ -1022,30 +1052,30 @@
 	 (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).
 (defun augment-type (new-type known-type)
-  (if (or (eq known-type 't)
+  (if (or (eq known-type t)
 	  (eq (car new-type) 'eql))
       new-type
       (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and))
@@ -1053,16 +1083,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))
@@ -1071,7 +1101,7 @@
 	       (if p-tail
 		   (let* ((position (car p-tail))
 			  (known-type (or (nth position types) t)))
-		     (if (eq (nth position metatypes) 't)
+		     (if (eq (nth position metatypes) t)
 			 (do-column (cdr p-tail) contenders
 				    (cons (cons position known-type)
 					  known-types))
@@ -1119,7 +1149,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 ()))))
 
@@ -1132,10 +1162,10 @@
 (defvar *case-table-limit* 10)
 
 (defun compute-mcase-parameters (case-list)
-  (unless (eq 't (caar (last case-list)))
+  (unless (eq t (caar (last case-list)))
     (error "The key for the last case arg to mcase was not T"))
   (let* ((eq-p (dolist (case case-list t)
-		 (unless (or (eq (car case) 't)
+		 (unless (or (eq (car case) t)
 			     (symbolp (caar case)))
 		   (return nil))))
 	 (len (1- (length case-list)))
@@ -1151,7 +1181,7 @@
     (list eq-p type)))
 
 (defmacro mlookup (key info default &optional eq-p type)
-  (unless (or (eq eq-p 't) (null eq-p))
+  (unless (or (eq eq-p t) (null eq-p))
     (error "Invalid eq-p argument"))
   (ecase type
     (:simple
@@ -1206,15 +1236,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))))))
@@ -1234,12 +1264,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)
@@ -1268,42 +1298,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-function-name function
-						  `(sdfun-method ,name))
-		     :arg-info fmc-arg-info))))))))))
+	  (get-fun1 `(,(if function-p
+			   '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)
 
@@ -1311,13 +1340,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
@@ -1329,12 +1358,12 @@
 ;;; the funcallable instance function of the generic function for which
 ;;; it was computed.
 ;;;
-;;; More precisely, if compute-discriminating-function is called with an
-;;; argument <gf1>, and returns a result <df1>, that result must not be
-;;; passed to apply or funcall directly. Rather, <df1> must be stored as
-;;; the funcallable instance function of the same generic function <gf1>
-;;; (using set-funcallable-instance-function). Then the generic function
-;;; can be passed to funcall or apply.
+;;; More precisely, if compute-discriminating-function is called with
+;;; an argument <gf1>, and returns a result <df1>, that result must
+;;; not be passed to apply or funcall directly. Rather, <df1> must be
+;;; stored as the funcallable instance function of the same generic
+;;; function <gf1> (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the
+;;; generic function can be passed to funcall or apply.
 ;;;
 ;;; An important exception is that methods on this generic function are
 ;;; permitted to return a function which itself ends up calling the value
@@ -1345,7 +1374,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))))
 ;;;
@@ -1372,7 +1401,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-function
@@ -1385,11 +1414,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-function
 ;;;		  gf
-;;;		  #'(lambda (a) ..))
+;;;		  (lambda (a) ..))
 ;;;		(funcall gf arg))
 ;;;	       (t
 ;;;		<call-a-method-of-gf>))))
@@ -1462,9 +1491,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
@@ -1473,31 +1502,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 ())
@@ -1508,11 +1543,11 @@
 	(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))
+      (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))