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

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index bea7cd3..437e146 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -89,10 +89,7 @@
       "is not a non-null atom"))
 
 (defmethod legal-slot-name-p ((object standard-method) x)
-  (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
-	((keywordp x)      "is a keyword and so cannot be bound")
-	((memq x '(t nil)) "cannot be bound")
-	((constantp x)     "is a constant and so cannot be bound")
+  (cond ((not (symbolp x)) "is not a symbol")
 	(t t)))
 
 (defmethod legal-specializers-p ((object standard-method) x)
@@ -132,9 +129,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 +139,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)))))
 
@@ -266,30 +263,7 @@
     (apply #'call-next-method generic-function initargs)))
 ||#
 
-;;; These three are scheduled for demolition.
-
-(defmethod remove-named-method (generic-function-name argument-specifiers
-						      &optional extra)
-  (let ((generic-function ())
-	(method ()))
-    (cond ((or (null (fboundp generic-function-name))
-	       (not (generic-function-p
-		      (setq generic-function
-			    (fdefinition generic-function-name)))))
-	   (error "~S does not name a generic function."
-		  generic-function-name))
-	  ((null (setq method (get-method generic-function
-					  extra
-					  (parse-specializers
-					    argument-specifiers)
-					  nil)))
-	   (error "There is no method for the generic function ~S~%~
-		   which matches the ARGUMENT-SPECIFIERS ~S."
-		  generic-function
-		  argument-specifiers))
-	  (t
-	   (remove-method generic-function method)))))
-
+;;; These two are scheduled for demolition.
 (defun real-add-named-method (generic-function-name
 			      qualifiers
 			      specializers
@@ -297,8 +271,8 @@
 			      &rest other-initargs)
   (unless (and (fboundp generic-function-name)
 	       (typep (fdefinition generic-function-name) 'generic-function))
-    (sb-kernel::style-warn "implicitly creating new generic function ~S"
-			   generic-function-name))
+    (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?
@@ -311,26 +285,41 @@
 				     :specializers specs
 				     :lambda-list lambda-list
 				     other-initargs)))
-    (add-method generic-function new)))
+    (add-method generic-function new)
+    new))
 
 (defun real-get-method (generic-function qualifiers specializers
 					 &optional (errorp t))
-  (let ((hit 
+  (let* ((lspec (length specializers))
+	 (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)))
+	      (aver (= lspec (length mspecializers)))
+	      (when (and (equal qualifiers (method-qualifiers method))
+			 (every #'same-specializer-p specializers
+				(method-specializers method)))
+		(return method))))))
     (cond (hit hit)
 	  ((null errorp) nil)
 	  (t
-	   (error "no method on ~S with qualifiers ~:S and specializers ~:S"
+	   (error "~@<There is no method on ~S with ~
+                   ~:[no qualifiers~;~:*qualifiers ~S~] ~
+                   and specializers ~S.~@:>"
 		  generic-function qualifiers specializers)))))
-
+
 (defmethod find-method ((generic-function standard-generic-function)
 			qualifiers specializers &optional (errorp t))
-  (real-get-method generic-function qualifiers
-		   (parse-specializers specializers) errorp))
+  (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function)))))
+    ;; ANSI: "The specializers argument contains the parameter
+    ;; specializers for the method. It must correspond in length to
+    ;; the number of required arguments of the generic function, or an
+    ;; error is signaled."
+    (when (/= (length specializers) nreq)
+      (error "~@<The generic function ~S takes ~D required argument~:P; ~
+              was asked to find a method with specializers ~S~@:>"
+	     generic-function nreq specializers))
+    (real-get-method generic-function qualifiers
+		     (parse-specializers specializers) errorp)))
 
 ;;; 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
@@ -380,10 +369,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 +384,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 +447,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,69 +469,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)))
+	generic-function)))
 
 (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)
@@ -532,8 +547,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)
@@ -585,7 +600,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 +608,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 +651,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 +688,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 +700,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)))
 
@@ -730,6 +744,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))
@@ -740,27 +770,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)
@@ -779,6 +807,9 @@
 (defvar *standard-slot-value-using-class-method* nil)
 (defvar *standard-setf-slot-value-using-class-method* nil)
 (defvar *standard-slot-boundp-using-class-method* nil)
+(defvar *condition-slot-value-using-class-method* nil)
+(defvar *condition-setf-slot-value-using-class-method* nil)
+(defvar *condition-slot-boundp-using-class-method* nil)
 (defvar *structure-slot-value-using-class-method* nil)
 (defvar *structure-setf-slot-value-using-class-method* nil)
 (defvar *structure-slot-boundp-using-class-method* nil)
@@ -795,6 +826,18 @@
     (writer (setq *standard-setf-slot-value-using-class-method* method))
     (boundp (setq *standard-slot-boundp-using-class-method* method))))
 
+(defun condition-svuc-method (type)
+  (case type
+    (reader *condition-slot-value-using-class-method*)
+    (writer *condition-setf-slot-value-using-class-method*)
+    (boundp *condition-slot-boundp-using-class-method*)))
+
+(defun set-condition-svuc-method (type method)
+  (case type
+    (reader (setq *condition-slot-value-using-class-method* method))
+    (writer (setq *condition-setf-slot-value-using-class-method* method))
+    (boundp (setq *condition-slot-boundp-using-class-method* method))))
+
 (defun structure-svuc-method (type)
   (case type
     (reader *structure-slot-value-using-class-method*)
@@ -813,17 +856,18 @@
       (when (and (or (not (eq type 'writer))
 		     (eq (pop specls) *the-class-t*))
 		 (every #'classp specls))
-	(cond ((and (eq (class-name (car specls))
-			'std-class)
-		    (eq (class-name (cadr specls))
-			'std-object)
+	(cond ((and (eq (class-name (car specls)) 'std-class)
+		    (eq (class-name (cadr specls)) 'std-object)
 		    (eq (class-name (caddr specls))
 			'standard-effective-slot-definition))
 	       (set-standard-svuc-method type method))
-	      ((and (eq (class-name (car specls))
-			'structure-class)
-		    (eq (class-name (cadr specls))
-			'structure-object)
+	      ((and (eq (class-name (car specls)) 'condition-class)
+		    (eq (class-name (cadr specls)) 'condition)
+		    (eq (class-name (caddr specls))
+			'condition-effective-slot-definition))
+	       (set-condition-svuc-method type method))
+	      ((and (eq (class-name (car specls)) 'structure-class)
+		    (eq (class-name (cadr specls)) 'structure-object)
 		    (eq (class-name (caddr specls))
 			'structure-effective-slot-definition))
 	       (set-structure-svuc-method type method)))))))
@@ -839,8 +883,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 +909,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)
@@ -888,7 +932,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))
@@ -901,7 +945,8 @@
   (cond ((eq class *the-class-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*)
@@ -925,21 +970,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 +994,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 +1055,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 +1086,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 +1152,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 ()))))
 
@@ -1140,15 +1185,19 @@
 
 (defmacro mlookup (key info default &optional eq-p type)
   (unless (or (eq eq-p t) (null eq-p))
-    (error "Invalid eq-p argument"))
+    (bug "Invalid eq-p argument: ~S" eq-p))
   (ecase type
     (:simple
-     `(if (,(if eq-p 'eq 'eql) ,key (car ,info))
+     `(if (locally
+	    (declare (optimize (inhibit-warnings 3)))
+	    (,(if eq-p 'eq 'eql) ,key (car ,info)))
 	  (cdr ,info)
 	  ,default))
     (:assoc
      `(dolist (e ,info ,default)
-	(when (,(if eq-p 'eq 'eql) (car e) ,key)
+	(when (locally
+		(declare (optimize (inhibit-warnings 3)))
+		(,(if eq-p 'eq 'eql) (car e) ,key))
 	  (return (cdr e)))))
     (:hash-table
      `(gethash ,key ,info ,default))))
@@ -1194,15 +1243,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 +1271,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 +1305,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
+			   '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 +1347,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
@@ -1316,12 +1365,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-fun). 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
@@ -1332,7 +1381,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,10 +1408,10 @@
 ;;; 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
+;;;		(set-funcallable-instance-function
 ;;;		  gf
 ;;;		  (compute-discriminating-function gf))
 ;;;		(funcall gf arg))
@@ -1372,11 +1421,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
+;;;		(set-funcallable-instance-function
 ;;;		  gf
-;;;		  #'(lambda (a) ..))
+;;;		  (lambda (a) ..))
 ;;;		(funcall gf arg))
 ;;;	       (t
 ;;;		<call-a-method-of-gf>))))
@@ -1449,9 +1498,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 +1509,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 ())