X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=8128f53478e3b64bd0a6125c465300b0b694542a;hb=54da325f13fb41669869aea688ae195426c0e231;hp=cf28f2e281dede494722d89db52a0eb562b7e7f6;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index cf28f2e..8128f53 100644
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -26,74 +26,75 @@
 (defun get-method-function (method &optional method-alist wrappers)
   (let ((fn (cadr (assoc method method-alist))))
     (if fn
-	(values fn nil nil nil)
-	(multiple-value-bind (mf fmf)
-	    (if (listp method)
-		(early-method-function method)
-		(values nil (method-fast-function method)))
-	  (let* ((pv-table (and fmf (method-function-pv-table fmf))))
-	    (if (and fmf (or (null pv-table) wrappers))
-		(let* ((pv-wrappers (when pv-table
-				      (pv-wrappers-from-all-wrappers
-				       pv-table wrappers)))
-		       (pv-cell (when (and pv-table pv-wrappers)
-				  (pv-table-lookup pv-table pv-wrappers))))
-		  (values mf t fmf pv-cell))
-		(values
-		 (or mf (if (listp method)
-			    (setf (cadr method)
-				  (method-function-from-fast-function fmf))
-			    (method-function method)))
-		 t nil nil)))))))
+        (values fn nil nil nil)
+        (multiple-value-bind (mf fmf)
+            (if (listp method)
+                (early-method-function method)
+                (values nil (safe-method-fast-function method)))
+          (let* ((pv-table (and fmf (method-plist-value method :pv-table))))
+            (if (and fmf (or (null pv-table) wrappers))
+                (let* ((pv-wrappers (when pv-table
+                                      (pv-wrappers-from-all-wrappers
+                                       pv-table wrappers)))
+                       (pv (when (and pv-table pv-wrappers)
+                             (pv-table-lookup pv-table pv-wrappers))))
+                  (values mf t fmf pv))
+                (values
+                 (or mf (if (listp method)
+                            (bug "early method with no method-function")
+                            (method-function method)))
+                 t nil nil)))))))
 
 (defun make-effective-method-function (generic-function form &optional
-				       method-alist wrappers)
+                                       method-alist wrappers)
   (funcall (make-effective-method-function1 generic-function form
-					    (not (null method-alist))
-					    (not (null wrappers)))
-	   method-alist wrappers))
+                                            (not (null method-alist))
+                                            (not (null wrappers)))
+           method-alist wrappers))
 
 (defun make-effective-method-function1 (generic-function form
-					method-alist-p wrappers-p)
+                                        method-alist-p wrappers-p)
   (if (and (listp form)
-	   (eq (car form) 'call-method))
+           (eq (car form) 'call-method))
       (make-effective-method-function-simple generic-function form)
       ;; We have some sort of `real' effective method. Go off and get a
       ;; compiled function for it. Most of the real hair here is done by
-      ;; the GET-FUNCTION mechanism.
+      ;; the GET-FUN mechanism.
       (make-effective-method-function-internal generic-function form
-					       method-alist-p wrappers-p)))
+                                               method-alist-p wrappers-p)))
 
-(defun make-effective-method-function-type (generic-function form
-					    method-alist-p wrappers-p)
+(defun make-effective-method-fun-type (generic-function
+                                       form
+                                       method-alist-p
+                                       wrappers-p)
   (if (and (listp form)
-	   (eq (car form) 'call-method))
+           (eq (car form) 'call-method))
       (let* ((cm-args (cdr form))
-	     (method (car cm-args)))
-	(when method
-	  (if (if (listp method)
-		  (eq (car method) ':early-method)
-		  (method-p method))
-	      (if method-alist-p
-		  't
-		  (multiple-value-bind (mf fmf)
-		      (if (listp method)
-			  (early-method-function method)
-			  (values nil (method-fast-function method)))
-		    (declare (ignore mf))
-		    (let* ((pv-table (and fmf (method-function-pv-table fmf))))
-		      (if (and fmf (or (null pv-table) wrappers-p))
-			  'fast-method-call
-			  'method-call))))
-	      (if (and (consp method) (eq (car method) 'make-method))
-		  (make-effective-method-function-type
-		   generic-function (cadr method) method-alist-p wrappers-p)
-		  (type-of method)))))
+             (method (car cm-args)))
+        (when method
+          (if (if (listp method)
+                  (eq (car method) :early-method)
+                  (method-p method))
+              (if method-alist-p
+                  t
+                  (multiple-value-bind (mf fmf)
+                      (if (listp method)
+                          (early-method-function method)
+                          (values nil (safe-method-fast-function method)))
+                    (declare (ignore mf))
+                    (let* ((pv-table (and fmf (method-plist-value method :pv-table))))
+                      (if (and fmf (or (null pv-table) wrappers-p))
+                          'fast-method-call
+                          'method-call))))
+              (if (and (consp method) (eq (car method) 'make-method))
+                  (make-effective-method-fun-type
+                   generic-function (cadr method) method-alist-p wrappers-p)
+                  (type-of method)))))
       'fast-method-call))
 
 (defun make-effective-method-function-simple
     (generic-function form &optional no-fmf-p)
-  ;; The effective method is just a call to call-method. This opens up
+  ;; The effective method is just a call to CALL-METHOD. This opens up
   ;; the possibility of just using the method function of the method as
   ;; the effective method function.
   ;;
@@ -103,78 +104,164 @@
   ;; asks about them. If it does, we must tell it whether there are
   ;; or aren't to prevent the leaky next methods bug.
   (let* ((cm-args (cdr form))
-	 (fmf-p (and (null no-fmf-p)
-		     (or (not (eq *boot-state* 'complete))
-			 (gf-fast-method-function-p generic-function))
-		     (null (cddr cm-args))))
-	 (method (car cm-args))
-	 (cm-args1 (cdr cm-args)))
-    #'(lambda (method-alist wrappers)
-	(make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
-						method-alist wrappers))))
+         (fmf-p (and (null no-fmf-p)
+                     (or (not (eq **boot-state** 'complete))
+                         (gf-fast-method-function-p generic-function))
+                     (null (cddr cm-args))))
+         (method (car cm-args))
+         (cm-args1 (cdr cm-args)))
+    (lambda (method-alist wrappers)
+      (make-effective-method-function-simple1 generic-function
+                                              method
+                                              cm-args1
+                                              fmf-p
+                                              method-alist
+                                              wrappers))))
 
 (defun make-emf-from-method
     (method cm-args &optional gf fmf-p method-alist wrappers)
-  (multiple-value-bind (mf real-mf-p fmf pv-cell)
+  (multiple-value-bind (mf real-mf-p fmf pv)
       (get-method-function method method-alist wrappers)
     (if fmf
-	(let* ((next-methods (car cm-args))
-	       (next (make-effective-method-function-simple1
-		      gf (car next-methods)
-		      (list* (cdr next-methods) (cdr cm-args))
-		      fmf-p method-alist wrappers))
-	       (arg-info (method-function-get fmf ':arg-info)))
-	  (make-fast-method-call :function fmf
-				 :pv-cell pv-cell
-				 :next-method-call next
-				 :arg-info arg-info))
-	(if real-mf-p
-	    (make-method-call :function mf
-			      :call-method-args cm-args)
-	    mf))))
+        (let* ((next-methods (car cm-args))
+               (next (make-effective-method-function-simple1
+                      gf (car next-methods)
+                      (list* (cdr next-methods) (cdr cm-args))
+                      fmf-p method-alist wrappers))
+               (arg-info (method-plist-value method :arg-info))
+               (default (cons nil nil))
+               (value (method-plist-value method :constant-value default)))
+          (if (eq value default)
+              (make-fast-method-call :function fmf :pv pv
+                                     :next-method-call next :arg-info arg-info)
+              (make-constant-fast-method-call
+               :function fmf :pv pv :next-method-call next
+               :arg-info arg-info :value value)))
+        (if real-mf-p
+            (flet ((frob-cm-arg (arg)
+                     (if (if (listp arg)
+                             (eq (car arg) :early-method)
+                             (method-p arg))
+                         arg
+                         (if (and (consp arg) (eq (car arg) 'make-method))
+                             (let ((emf (make-effective-method-function
+                                         gf (cadr arg) method-alist wrappers)))
+                               (etypecase emf
+                                 (method-call
+                                  (make-instance 'standard-method
+                                                 :specializers nil ; XXX
+                                                 :qualifiers nil ; XXX
+                                                 :function (method-call-function emf)))
+                                 (fast-method-call
+                                  (let* ((fmf (fast-method-call-function emf))
+                                         (fun (method-function-from-fast-method-call emf))
+                                         (mf (%make-method-function fmf nil)))
+                                    (set-funcallable-instance-function mf fun)
+                                    (make-instance 'standard-method
+                                                   :specializers nil ; XXX
+                                                   :qualifiers nil
+                                                   :function mf)))))
+                             arg))))
+              (let* ((default (cons nil nil))
+                     (value
+                      (method-plist-value method :constant-value default))
+                     ;; FIXME: this is wrong.  Very wrong.  It assumes
+                     ;; that the only place that can have make-method
+                     ;; calls is in the list structure of the second
+                     ;; argument to CALL-METHOD, but AMOP says that
+                     ;; CALL-METHOD can be more complicated if
+                     ;; COMPUTE-EFFECTIVE-METHOD (and presumably
+                     ;; MAKE-METHOD-LAMBDA) is adjusted to match.
+                     ;;
+                     ;; On the other hand, it's a start, because
+                     ;; without this calls to MAKE-METHOD in method
+                     ;; combination where one of the methods is of a
+                     ;; user-defined class don't work at all.  -- CSR,
+                     ;; 2006-08-05
+                     (args (cons (mapcar #'frob-cm-arg (car cm-args))
+                                 (cdr cm-args))))
+                (if (eq value default)
+                    (make-method-call :function mf :call-method-args args)
+                    (make-constant-method-call :function mf :value value
+                                               :call-method-args args))))
+            mf))))
 
 (defun make-effective-method-function-simple1
     (gf method cm-args fmf-p &optional method-alist wrappers)
   (when method
     (if (if (listp method)
-	    (eq (car method) ':early-method)
-	    (method-p method))
-	(make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
-	(if (and (consp method) (eq (car method) 'make-method))
-	    (make-effective-method-function gf
-					    (cadr method)
-					    method-alist wrappers)
-	    method))))
+            (eq (car method) :early-method)
+            (method-p method))
+        (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
+        (if (and (consp method) (eq (car method) 'make-method))
+            (make-effective-method-function gf
+                                            (cadr method)
+                                            method-alist wrappers)
+            method))))
 
 (defvar *global-effective-method-gensyms* ())
 (defvar *rebound-effective-method-gensyms*)
 
 (defun get-effective-method-gensym ()
   (or (pop *rebound-effective-method-gensyms*)
-      (let ((new (intern (format nil
-				 "EFFECTIVE-METHOD-GENSYM-~D"
-				 (length *global-effective-method-gensyms*))
-			 *pcl-package*)))
-	(setq *global-effective-method-gensyms*
-	      (append *global-effective-method-gensyms* (list new)))
-	new)))
+      (let ((new (format-symbol *pcl-package*
+                                "EFFECTIVE-METHOD-GENSYM-~D"
+                                (length *global-effective-method-gensyms*))))
+        (setq *global-effective-method-gensyms*
+              (append *global-effective-method-gensyms* (list new)))
+        new)))
 
 (let ((*rebound-effective-method-gensyms* ()))
   (dotimes-fixnum (i 10) (get-effective-method-gensym)))
 
 (defun expand-effective-method-function (gf effective-method &optional env)
   (declare (ignore env))
-  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-      (get-generic-function-info gf)
-    (declare (ignore nreq nkeys arg-info))
-    (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
-	  ;; When there are no primary methods and a next-method call occurs
-	  ;; effective-method is (error "No mumble..") and the defined
-	  ;; args are not used giving a compiler warning.
-	  (error-p (eq (first effective-method) 'error)))
-      `(lambda ,ll
-	 (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
-	 ,effective-method))))
+  (multiple-value-bind (nreq applyp)
+      (get-generic-fun-info gf)
+    (let ((ll (make-fast-method-call-lambda-list nreq applyp))
+          (check-applicable-keywords
+           (when (and applyp (gf-requires-emf-keyword-checks gf))
+             '((check-applicable-keywords))))
+          (error-p (or (eq (first effective-method) '%no-primary-method)
+                       (eq (first effective-method) '%invalid-qualifiers)))
+          (mc-args-p
+           (when (eq **boot-state** 'complete)
+             ;; Otherwise the METHOD-COMBINATION slot is not bound.
+             (let ((combin (generic-function-method-combination gf)))
+               (and (long-method-combination-p combin)
+                    (long-method-combination-args-lambda-list combin)))))
+          (name `(emf ,(generic-function-name gf))))
+      (cond
+        (error-p
+         `(named-lambda ,name (.pv. .next-method-call. &rest .args.)
+            (declare (ignore .pv. .next-method-call.))
+            (declare (ignorable .args.))
+            (flet ((%no-primary-method (gf args)
+                     (call-no-primary-method gf args))
+                   (%invalid-qualifiers (gf combin method)
+                     (invalid-qualifiers gf combin method)))
+              (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
+              ,effective-method)))
+        (mc-args-p
+         (let* ((required (make-dfun-required-args nreq))
+                (gf-args (if applyp
+                             `(list* ,@required
+                                     (sb-c::%listify-rest-args
+                                      .dfun-more-context.
+                                      (the (and unsigned-byte fixnum)
+                                        .dfun-more-count.)))
+                             `(list ,@required))))
+           `(named-lambda ,name ,ll
+              (declare (ignore .pv. .next-method-call.))
+              (let ((.gf-args. ,gf-args))
+                (declare (ignorable .gf-args.))
+                ,@check-applicable-keywords
+                ,effective-method))))
+        (t
+         `(named-lambda ,name ,ll
+            (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.))))
+            ,@check-applicable-keywords
+            ,effective-method))))))
 
 (defun expand-emf-call-method (gf form metatypes applyp env)
   (declare (ignore gf metatypes applyp env))
@@ -182,169 +269,261 @@
 
 (defmacro call-method (&rest args)
   (declare (ignore args))
-  `(error "~S outside of a effective method form" 'call-method))
+  ;; the PROGN is here to defend against premature macroexpansion by
+  ;; RESTART-CASE.
+  `(progn (error "~S outside of a effective method form" 'call-method)))
+
+(defun make-effective-method-list-fun-type
+    (generic-function form method-alist-p wrappers-p)
+  (if (every (lambda (form)
+               (eq 'fast-method-call
+                   (make-effective-method-fun-type
+                    generic-function form method-alist-p wrappers-p)))
+             (cdr form))
+      'fast-method-call
+      t))
 
 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (case (make-effective-method-function-type
-		generic-function form method-alist-p wrappers-p)
-	   (fast-method-call
-	    '.fast-call-method.)
-	   (t
-	    '.call-method.)))
-	((and (consp form) (eq (car form) 'call-method-list))
-	 (case (if (every #'(lambda (form)
-			      (eq 'fast-method-call
-				  (make-effective-method-function-type
-				   generic-function form
-				   method-alist-p wrappers-p)))
-			  (cdr form))
-		   'fast-method-call
-		   't)
-	   (fast-method-call
-	    '.fast-call-method-list.)
-	   (t
-	    '.call-method-list.)))
-	(t
-	 (default-test-converter form))))
+  (case (and (consp form) (car form))
+    (call-method
+     (case (make-effective-method-fun-type
+            generic-function form method-alist-p wrappers-p)
+       (fast-method-call '.fast-call-method.)
+       (t '.call-method.)))
+    (call-method-list
+     (case (make-effective-method-list-fun-type
+            generic-function 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))))
 
+;;; CMUCL comment (2003-10-15):
+;;;
+;;;   This function is called via the GET-FUNCTION mechanism on forms
+;;;   of an emf lambda.  First value returned replaces FORM in the emf
+;;;   lambda.  Second value is a list of variable names that become
+;;;   closure variables.
 (defun memf-code-converter
     (form generic-function metatypes applyp method-alist-p wrappers-p)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (let ((gensym (get-effective-method-gensym)))
-	   (values (make-emf-call metatypes applyp gensym
-				  (make-effective-method-function-type
-				   generic-function form method-alist-p wrappers-p))
-		   (list gensym))))
-	((and (consp form) (eq (car form) 'call-method-list))
-	 (let ((gensym (get-effective-method-gensym))
-	       (type (if (every #'(lambda (form)
-				    (eq 'fast-method-call
-					(make-effective-method-function-type
-					 generic-function form
-					 method-alist-p wrappers-p)))
-				(cdr form))
-			 'fast-method-call
-			 't)))
-	   (values `(dolist (emf ,gensym nil)
-		      ,(make-emf-call metatypes applyp 'emf type))
-		   (list gensym))))
-	(t
-	 (default-code-converter form))))
+  (case (and (consp form) (car form))
+    (call-method
+     (let ((gensym (get-effective-method-gensym)))
+       (values (make-emf-call
+                (length metatypes) applyp gensym
+                (make-effective-method-fun-type
+                 generic-function form method-alist-p wrappers-p))
+               (list gensym))))
+    (call-method-list
+     (let ((gensym (get-effective-method-gensym))
+           (type (make-effective-method-list-fun-type
+                  generic-function form method-alist-p wrappers-p)))
+       (values `(dolist (emf ,gensym nil)
+                 ,(make-emf-call (length metatypes) applyp 'emf type))
+               (list gensym))))
+    (check-applicable-keywords
+     (values `(check-applicable-keywords .keyargs-start.
+                                         .valid-keys.
+                                         .dfun-more-context.
+                                         .dfun-more-count.)
+             '(.keyargs-start. .valid-keys.)))
+    (t
+     (default-code-converter form))))
 
 (defun memf-constant-converter (form generic-function)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (list (cons '.meth.
-		     (make-effective-method-function-simple
-		      generic-function form))))
-	((and (consp form) (eq (car form) 'call-method-list))
-	 (list (cons '.meth-list.
-		     (mapcar #'(lambda (form)
-				 (make-effective-method-function-simple
-				  generic-function form))
-			     (cdr form)))))
-	(t
-	 (default-constant-converter form))))
+  (case (and (consp form) (car form))
+    (call-method
+     (list (cons '.meth.
+                 (make-effective-method-function-simple
+                  generic-function form))))
+    (call-method-list
+     (list (cons '.meth-list.
+                 (mapcar (lambda (form)
+                           (make-effective-method-function-simple
+                            generic-function form))
+                         (cdr form)))))
+    (check-applicable-keywords
+     '(.keyargs-start. .valid-keys.))
+    (t
+     (default-constant-converter form))))
 
+(defvar *applicable-methods*)
 (defun make-effective-method-function-internal
     (generic-function effective-method method-alist-p wrappers-p)
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore nkeys arg-info))
     (let* ((*rebound-effective-method-gensyms*
-	    *global-effective-method-gensyms*)
-	   (name (if (early-gf-p generic-function)
-		     (!early-gf-name generic-function)
-		     (generic-function-name generic-function)))
-	   (arg-info (cons nreq applyp))
-	   (effective-method-lambda (expand-effective-method-function
-				     generic-function effective-method)))
+            *global-effective-method-gensyms*)
+           (name (if (early-gf-p generic-function)
+                     (!early-gf-name generic-function)
+                     (generic-function-name generic-function)))
+           (arg-info (cons nreq applyp))
+           (effective-method-lambda (expand-effective-method-function
+                                     generic-function effective-method)))
       (multiple-value-bind (cfunction constants)
-	  (get-function1 effective-method-lambda
-			 #'(lambda (form)
-			     (memf-test-converter form generic-function
-						  method-alist-p wrappers-p))
-			 #'(lambda (form)
-			     (memf-code-converter form generic-function
-						  metatypes applyp
-						  method-alist-p wrappers-p))
-			 #'(lambda (form)
-			     (memf-constant-converter form generic-function)))
-	#'(lambda (method-alist wrappers)
-	    (let* ((constants
-		    (mapcar #'(lambda (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))
-				    constant))
-			    constants))
-		   (function (set-function-name
-			      (apply cfunction constants)
-			      `(combined-method ,name))))
-	      (make-fast-method-call :function function
-				     :arg-info arg-info)))))))
+          (get-fun1 effective-method-lambda
+                    (lambda (form)
+                      (memf-test-converter form generic-function
+                                           method-alist-p wrappers-p))
+                    (lambda (form)
+                      (memf-code-converter form generic-function
+                                           metatypes applyp
+                                           method-alist-p wrappers-p))
+                    (lambda (form)
+                      (memf-constant-converter form generic-function)))
+        (lambda (method-alist wrappers)
+          (multiple-value-bind (valid-keys keyargs-start)
+              (when (memq '.valid-keys. constants)
+                (compute-applicable-keywords
+                 generic-function *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 ((fun (apply cfunction
+                                (mapcar #'compute-constant constants))))
+                (set-fun-name fun `(combined-method ,name))
+                (make-fast-method-call :function fun
+                                       :arg-info arg-info)))))))))
 
 (defmacro call-method-list (&rest calls)
   `(progn ,@calls))
 
 (defun make-call-methods (methods)
   `(call-method-list
-    ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
+    ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
+
+(defun gf-requires-emf-keyword-checks (generic-function)
+  (member '&key (gf-lambda-list generic-function)))
+
+(defun standard-compute-effective-method
+    (generic-function combin applicable-methods)
+  (collect ((before) (primary) (after) (around))
+    (flet ((invalid (gf combin m) (invalid-qualifiers gf combin m)))
+      (dolist (m applicable-methods)
+        (let ((qualifiers (if (listp m)
+                              (early-method-qualifiers m)
+                              (safe-method-qualifiers m))))
+          (cond
+            ((null qualifiers) (primary m))
+            ((cdr qualifiers) (invalid generic-function combin m))
+            ((eq (car qualifiers) :around) (around m))
+            ((eq (car qualifiers) :before) (before m))
+            ((eq (car qualifiers) :after) (after m))
+            (t (invalid generic-function combin m))))))
+    (cond ((null (primary))
+           `(%no-primary-method ',generic-function .args.))
+          ((and (null (before)) (null (after)) (null (around)))
+           ;; By returning a single call-method `form' here we enable
+           ;; an important implementation-specific optimization; that
+           ;; is, we can use the fast method function directly as the
+           ;; effective method function.
+           ;;
+           ;; However, the requirement by ANSI (CLHS 7.6.5) on generic
+           ;; function argument checking inhibits this, as we don't
+           ;; perform this checking in fast-method-functions given
+           ;; that they are not solely used for effective method
+           ;; functions, but also in combination, when they should not
+           ;; perform argument checks.
+           (let ((call-method
+                  `(call-method ,(first (primary)) ,(rest (primary)))))
+             (if (gf-requires-emf-keyword-checks generic-function)
+                 ;; the PROGN inhibits the above optimization
+                 `(progn ,call-method)
+                 call-method)))
+          (t
+           (let ((main-effective-method
+                   (if (or (before) (after))
+                       `(multiple-value-prog1
+                          (progn
+                            ,(make-call-methods (before))
+                            (call-method ,(first (primary))
+                                         ,(rest (primary))))
+                          ,(make-call-methods (reverse (after))))
+                       `(call-method ,(first (primary)) ,(rest (primary))))))
+             (if (around)
+                 `(call-method ,(first (around))
+                               (,@(rest (around))
+                                  (make-method ,main-effective-method)))
+                 main-effective-method))))))
+
+;;; helper code for checking keywords in generic function calls.
+(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))
+        (dolist (method methods)
+          (let ((ll (if (consp method)
+                        (early-method-lambda-list method)
+                        (method-lambda-list method))))
+            (multiple-value-bind (n allowp method-keys)
+                (analyze ll)
+              (declare (ignore n))
+              (when allowp
+                (return-from compute-applicable-keywords (values t nopt)))
+              (setq keys (union method-keys keys)))))
+        (aver any-keyp)
+        (values (if allowp t keys) nopt)))))
 
-(defun standard-compute-effective-method (generic-function combin applicable-methods)
-  (declare (ignore combin))
-  (let ((before ())
-	(primary ())
-	(after ())
-	(around ()))
-    (dolist (m applicable-methods)
-      (let ((qualifiers (if (listp m)
-			    (early-method-qualifiers m)
-			    (method-qualifiers m))))
-	(cond ((member ':before qualifiers)  (push m before))
-	      ((member ':after  qualifiers)  (push m after))
-	      ((member ':around  qualifiers) (push m around))
-	      (t
-	       (push m primary)))))
-    (setq before  (reverse before)
-	  after   (reverse after)
-	  primary (reverse primary)
-	  around  (reverse around))
-    (cond ((null primary)
-	   `(error "There is no primary method for the generic function ~S."
-		   ',generic-function))
-	  ((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)))
-	  (t
-	   (let ((main-effective-method
-		   (if (or before after)
-		       `(multiple-value-prog1
-			  (progn ,(make-call-methods before)
-				 (call-method ,(first primary)
-					      ,(rest primary)))
-			  ,(make-call-methods (reverse after)))
-		       `(call-method ,(first primary) ,(rest primary)))))
-	     (if around
-		 `(call-method ,(first around)
-			       (,@(rest around)
-				  (make-method ,main-effective-method)))
-		 main-effective-method))))))
+(defun check-applicable-keywords (start valid-keys more-context more-count)
+  (let ((allow-other-keys-seen nil)
+        (allow-other-keys nil)
+        (i start))
+    (declare (type index i more-count)
+             (optimize speed))
+    (flet ((current-value ()
+             (sb-c::%more-arg more-context i)))
+      (declare (inline current-value))
+      (collect ((invalid))
+        (loop
+           (when (>= i more-count)
+             (when (and (invalid) (not allow-other-keys))
+               (error 'simple-program-error
+                      :format-control "~@<invalid keyword argument~P: ~
+                                   ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
+                      :format-arguments (list (length (invalid)) (invalid) valid-keys)))
+             (return))
+           (let ((key (current-value)))
+             (incf i)
+             (cond
+               ((not (symbolp key))
+                (error 'simple-program-error
+                       :format-control "~@<keyword argument not a symbol: ~S.~@:>"
+                       :format-arguments (list key)))
+               ((= i more-count)
+                (sb-c::%odd-key-args-error))
+               ((eq key :allow-other-keys)
+                ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
+                (unless allow-other-keys-seen
+                  (setq allow-other-keys-seen t
+                        allow-other-keys (current-value))))
+               ((eq t valid-keys))
+               ((not (memq key valid-keys)) (invalid key))))
+           (incf i))))))
 
-;;;; the STANDARD method combination type. This is coded by hand (rather than
-;;;; with define-method-combination) for bootstrapping and efficiency reasons.
-;;;; Note that the definition of the find-method-combination-method appears in
-;;;; the file defcombin.lisp. This is because EQL methods can't appear in the
+;;;; the STANDARD method combination type. This is coded by hand
+;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
+;;;; and efficiency reasons. Note that the definition of the
+;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
+;;;; defcombin.lisp. This is because EQL methods can't appear in the
 ;;;; bootstrap.
 ;;;;
 ;;;; The DEFCLASS for the METHOD-COMBINATION and
@@ -354,55 +533,18 @@
 
 (defun compute-effective-method (generic-function combin applicable-methods)
   (standard-compute-effective-method generic-function
-				     combin
-				     applicable-methods))
-
-;;; FIXME: As of sbcl-0.6.10, the bindings of *INVALID-METHOD-ERROR*
-;;; and *METHOD-COMBINATION-ERROR* are never changed, even within the
-;;; dynamic scope of method combination functions.
-(defvar *invalid-method-error*
-	#'(lambda (&rest args)
-	    (declare (ignore args))
-	    (error
-	      "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
-	       of a method combination function (inside the body of~%~
-	       DEFINE-METHOD-COMBINATION or a method on the generic~%~
-	       function COMPUTE-EFFECTIVE-METHOD).")))
-(defvar *method-combination-error*
-	#'(lambda (&rest args)
-	    (declare (ignore args))
-	    (error
-	      "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
-	       of a method combination function (inside the body of~%~
-	       DEFINE-METHOD-COMBINATION or a method on the generic~%~
-	       function COMPUTE-EFFECTIVE-METHOD).")))
-
-;(defmethod compute-effective-method :around	;issue with magic
-;	   ((generic-function generic-function)     ;generic functions
-;	    (method-combination method-combination)
-;	    applicable-methods)
-;  (declare (ignore applicable-methods))
-;  (flet ((real-invalid-method-error (method format-string &rest args)
-;	   (declare (ignore method))
-;	   (apply #'error format-string args))
-;	 (real-method-combination-error (format-string &rest args)
-;	   (apply #'error format-string args)))
-;    (let ((*invalid-method-error* #'real-invalid-method-error)
-;	  (*method-combination-error* #'real-method-combination-error))
-;      (call-next-method))))
-
-(defun invalid-method-error (&rest args)
-  (apply *invalid-method-error* args))
+                                     combin
+                                     applicable-methods))
 
-(defun method-combination-error (&rest args)
-  (apply *method-combination-error* args))
+(defun invalid-method-error (method format-control &rest format-arguments)
+  (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+    (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
+           method
+           format-control
+           format-arguments)))
 
-;This definition now appears in defcombin.lisp.
-;
-;(defmethod find-method-combination ((generic-function generic-function)
-;				     (type (eql 'standard))
-;				     options)
-;  (when options
-;    (method-combination-error
-;      "The method combination type STANDARD accepts no options."))
-;  *standard-method-combination*)
+(defun method-combination-error (format-control &rest format-arguments)
+  (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+    (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
+           format-control
+           format-arguments)))