diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index 974843a719ed17f18fd2941d64eb8d471be152df..3b61e361f6f43598440d56b25136e286f8b863e9 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.59 2003/05/23 11:05:16 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.60 2003/05/25 14:33:50 gerd Exp $")
 
 (in-package :pcl)
 
@@ -181,11 +181,9 @@ work during bootstrapping.
 
 (defun check-generic-function-lambda-list (function-specifier lambda-list)
   (multiple-value-bind (required optional restp rest keyp keys
-				 allow-other-keys-p auxp aux morep
-				 more-context more-count)
+				 allow-other-keys-p auxp aux)
       (parse-generic-function-lambda-list lambda-list)
-    (declare (ignore restp rest keyp aux allow-other-keys-p more-context
-		     more-count))
+    (declare (ignore restp rest keyp aux allow-other-keys-p))
     (labels ((lambda-list-error (format-control &rest format-arguments)
 	       (simple-program-error
 		(format nil "~~@<Generic function ~a: ~?.~~@:>"
@@ -209,14 +207,9 @@ work during bootstrapping.
 		  "Optional and key parameters of generic functions ~
                    may not have default values or supplied-p ~
                    parameters: ~<~s~>" parameter))))
-      (when morep
-	(lambda-list-error
-	 "~s is not allowed in generic function lambda lists"
-	 '&more))
       (when auxp
 	(lambda-list-error
-	 "~s is not allowed in generic function lambda lists"
-	 '&aux))
+	 "~s is not allowed in generic function lambda lists" '&aux))
       (mapc #'check-required-parameter required)
       (mapc #'check-key-or-optional-parameter optional)
       (mapc #'check-key-or-optional-parameter keys))))
@@ -384,12 +377,10 @@ work during bootstrapping.
 
 (defvar *inline-access*)
 (defvar *method-source-info*)
-(defvar *make-method-lambda-gf-name* nil)
 
 (defun expand-defmethod (name proto-gf proto-method qualifiers
 			 lambda-list body env)
-  (let ((*inline-access* ())
-	(*make-method-lambda-gf-name* name))
+  (let ((*inline-access* ()))
     (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
 	(add-method-declarations name qualifiers lambda-list body env)
       (let* ((auto-compile-p (auto-compile-p name qualifiers specializers))
@@ -653,6 +644,7 @@ work during bootstrapping.
 		  (multiple-value-bind (slot-name-lists call-list)
 		      (slot-name-lists-from-slots slots calls)
 		    (let ((pv-table-symbol (make-symbol "pv-table")))
+		      ;;
 		      ;; PV-TABLE-SYMBOL's symbol-value is later set
 		      ;; to an actual PV table for the method
 		      ;; function; see INITIALIZE-METHOD-FUNCTION.
@@ -668,23 +660,11 @@ work during bootstrapping.
 					   ,pv-table-symbol)
 			       ,@walked-lambda-body))))))
 		;;
-		;; When the GF contains &KEY, and the method has no
-		;; &KEY, add &KEY to the method function's
-		;; lambda-list, so that it checks for invalid keyword
-		;; arguments lists.  This is hack that works only for
-		;; methods defined with DEFMETHOD.  Don't know how to
-		;; do any better, though.  MAKE-METHOD-LAMBDA really
-		;; wants a NAME argument telling it the name of the
-		;; generic function for which the method lambda is
-		;; made, or maybe the lambda-list of the generic
-		;; function, or something.
-		(when (and (gf-key-p *make-method-lambda-gf-name*)
-			   (not (memq '&key lambda-list)))
-		  (setq lambda-list (append lambda-list '(&key))))
-		;;
 		;; When the lambda-list contains &KEY but not
 		;; &ALLOW-OTHER-KEYS, insert an &ALLOW-OTHER-KEYS
-		;; into the lambda-list.
+		;; into the lambda-list.  This corresponds to
+		;; CLHS 7.6.4 which says that methods are effectively
+		;; called as if :ALLOW-OTHER-KEYS T were supplied.
 		(when (and (memq '&key lambda-list)
 			   (not (memq '&allow-other-keys lambda-list)))
 		  (let ((aux (memq '&aux lambda-list)))
@@ -821,23 +801,11 @@ work during bootstrapping.
 	       (if (eq value +slot-unbound+)
 		   (slot-unbound-internal ,(car required-args+rest-arg) ,emf)
 		   value)))))
-       ;;
        ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
-	  `((fixnum
-	     (let ((.new-value. ,(car required-args+rest-arg))
-		   (.slots. (get-slots-or-nil ,(cadr required-args+rest-arg))))
-	       (when .slots. ; just to avoid compiler wranings
-		 (setf (%slot-ref .slots. ,emf) .new-value.))))))
-       #|| 
-       ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
-          `(((typep ,emf 'fast-instance-boundp)
-              (let ((.slots. (get-slots-or-nil
-				  ,(car required-args+rest-arg))))
-		    (and .slots.
-			 (not (eq (%slot-ref
-				   .slots. (fast-instance-boundp-index ,emf))
-				  +slot-unbound+)))))))
-       ||#
+	   (destructuring-bind (new-value object) required-args+rest-arg
+	     `((fixnum
+		(setf (%slot-ref (get-slots-or-nil ,object) ,emf)
+		      ,new-value)))))
        (method-call
 	(invoke-method-call ,emf ,restp ,@required-args+rest-arg))
        (function
@@ -954,104 +922,65 @@ work during bootstrapping.
 			 (next-method-p-body)))))
 	      ,@body))))
 
-(defmacro bind-args ((lambda-list args) &body body)
-  (let ((args-tail '.args-tail.)
-	(key '.key.)
-	(state 'required)
-	(key-seen nil)
-	(nkeys 0))
-    (flet ((process-var (var)
-	     (if (memq var lambda-list-keywords)
-		 (progn
-		   (ecase var
-		     (&optional         (setq state 'optional))
-		     (&key              (setq state 'key key-seen t))
-		     (&allow-other-keys)
-		     (&rest             (setq state 'rest))
-		     (&aux              (setq state 'aux)))
-		   nil)
-		 (case state
-		   (required
-		    `((,var (pop ,args-tail))))
-		   (optional
-		    (cond ((not (consp var))
-			   `((,var (when ,args-tail (pop ,args-tail)))))
-			  ((null (cddr var))
-			   `((,(car var) (if ,args-tail
-					     (pop ,args-tail)
-					     ,(cadr var)))))
-			  (t
-			   `((,(caddr var) ,args-tail)
-			     (,(car var) (if ,args-tail
-					     (pop ,args-tail)
-					     ,(cadr var)))))))
-		   (rest
-		    `((,var ,args-tail)))
-		   (key
-		    (incf nkeys)
-		    (cond ((not (consp var))
-			   `((,var (get-key-arg ,(make-keyword var)
-						,args-tail ',(= 1 nkeys)))))
-			  ((null (cddr var))
-			   (multiple-value-bind (keyword variable)
-			       (if (consp (car var))
-				   (values (caar var) (cadar var))
-				   (values (make-keyword (car var)) (car var)))
-			     `((,key (get-key-arg1 ',keyword ,args-tail
-						   ',(= 1 nkeys)))
-			       (,variable (if (consp ,key)
-					      (car ,key)
-					      ,(cadr var))))))
-			  (t
-			   (multiple-value-bind (keyword variable)
-			       (if (consp (car var))
-				   (values (caar var) (cadar var))
-				   (values (make-keyword (car var)) (car var)))
-			     `((,key (get-key-arg1 ',keyword ,args-tail
-						   ',(= 1 nkeys)))
-			       (,(caddr var) ,key)
-			       (,variable (if (consp ,key)
-					      (car ,key)
-					      ,(cadr var))))))))
-		   (aux
-		    `(,var))))))
-      (let ((bindings (mapcan #'process-var lambda-list)))
-	`(let* ((,args-tail ,args)
-		,@bindings
-		(.dummy1. ,@(when (eq state 'optional)
-			      `((unless (null ,args-tail)
-				  (too-many-args)))))
-		(.dummy. ,@(when (and key-seen (zerop nkeys))
-			     `((get-key-arg1 :allow-other-keys
-					     ,args-tail t)))))
-	   (declare (ignorable ,args-tail .dummy. .dummy1.))
-	   ,@body)))))
-
 (defun too-many-args ()
   (simple-program-error "Too many arguments."))
 
-(defun odd-number-of-keyword-arguments ()
-  (simple-program-error "Odd number of keyword arguments."))
-
-(defun invalid-keyword-argument (key)
-  (simple-program-error "Invalid keyword argument ~s" key))
-
-(defun get-key-arg (keyword list first-time)
-  (car (get-key-arg1 keyword list first-time)))
-
-(defun get-key-arg1 (keyword list first-time)
-  (if first-time
-      (loop with cell = nil
-	    for (key . more) on list by #'cddr do
-	      (cond ((not (symbolp key))
-		     (invalid-keyword-argument key))
-		    ((null more)
-		     (odd-number-of-keyword-arguments))
-		    ((and (null cell) (eq key keyword))
-		     (setq cell more)))
-	    finally (return cell))
-      (loop for (key . more) on list by #'cddr
-	    when (eq key keyword) return more)))
+(declaim (inline get-key-arg))
+(defun get-key-arg (keyword list)
+  (car (get-key-arg1 keyword list)))
+
+(defun get-key-arg1 (keyword list)
+  (loop for (key . more) on list by #'cddr
+	when (eq key keyword) return more))
+
+(defmacro bind-args ((lambda-list args) &body body)
+  (let ((state 'required))
+    (collect ((bindings) (ignorable (list '.args.)))
+      (dolist (var lambda-list)
+	(if (memq var lambda-list-keywords)
+	    (ecase var
+	      ((&optional &key &rest &aux)
+	       (setq state var))
+	      (&allow-other-keys))
+	    (case state
+	      (required
+	       (bindings `(,var (pop .args.))))
+	      (&optional
+	       (etypecase var
+		 (symbol
+		  (bindings `(,var (when .args. (pop .args.)))))
+		 (cons
+		  (destructuring-bind (var &optional default
+					   (supplied nil supplied-p))
+		      var
+		    (when supplied-p (bindings `(,supplied .args.)))
+		    (bindings `(,var (if .args. (pop .args.) ,default)))))))
+	      (&rest
+	       (bindings `(,var .args.)))
+	      (&key
+	       (etypecase var
+		 (symbol
+		  (bindings `(,var (get-key-arg ,(make-keyword var) .args.))))
+		 (cons
+		  (destructuring-bind (var &optional default
+					   (supplied nil supplied-p))
+		      var
+		    (multiple-value-bind (key var)
+			(if (consp var)
+			    (destructuring-bind (key var) var
+			      (values key var))
+			    (values (make-keyword var) var))
+		      (bindings `(.key. (get-key-arg1 ',key .args.)))
+		      (when supplied-p (bindings `(,supplied .key.)))
+		      (bindings `(,var (if .key. (car .key.) ,default))))))))
+	      (&aux
+	       (bindings var)))))
+      (when (eq state '&optional)
+	(bindings '(.dummy. (unless (null .args.) (too-many-args))))
+	(ignorable '.dummy.))
+      `(let* ((.args. ,args) ,@(bindings))
+	 (declare (ignorable ,@(ignorable)))
+	 ,@body))))
 
 (defun walk-method-lambda (method-lambda required-parameters env slots calls)
   (let ((call-next-method-p nil)   ;flag indicating that call-next-method
@@ -1471,6 +1400,30 @@ work during bootstrapping.
     (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
     arg-info))
 
+(declaim (inline generic-function-name*))
+(defun generic-function-name* (gf)
+  (if (early-gf-p gf)
+      (early-gf-name gf)
+      (generic-function-name gf)))
+
+(declaim (inline generic-function-methods*))
+(defun generic-function-methods* (gf)
+  (if (early-gf-p gf)
+      (early-gf-methods gf)
+      (generic-function-methods gf)))
+
+(declaim (inline gf-arg-info*))
+(defun gf-arg-info* (gf)
+  (if (early-gf-p gf)
+      (early-gf-arg-info gf)
+      (gf-arg-info gf)))
+
+(declaim (inline method-lambda-list*))
+(defun method-lambda-list* (method)
+  (if (consp method)
+      (early-method-lambda-list method)
+      (method-lambda-list method)))
+
 (defun compute-precedence (lambda-list nreq argument-precedence-order)
   (if (null argument-precedence-order)
       (let ((list nil))
@@ -1482,9 +1435,7 @@ work during bootstrapping.
 
 (defun check-method-arg-info (gf arg-info method)
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
-      (analyze-lambda-list (if (consp method)
-			       (early-method-lambda-list method)
-			       (method-lambda-list method)))
+      (analyze-lambda-list (method-lambda-list* method))
     (flet ((lose (format-control &rest format-args)
 	     (simple-program-error
 	      (format nil "~~@<Attempt to add the method ~~S to the generic ~
@@ -1716,6 +1667,13 @@ work during bootstrapping.
 (defun early-gf-name (gf)
   (slot-ref (get-slots gf) *sgf-name-index*))
 
+(defun gf-lambda-list-from-method (method)
+  (multiple-value-bind (parameters unspecialized-lambda-list)
+      (parse-specialized-lambda-list (method-lambda-list* method))
+    (declare (ignore parameters))
+    (let ((aux (memq '&aux unspecialized-lambda-list)))
+      (ldiff unspecialized-lambda-list aux))))
+
 (defun gf-lambda-list (gf)
   (let ((arg-info (if (eq *boot-state* 'complete)
 		      (gf-arg-info gf)
@@ -1725,17 +1683,8 @@ work during bootstrapping.
 			   (generic-function-methods gf)
 			   (early-gf-methods gf))))
 	  (if (null methods)
-	      (progn
-		(warn "~@<No way to determine the lambda list for ~S.~@:>" gf)
-		nil)
-	      (let* ((method (car (last methods)))
-		     (ll (if (consp method)
-			     (early-method-lambda-list method)
-			     (method-lambda-list method)))
-		     (k (member '&key ll)))
-		(if k 
-		    (append (ldiff ll (cdr k)) '(&allow-other-keys))
-		    ll))))
+	      (internal-error "~@<No way to determine the lambda list~@:>")
+	      (gf-lambda-list-from-method (car (last methods)))))
 	(arg-info-lambda-list arg-info))))
 
 (defmacro real-ensure-gf-internal (gf-class all-keys env)
@@ -1840,9 +1789,7 @@ work during bootstrapping.
 (defun get-generic-function-info (gf)
   ;; values   nreq applyp metatypes nkeys arg-info
   (multiple-value-bind (applyp metatypes arg-info)
-      (let* ((arg-info (if (early-gf-p gf)
-			   (early-gf-arg-info gf)
-			   (gf-arg-info gf)))
+      (let* ((arg-info (gf-arg-info* gf))
 	     (metatypes (arg-info-metatypes arg-info)))
 	(values (arg-info-applyp arg-info)
 		metatypes
@@ -2196,7 +2143,6 @@ work during bootstrapping.
   (multiple-value-bind (required optional restp rest keyp keys
 				 allow-other-keys-p aux)
       (parse-lambda-list lambda-list t)
-    (declare (ignore more-context more-count))
     (collect ((req) (spec))
       (dolist (x required)
 	(req (if (consp x) (car x) x))
diff --git a/pcl/braid.lisp b/pcl/braid.lisp
index 10d8f032d768343b435abfb78d2d2f30a6511cbc..c3c664d8d1cf42d1163a7130021ee937b2d56bb5 100644
--- a/pcl/braid.lisp
+++ b/pcl/braid.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.42 2003/05/19 19:16:26 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.43 2003/05/25 14:33:50 gerd Exp $")
 
 ;;;
 ;;; Bootstrapping the meta-braid.
@@ -514,19 +514,15 @@
 ;;; for the corresponding KERNEL::CLASS.
 ;;; 
 (defun ensure-non-standard-class (name &optional existing-class)
-  (flet ((ensure (metaclass &optional (slots nil slotsp))
+  (flet ((ensure (metaclass slots)
 	   (let* ((class (kernel::find-class name))
 		  (kernel-supers (kernel:%class-direct-superclasses class))
 		  (supers (mapcar #'kernel:%class-name kernel-supers)))
              (without-package-locks
-              (if slotsp
-                  (ensure-class-using-class
-                   existing-class name :metaclass metaclass :name name
-                   :direct-superclasses supers
-                   :direct-slots slots)
-                  (ensure-class-using-class
-                   existing-class name :metaclass metaclass :name name
-                   :direct-superclasses supers)))))
+	      (ensure-class-using-class
+	       existing-class name :metaclass metaclass :name name
+	       :direct-superclasses supers
+	       :direct-slots slots))))
 	 (slot-initargs-from-structure-slotd (slotd)
 	   (let ((accessor (structure-slotd-accessor-symbol slotd)))
 	     `(:name ,(structure-slotd-name slotd)
diff --git a/pcl/combin.lisp b/pcl/combin.lisp
index 37f8482c37d116a9714c5e54ec90e0a7673fccd5..01fd38b9f76ec48438e67958937bd05e6ec4c0d8 100644
--- a/pcl/combin.lisp
+++ b/pcl/combin.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.15 2003/05/04 13:11:22 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.16 2003/05/25 14:33:50 gerd Exp $")
 
 (in-package "PCL")
 
@@ -120,9 +120,21 @@
 	   `(%no-primary-method ',gf .args.))
 	  ((and (null before) (null after) (null around))
 	   ;;
-	   ;; By returning a single CALL-METHOD form here, we enable an
-	   ;; important implementation-specific optimization.
-	   `(call-method ,(first primary) ,(rest primary)))
+	   ;; By returning a single CALL-METHOD form here, we enable
+	   ;; an important implementation-specific optimization, which
+	   ;; uses fast-method functions directly for effective method
+	   ;; functions.  (Which is also the reason emfs have a
+	   ;; lambda-list like fast method functionts.)
+	   ;;
+	   ;; This cannot be done if the gf requires keyword argument
+	   ;; checking as in CLHS 7.6.5 because we can't tell in
+	   ;; method functions if they are used as emfs only.  If they
+	   ;; are not used as emfs only, they should accept any keyword
+	   ;; argumests, per CLHS 7.6.4, for instance.
+	   (let ((call-method `(call-method ,(first primary) ,(rest primary))))
+	     (if (emfs-must-check-applicable-keywords-p gf)
+		 `(progn ,call-method)
+		 call-method)))
 	  (t
 	   (let ((main-effective-method
 		   (if (or before after)
@@ -273,17 +285,15 @@
 
 ;;;
 ;;; Return a closure returning a FAST-METHOD-CALL instance for the
-;;; call of the effective method of generic function GF with body
+;;; call of an effective method of generic function GF with body
 ;;; BODY.
 ;;;
 (defun callable-generator-for-emf (gf body method-alist-p wrappers-p)
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
       (get-generic-function-info gf)
     (declare (ignore nkeys arg-info))
-    (let* ((name (if (early-gf-p gf)
-		     (early-gf-name gf)
-		     (generic-function-name gf)))
-	   (arg-info (cons nreq applyp))
+    (let* ((name (generic-function-name* gf))
+	   (fmc-info (cons nreq applyp))
 	   (effective-method-lambda (make-effective-method-lambda gf body)))
       (multiple-value-bind (cfunction constants)
 	  (get-function1 effective-method-lambda
@@ -296,21 +306,118 @@
 			 (lambda (form)
 			   (memf-constant-converter form gf)))
 	(lambda (method-alist wrappers)
-	  (let* ((constants 
-		  (mapcar (lambda (constant)
-			    (case (car-safe constant)
-			      (.meth.
-			       (funcall (cdr constant) method-alist wrappers))
-			      (.meth-list.
-			       (mapcar (lambda (fn)
-					 (funcall fn method-alist wrappers))
-				       (cdr constant)))
-			      (t constant)))
-			  constants))
-		 (function (set-function-name (apply cfunction constants)
-					      `(effective-method ,name))))
-	    (make-fast-method-call :function function
-				   :arg-info arg-info)))))))
+	  (declare (special *applicable-methods*))
+	  (multiple-value-bind (valid-keys keyargs-start)
+	      (when (memq '.valid-keys. constants)
+		(compute-applicable-keywords gf *applicable-methods*))
+	    (flet ((compute-constant (constant)
+		     (if (consp constant)
+			 (case (car constant)
+			   (.meth.
+			    (funcall (cdr constant) method-alist wrappers))
+			   (.meth-list.
+			    (mapcar (lambda (fn)
+				      (funcall fn method-alist wrappers))
+				    (cdr constant)))
+			   (t constant))
+			 (case constant
+			   (.keyargs-start. keyargs-start)
+			   (.valid-keys. valid-keys)
+			   (t constant)))))
+	      (let ((fn (apply cfunction
+			       (mapcar #'compute-constant constants))))
+		(set-function-name fn `(effective-method ,name))
+		(make-fast-method-call :function fn :arg-info fmc-info)))))))))
+
+;;;
+;;; Return true if emfs of generic function GF must do keyword
+;;; argument checking with CHECK-APPLICABLE-KEYWORDS.
+;;;
+;;; We currently do this if the generic function type has &KEY, which
+;;; should be the case if the gf or any method has &KEY.  It would be
+;;; possible to avoid the check if it also has &ALLOW-OTHER-KEYS, iff
+;;; method functions do checks of their own, which is ugly to do,
+;;; so we don't.
+;;;
+(defun emfs-must-check-applicable-keywords-p (gf)
+  (let ((type (info function type (generic-function-name* gf))))
+    (and (kernel::function-type-p type)
+	 (kernel::function-type-keyp type))))
+
+;;;
+;;; Compute which keyword args are valid in a call of generic function
+;;; GF with applicable methods METHODS.  See also CLHS 7.6.5.
+;;;
+;;; First value is either a list of valid keywords or T meaning all
+;;; keys are valid.  Second value is the number of optional arguments
+;;; that GF takes.  This number is used as an offset in the supplied
+;;; args .DFUN-REST-ARG. in CHECK-APPLICABLE-KEYWORDS.
+;;;
+(defun compute-applicable-keywords (gf methods)
+  (let ((any-keyp nil))
+    (flet ((analyze (lambda-list)
+	     (multiple-value-bind (nreq nopt keyp restp allowp keys)
+		 (analyze-lambda-list lambda-list)
+	       (declare (ignore nreq restp))
+	       (when keyp
+		 (setq any-keyp t))
+	       (values nopt allowp keys))))
+      (multiple-value-bind (nopt allowp keys)
+	  (analyze (generic-function-lambda-list gf))
+	(if allowp
+	    (setq keys t)
+	    (dolist (method methods)
+	      (multiple-value-bind (n allowp method-keys)
+		  (analyze (method-lambda-list* method))
+		(declare (ignore n))
+		(if allowp
+		    (return (setq keys t))
+		    (setq keys (union method-keys keys))))))
+	;;
+	;; It shouldn't happen thet neither the gf nor any method has
+	;; &KEY, when this method is called.  Let's handle the case
+	;; anyway, just for generality.
+	(values (if any-keyp keys t) nopt)))))
+
+;;;
+;;; Check ARGS for invalid keyword arguments, beginning at position
+;;; START in ARGS.  VALID-KEYS is a list of valid keywords.  VALID-KEYS
+;;; being T means all keys are valid.
+;;;
+(defun check-applicable-keywords (args start valid-keys)
+  (let ((allow-other-keys-seen nil)
+	(allow-other-keys nil)
+	(args (nthcdr start args)))
+    (collect ((invalid))
+      (loop
+	 (when (null args)
+	   (when (and (invalid) (not allow-other-keys))
+	     (simple-program-error
+	      "~@<Invalid keyword argument~p ~{~s~^, ~}.  ~
+               Valid keywords are: ~{~s~^, ~}.~@:>"
+	      (length (invalid))
+	      (invalid)
+	      valid-keys))
+	   (return))
+	 (let ((key (pop args)))
+	   (cond ((not (symbolp key))
+		  (invalid-keyword-argument key))
+		 ((null args)
+		  (odd-number-of-keyword-arguments))
+		 ((eq key :allow-other-keys)
+		  (unless allow-other-keys-seen
+		    (setq allow-other-keys-seen t
+			  allow-other-keys (car args))))
+		 ((eq t valid-keys))
+		 ((not (memq key valid-keys))
+		  (invalid key))))
+	 (pop args)))))
+
+(defun odd-number-of-keyword-arguments ()
+  (simple-program-error "Odd number of keyword arguments."))
+
+(defun invalid-keyword-argument (key)
+  (simple-program-error "Invalid keyword argument ~s" key))
 
 ;;;
 ;;; Return a lambda-form for an effective method of generic function
@@ -320,7 +427,17 @@
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
       (get-generic-function-info gf)
     (declare (ignore nreq nkeys arg-info))
+    ;;
+    ;; Note that emfs use the same lambda-lists as fast method
+    ;; functions, although they don't need all the arguments that a
+    ;; fast method function needs, because this makes it possible to
+    ;; use fast method functions directly as emfs.  This is achieved
+    ;; by returning a single CALL-METHOD form from the method
+    ;; combination.
     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
+	  (check-applicable-keywords
+	   (when (and applyp (emfs-must-check-applicable-keywords-p gf))
+	     '((check-applicable-keywords))))
 	  (error-p (eq (first body) '%no-primary-method))
 	  (mc-args-p
 	   (when (eq *boot-state* 'complete)
@@ -341,10 +458,12 @@
 		  (declare (ignore .pv-cell. .next-method-call.))
 		  (let ((.gf-args. ,gf-args))
 		    (declare (ignorable .gf-args.))
+		    ,@check-applicable-keywords
 		    ,body))))
 	    (t
 	     `(lambda ,ll
 		(declare (ignore .pv-cell. .next-method-call.))
+		,@check-applicable-keywords
 		,body))))))
 
 (defun memf-test-converter (form gf method-alist-p wrappers-p)
@@ -357,6 +476,8 @@
      (case (get-method-list-call-type gf form method-alist-p wrappers-p)
        (fast-method-call '.fast-call-method-list.)
        (t '.call-method-list.)))
+    (check-applicable-keywords
+     'check-applicable-keywords)
     (t
      (default-test-converter form))))
 
@@ -376,6 +497,10 @@
        (values `(dolist (emf ,gensym nil)
 		  ,(make-emf-call metatypes applyp 'emf type))
 	       (list gensym))))
+    (check-applicable-keywords
+     (values `(check-applicable-keywords .dfun-rest-arg.
+					 .keyargs-start. .valid-keys.)
+	      '(.keyargs-start. .valid-keys.)))
     (t
      (default-code-converter form))))
 
@@ -389,6 +514,8 @@
 		 (mapcar (lambda (form)
 			   (callable-generator-for-call-method gf form))
 			 (cdr form)))))
+    (check-applicable-keywords
+     '(.keyargs-start. .valid-keys.))
     (t
      (default-constant-converter form))))
 
@@ -444,8 +571,11 @@
 ;;; CALLABLE-GENERATOR.  Call it with two args METHOD-ALIST and
 ;;; WRAPPERS to obtain the actual callable.
 ;;;
+(defvar *applicable-methods*)
+
 (defun make-callable (gf methods generator method-alist wrappers)
-  (let ((callable (function-funcall generator method-alist wrappers)))
+  (let* ((*applicable-methods* methods)
+	 (callable (function-funcall generator method-alist wrappers)))
     (set-emf-name gf methods callable)))
 
 ;;;
@@ -484,9 +614,7 @@
 
 (defun make-emf-name (gf methods)
   (let* ((early-p (early-gf-p gf))
-	 (gf-name (if early-p
-		     (early-gf-name gf)
-		     (generic-function-name gf)))
+	 (gf-name (generic-function-name* gf))
 	 (emf-name
 	  (if (or early-p
 		  (eq (generic-function-method-combination gf)
diff --git a/pcl/ctor.lisp b/pcl/ctor.lisp
index 1e16202a2c46d5e14ddf7b0637bd79e905897ea8..d4233b10a4f33bafae74d2a886cec15ab64b5d9b 100644
--- a/pcl/ctor.lisp
+++ b/pcl/ctor.lisp
@@ -46,7 +46,7 @@
 ;;; is called.
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.12 2003/05/13 10:49:01 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.13 2003/05/25 14:33:50 gerd Exp $")
 
 (in-package "PCL")
 
@@ -258,7 +258,7 @@
 	      (unless (class-finalized-p class)
 		(finalize-inheritance class))
 	      (pushnew ctor (plist-value class 'ctors))
-	      (install (null *cold-boot-state*))))))))
+	      (install (null *cold-boot-state*)))))))
 
 (defun constructor-function-form (ctor)
   (let* ((class (ctor-class ctor))
diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp
index c80aefaf63dc49a63e820cd0fec06a1f057e4875..8ff1b89214f1d8a839a08a89efd1b1d5baae3daa 100644
--- a/pcl/dfun.lisp
+++ b/pcl/dfun.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.27 2003/05/11 11:30:34 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.28 2003/05/25 14:33:49 gerd Exp $")
 
 (in-package :pcl)
 
@@ -493,15 +493,13 @@ And so, we are saved.
 		      classes-list new-class)))
 	  (make-checking-dfun generic-function function cache)))))
 
-(defun use-caching-dfun-p (generic-function)
+(defun use-caching-dfun-p (gf)
   (some (lambda (method)
 	  (let ((fmf (if (listp method)
 			 (third method)
 			 (method-fast-function method))))
 	    (method-function-get fmf :slot-name-lists)))
-	(if (early-gf-p generic-function)
-	    (early-gf-methods generic-function)
-	    (generic-function-methods generic-function))))
+	(generic-function-methods* gf)))
 
 
 ;;;
@@ -546,9 +544,7 @@ And so, we are saved.
       (get-generic-function-info gf)
     (declare (ignore nreq metatypes nkeys))
     (let* ((early-p (early-gf-p gf))
-	   (methods (if early-p
-			(early-gf-methods gf)
-			(generic-function-methods gf)))
+	   (methods (generic-function-methods* gf))
 	   (default '(unknown)))
       (and (null applyp)
 	   (or (not (eq *boot-state* 'complete))
@@ -590,7 +586,7 @@ And so, we are saved.
 
 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
   (when (eq *boot-state* 'complete)
-    (unless caching-p
+    (unless (or caching-p (emfs-must-check-applicable-keywords-p gf))
       ;; This should return T when almost all dispatching is by
       ;; eql specializers or built-in classes.  In other words,
       ;; return NIL if we might ever need to do more than
@@ -796,9 +792,7 @@ And so, we are saved.
 		       (t
 			(values initial-dfun nil (make-initial-dfun-info))))))
 	      (t
-	       (let ((arg-info (if (early-gf-p gf)
-				   (early-gf-arg-info gf)
-				   (gf-arg-info gf)))
+	       (let ((arg-info (gf-arg-info* gf))
 		     (type nil))
 		 (if (and (gf-precompute-dfun-and-emf-p arg-info)
 			  (setq type (final-accessor-dfun-type gf)))
@@ -844,18 +838,16 @@ And so, we are saved.
       (make-final-dfun-internal gf classes-list)
     (set-dfun gf dfun cache info)))
 
-(defun update-dfun (generic-function &optional dfun cache info)
-  (let* ((early-p (early-gf-p generic-function))
-	 (gf-name (if early-p
-		      (early-gf-name generic-function)
-		      (generic-function-name generic-function))))
-    (set-dfun generic-function dfun cache info)
+(defun update-dfun (gf &optional dfun cache info)
+  (let* ((early-p (early-gf-p gf))
+	 (gf-name (generic-function-name* gf)))
+    (set-dfun gf dfun cache info)
     (let ((dfun (if early-p
-		    (or dfun (make-initial-dfun generic-function))
-		    (compute-discriminating-function generic-function))))
-      (set-funcallable-instance-function generic-function dfun)
-      (set-function-name generic-function gf-name)
-      (update-pv-calls-for-gf generic-function)
+		    (or dfun (make-initial-dfun gf))
+		    (compute-discriminating-function gf))))
+      (set-funcallable-instance-function gf dfun)
+      (set-function-name gf gf-name)
+      (update-pv-calls-for-gf gf)
       dfun)))
 
 (defun gfs-of-type (type)
@@ -884,9 +876,7 @@ And so, we are saved.
   `(with-hash-table (,table eq) ,@forms))
 
 (defun final-accessor-dfun-type (gf)
-  (let ((methods (if (early-gf-p gf)
-		     (early-gf-methods gf)
-		     (generic-function-methods gf))))
+  (let ((methods (generic-function-methods* gf)))
     (cond ((every (lambda (method) 
 		    (if (consp method)
 			(eq *the-class-standard-reader-method*
@@ -1315,9 +1305,7 @@ And so, we are saved.
 ;;;
 (defun make-accessor-table (gf type table)
   (let ((table (or table (make-hash-table :test 'eq)))
-	(methods (if (early-gf-p gf)
-		     (early-gf-methods gf)
-		     (generic-function-methods gf)))
+	(methods (generic-function-methods* gf))
 	(all-index nil)
 	(no-class-slots-p t)
 	(early-p (not (eq *boot-state* 'complete)))
@@ -1392,9 +1380,7 @@ And so, we are saved.
 (defun compute-applicable-methods-using-types (gf types)
   (let ((definite-p t)
 	(possibly-applicable-methods ()))
-    (dolist (method (if (early-gf-p gf)
-			(early-gf-methods gf)
-			(generic-function-methods gf)))
+    (dolist (method (generic-function-methods* gf))
       (let ((specls (if (consp method)
 			(early-method-specializers method t)
 			(method-specializers method)))
@@ -1413,9 +1399,7 @@ And so, we are saved.
 	  (unless applicable-p
 	    (setq definite-p nil))
 	  (push method possibly-applicable-methods))))
-    (let ((precedence (arg-info-precedence (if (early-gf-p gf)
-					       (early-gf-arg-info gf)
-					       (gf-arg-info gf)))))
+    (let ((precedence (arg-info-precedence (gf-arg-info* gf))))
       (values (sort-applicable-methods (nreverse possibly-applicable-methods)
 				       types precedence)
 	      definite-p))))
diff --git a/pcl/init.lisp b/pcl/init.lisp
index 7214d0b5ee89cbf09f61c98c04c68c4bb5cf614f..daaa23097482d3f57a8936822b368881bd602c5c 100644
--- a/pcl/init.lisp
+++ b/pcl/init.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.23 2003/05/09 15:19:19 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.24 2003/05/25 14:33:49 gerd Rel $")
 
 ;;;
 ;;; This file defines the initialization and related protocols.
@@ -210,9 +210,7 @@
     ;; just quit.
     (dolist (method methods)
       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
-	  (analyze-lambda-list (if (consp method)
-				   (early-method-lambda-list method)
-				   (method-lambda-list method)))
+	  (analyze-lambda-list (method-lambda-list* method))
 	(declare (ignore nreq nopt keysp restp))
 	(when allow-other-keys
 	  (return-from valid-initargs (values nil t)))
diff --git a/pcl/low.lisp b/pcl/low.lisp
index 1878640311487032ae8b4b618115f644870fc08d..989d7dffe6886c7bac8d19eb3213aad46a1fdba9 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.30 2003/05/19 19:16:26 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.31 2003/05/25 14:33:49 gerd Exp $")
 
 ;;; 
 ;;; This file contains optimized low-level constructs for PCL.
@@ -364,6 +364,7 @@ the compiler as completely as possible.  Currently this means that
 		 (if (consp var)
 		     (destructuring-bind (var &optional value supplied-p)
 			 var
+		       (declare (ignore value))
 		       (if (consp var)
 			   (check-var (cadr var))
 			   (check-var var))
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
index 1c2169fe297d9a16526dd6e6c06198ab46e2ce75..0c38fd2e00670636f36ff4f3574aba4416d5d520 100644
--- a/pcl/methods.lisp
+++ b/pcl/methods.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.32 2003/05/20 18:39:36 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.33 2003/05/25 14:33:49 gerd Exp $")
 
 (in-package :pcl)
 
@@ -894,7 +894,7 @@
   (case type
     (reader (setq *condition-slot-value-using-class-method* method))
     (writer (setq *condition-setf-slot-value-using-class-method* method))
-    (boundp (setq *condition-boundp-using-class-method* method))))
+    (boundp (setq *condition-slot-boundp-using-class-method* method))))
 
 (defun update-std-or-str-methods (gf type)
   (dolist (method (generic-function-methods gf))
@@ -1529,9 +1529,7 @@
 ;;;
 (defmethod function-keywords ((method standard-method))
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
-      (analyze-lambda-list (if (consp method)
-			       (early-method-lambda-list method)
-			       (method-lambda-list method)))
+      (analyze-lambda-list (method-lambda-list* method))
     (declare (ignore nreq nopt keysp restp))
     (values keywords allow-other-keys-p)))
 
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index fb012a6705c8b15b8b85dca9f573db381d27a486..4befefe882637ee8ea133ffcd0bf79c06717e7c4 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.66 2003/05/20 18:39:36 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.67 2003/05/25 14:33:49 gerd Exp $")
 
 (in-package :pcl)
 
@@ -1131,9 +1131,12 @@
 (defmethod compute-effective-slot-definition-initargs :around
     ((class structure-class) direct-slotds)
   (let ((slotd (car direct-slotds)))
-    (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
-	   :internal-reader-function (slot-definition-internal-reader-function slotd)
-	   :internal-writer-function (slot-definition-internal-writer-function slotd)
+    (list* :defstruct-accessor-symbol
+	   (slot-definition-defstruct-accessor-symbol slotd)
+	   :internal-reader-function
+	   (slot-definition-internal-reader-function slotd)
+	   :internal-writer-function
+	   (slot-definition-internal-writer-function slotd)
 	   (call-next-method))))
 
 ;;;