X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=87c30fe284e274dd7f246a5837edcc5d6f387463;hb=644995852be20e0dcb64cdcbadfe1b98834a4c9c;hp=559b3eac0c78f831c2c030ff20a94a784a389de0;hpb=920f9a94cc0512d7fbab3f1578e8b71485b18b00;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 559b3ea..87c30fe 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -68,16 +68,6 @@ bootstrapping.
 
 |#
 
-;;; FIXME: As of sbcl-0.6.9.10, PCL still uses this nonstandard type
-;;; of declaration internally. It would be good to figure out how to
-;;; get rid of it, or failing that, (1) document why it's needed and
-;;; (2) use a private symbol with a forbidding name which suggests
-;;; it's not to be messed with by the user (e.g. SB-PCL:%CLASS)
-;;; instead of the too-inviting CLASS. (I tried just deleting the
-;;; declarations in MAKE-METHOD-LAMBDA-INTERNAL ca. sbcl-0.6.9.10, but
-;;; then things break.)
-(declaim (declaration class))
-
 (declaim (notinline make-a-method
 		    add-named-method
 		    ensure-generic-function-using-class
@@ -165,7 +155,7 @@ bootstrapping.
 		    (qualifiers (subseq qab 0 arglist-pos))
 		    (body (nthcdr (1+ arglist-pos) qab)))
 	       `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body)
-                      (generic-function-initial-methods #',fun-name)))))
+                      (generic-function-initial-methods (fdefinition ',fun-name))))))
       (macrolet ((initarg (key) `(getf initargs ,key)))
 	(dolist (option options)
 	  (let ((car-option (car option)))
@@ -189,12 +179,33 @@ bootstrapping.
 			:format-control "The declaration specifier ~S ~
                                          is not allowed inside DEFGENERIC."
 			:format-arguments (list (cadr option))))
-	       (push (cdr option) (initarg :declarations)))
-	      ((:argument-precedence-order :method-combination)
-	       (if (initarg car-option)
-		   (duplicate-option car-option)
-		   (setf (initarg car-option)
-			 `',(cdr option))))
+	       (push (cadr option) (initarg :declarations)))
+	      (:method-combination
+	       (when (initarg car-option)
+		 (duplicate-option car-option))
+	       (unless (symbolp (cadr option))
+		 (error 'simple-program-error
+			:format-control "METHOD-COMBINATION name not a ~
+                                         symbol: ~S"
+			:format-arguments (list (cadr option))))
+	       (setf (initarg car-option)
+		     `',(cdr option)))
+	      (:argument-precedence-order
+	       (let* ((required (parse-lambda-list lambda-list))
+		      (supplied (cdr option)))
+		 (unless (= (length required) (length supplied))
+		   (error 'simple-program-error
+			  :format-control "argument count discrepancy in ~
+                                           :ARGUMENT-PRECEDENCE-ORDER clause."
+			  :format-arguments nil))
+		 (when (set-difference required supplied)
+		   (error 'simple-program-error
+			  :format-control "unequal sets for ~
+                                           :ARGUMENT-PRECEDENCE-ORDER clause: ~
+                                           ~S and ~S"
+			  :format-arguments (list required supplied)))
+		 (setf (initarg car-option)
+		       `',(cdr option))))
 	      ((:documentation :generic-function-class :method-class)
 	       (unless (proper-list-of-length-p option 2)
 		 (error "bad list length for ~S" option))
@@ -218,19 +229,19 @@ bootstrapping.
 	   (compile-or-load-defgeneric ',fun-name))
          (load-defgeneric ',fun-name ',lambda-list ,@initargs)
         ,@(mapcar #'expand-method-definition methods)
-	 #',fun-name))))
+        (fdefinition ',fun-name)))))
 
 (defun compile-or-load-defgeneric (fun-name)
-  (sb-kernel:proclaim-as-fun-name fun-name)
-  (sb-kernel:note-name-defined fun-name :function)
+  (proclaim-as-fun-name fun-name)
+  (note-name-defined fun-name :function)
   (unless (eq (info :function :where-from fun-name) :declared)
     (setf (info :function :where-from fun-name) :defined)
     (setf (info :function :type fun-name)
-	  (sb-kernel:specifier-type 'function))))
+	  (specifier-type 'function))))
 
 (defun load-defgeneric (fun-name lambda-list &rest initargs)
   (when (fboundp fun-name)
-    (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)
+    (style-warn "redefining ~S in DEFGENERIC" fun-name)
     (let ((fun (fdefinition fun-name)))
       (when (generic-function-p fun)
         (loop for method in (generic-function-initial-methods fun)
@@ -242,18 +253,18 @@ bootstrapping.
          :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
          initargs))
 
-;;; As per section 3.4.2 of the ANSI spec, generic function lambda
-;;; lists have some special limitations, which we check here.
+(define-condition generic-function-lambda-list-error
+    (reference-condition simple-program-error)
+  ()
+  (:default-initargs :references (list '(:ansi-cl :section (3 4 2)))))
+
 (defun check-gf-lambda-list (lambda-list)
   (flet ((ensure (arg ok)
            (unless ok
-	     (error
-	      ;; (s/invalid/non-ANSI-conforming/ because the old PCL
-	      ;; implementation allowed this, so people got used to
-	      ;; it, and maybe this phrasing will help them to guess
-	      ;; why their program which worked under PCL no longer works.)
-	      "~@<non-ANSI-conforming argument ~S ~_in the generic function lambda list ~S~:>"
-	      arg lambda-list))))
+	     (error 'generic-function-lambda-list-error
+		    :format-control
+		    "~@<invalid ~S ~_in the generic function lambda list ~S~:>"
+		    :format-arguments (list arg lambda-list)))))
     (multiple-value-bind (required optional restp rest keyp keys allowp
                           auxp aux morep more-context more-count)
 	(parse-lambda-list lambda-list)
@@ -335,11 +346,6 @@ bootstrapping.
 	    (class-prototype (or (generic-function-method-class gf?)
 				 (find-class 'standard-method)))))))
 
-(defvar *optimize-asv-funcall-p* nil)
-(defvar *asv-readers*)
-(defvar *asv-writers*)
-(defvar *asv-boundps*)
-
 (defun expand-defmethod (name
 			 proto-gf
 			 proto-method
@@ -347,53 +353,43 @@ bootstrapping.
 			 lambda-list
 			 body
 			 env)
-  (let ((*make-instance-function-keys* nil)
-	(*optimize-asv-funcall-p* t)
-	(*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
-    (declare (special *make-instance-function-keys*))
-    (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
-	(add-method-declarations name qualifiers lambda-list body env)
-      (multiple-value-bind (method-function-lambda initargs)
-	  (make-method-lambda proto-gf proto-method method-lambda env)
-	(let ((initargs-form (make-method-initargs-form proto-gf
-							proto-method
-							method-function-lambda
-							initargs
-							env)))
-	  `(progn
-	     ;; Note: We could DECLAIM the ftype of the generic
-	     ;; function here, since ANSI specifies that we create it
-	     ;; if it does not exist. However, I chose not to, because
-	     ;; I think it's more useful to support a style of
-	     ;; programming where every generic function has an
-	     ;; explicit DEFGENERIC and any typos in DEFMETHODs are
-	     ;; warned about. Otherwise
-	     ;;   (DEFGENERIC FOO-BAR-BLETCH ((X T)))
-	     ;;   (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
-	     ;;   (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
-	     ;;   (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
-	     ;;   (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
-	     ;;   (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
-	     ;; compiles without raising an error and runs without
-	     ;; raising an error (since SIMPLE-VECTOR cases fall
-	     ;; through to VECTOR) but still doesn't do what was
-	     ;; intended. I hate that kind of bug (code which silently
-	     ;; gives the wrong answer), so we don't do a DECLAIM
-	     ;; here. -- WHN 20000229
-	     ,@(when *make-instance-function-keys*
-		 `((get-make-instance-functions
-		    ',*make-instance-function-keys*)))
-	     ,@(when (or *asv-readers* *asv-writers* *asv-boundps*)
-		 `((initialize-internal-slot-gfs*
-		    ',*asv-readers* ',*asv-writers* ',*asv-boundps*)))
-	     ,(make-defmethod-form name qualifiers specializers
-				   unspecialized-lambda-list
-				   (if proto-method
-				       (class-name (class-of proto-method))
-				       'standard-method)
-				   initargs-form
-				   (getf (getf initargs :plist)
-					 :pv-table-symbol))))))))
+  (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
+      (add-method-declarations name qualifiers lambda-list body env)
+    (multiple-value-bind (method-function-lambda initargs)
+	(make-method-lambda proto-gf proto-method method-lambda env)
+      (let ((initargs-form (make-method-initargs-form proto-gf
+						      proto-method
+						      method-function-lambda
+						      initargs
+						      env)))
+	`(progn
+	  ;; Note: We could DECLAIM the ftype of the generic function
+	  ;; here, since ANSI specifies that we create it if it does
+	  ;; not exist. However, I chose not to, because I think it's
+	  ;; more useful to support a style of programming where every
+	  ;; generic function has an explicit DEFGENERIC and any typos
+	  ;; in DEFMETHODs are warned about. Otherwise
+	  ;;
+	  ;;   (DEFGENERIC FOO-BAR-BLETCH ((X T)))
+	  ;;   (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+	  ;;   (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+	  ;;   (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+	  ;;   (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+	  ;;   (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+	  ;;
+	  ;; compiles without raising an error and runs without
+	  ;; raising an error (since SIMPLE-VECTOR cases fall through
+	  ;; to VECTOR) but still doesn't do what was intended. I hate
+	  ;; that kind of bug (code which silently gives the wrong
+	  ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
+	  ,(make-defmethod-form name qualifiers specializers
+				unspecialized-lambda-list
+				(if proto-method
+				    (class-name (class-of proto-method))
+				    'standard-method)
+				initargs-form
+				(getf (getf initargs :plist)
+				      :pv-table-symbol)))))))
 
 (defun interned-symbol-p (x)
   (and (symbolp x) (symbol-package x)))
@@ -429,24 +425,16 @@ bootstrapping.
 				   specl))
 			       specializers))
 	       (mname `(,(if (eq (cadr initargs-form) :function)
-			     'method 'fast-method)
-			,name ,@qualifiers ,specls))
-	       (mname-sym (intern (let ((*print-pretty* nil)
-					;; (We bind *PACKAGE* to
-					;; KEYWORD here as a way to
-					;; force symbols to be printed
-					;; with explicit package
-					;; prefixes.)
-					(*package* *keyword-package*))
-				    (format nil "~S" mname)))))
+			     'slow-method 'fast-method)
+			,name ,@qualifiers ,specls)))
 	  `(progn
-	     (defun ,mname-sym ,(cadr fn-lambda)
+	     (defun ,mname ,(cadr fn-lambda)
 	       ,@(cddr fn-lambda))
 	     ,(make-defmethod-form-internal
 	       name qualifiers `',specls
 	       unspecialized-lambda-list method-class-name
 	       `(list* ,(cadr initargs-form)
-		       #',mname-sym
+		       #',mname
 		       ,@(cdddr initargs-form))
 	       pv-table-symbol)))
 	(make-defmethod-form-internal
@@ -454,7 +442,7 @@ bootstrapping.
 	 `(list ,@(mapcar (lambda (specializer)
 			    (if (consp specializer)
 				``(,',(car specializer)
-				   ,,(cadr specializer))
+				      ,,(cadr specializer))
 				`',specializer))
 			  specializers))
 	 unspecialized-lambda-list
@@ -493,11 +481,11 @@ bootstrapping.
 				 env))))
 
 (defun add-method-declarations (name qualifiers lambda-list body env)
+  (declare (ignore env))
   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
       (parse-specialized-lambda-list lambda-list)
-    (declare (ignore parameters))
     (multiple-value-bind (real-body declarations documentation)
-	(parse-body body env)
+	(parse-body body)
       (values `(lambda ,unspecialized-lambda-list
 		 ,@(when documentation `(,documentation))
 		 ;; (Old PCL code used a somewhat different style of
@@ -601,9 +589,52 @@ bootstrapping.
 	 ;; second argument.) Hopefully it only does this kind of
 	 ;; weirdness when bootstrapping.. -- WHN 20000610
 	 '(ignorable))
+	((var-globally-special-p parameter)
+	 ;; KLUDGE: Don't declare types for global special variables
+	 ;; -- our rebinding magic for SETQ cases don't work right
+	 ;; there.
+	 ;;
+	 ;; FIXME: It would be better to detect the SETQ earlier and
+	 ;; skip declarations for specials only when needed, not
+	 ;; always.
+	 ;;
+	 ;; --NS 2004-10-14
+	 '(ignorable))
 	(t
-	 ;; Otherwise, we can make Python very happy.
-	 `(type ,specializer ,parameter))))
+	 ;; Otherwise, we can usually make Python very happy.
+	 (let ((kind (info :type :kind specializer)))
+	   (ecase kind
+	     ((:primitive) `(type ,specializer ,parameter))
+	     ((:defined) 
+	      (let ((class (find-class specializer nil)))
+                ;; CLASS can be null here if the user has erroneously
+                ;; tried to use a defined type as a specializer; it
+                ;; can be a non-BUILT-IN-CLASS if the user defines a
+                ;; type and calls (SETF FIND-CLASS) in a consistent
+                ;; way.
+                (when (and class (typep class 'built-in-class))
+                  `(type ,specializer ,parameter))))
+	     ((:instance nil)
+	      (let ((class (find-class specializer nil)))
+		(cond
+		  (class
+		   (if (typep class '(or built-in-class structure-class))
+		       `(type ,specializer ,parameter)
+		       ;; don't declare CLOS classes as parameters;
+		       ;; it's too expensive.
+		       '(ignorable)))
+		  (t
+		   ;; we can get here, and still not have a failure
+		   ;; case, by doing MOP programming like (PROGN
+		   ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
+		   ;; ...)).  Best to let the user know we haven't
+		   ;; been able to extract enough information:
+		   (style-warn
+		    "~@<can't find type for presumed class ~S in ~S.~@:>"
+		    specializer
+		    'parameter-specializer-declaration-in-defmethod)
+		   '(ignorable)))))
+	     ((:forthcoming-defclass-type) '(ignorable)))))))
 
 (defun make-method-lambda-internal (method-lambda &optional env)
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
@@ -611,7 +642,7 @@ bootstrapping.
 	    is not a lambda form."
 	   method-lambda))
   (multiple-value-bind (real-body declarations documentation)
-      (parse-body (cddr method-lambda) env)
+      (parse-body (cddr method-lambda))
     (let* ((name-decl (get-declaration '%method-name declarations))
 	   (sll-decl (get-declaration '%method-lambda-list declarations))
 	   (method-name (when (consp name-decl) (car name-decl)))
@@ -645,8 +676,9 @@ bootstrapping.
 		  ;; it can avoid run-time type dispatch overhead,
 		  ;; which can be a huge win for Python.)
 		  ;;
-		  ;; FIXME: Perhaps these belong in
-		  ;; ADD-METHOD-DECLARATIONS instead of here?
+		  ;; KLUDGE: when I tried moving these to
+		  ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
+		  ;; why.  -- CSR, 2004-06-16
 		  ,@(mapcar #'parameter-specializer-declaration-in-defmethod
 			    parameters
 			    specializers)))
@@ -692,7 +724,8 @@ bootstrapping.
 			       ((eq p '&aux)
 				(return nil))))))
 	  (multiple-value-bind
-	      (walked-lambda call-next-method-p closurep next-method-p-p)
+		(walked-lambda call-next-method-p closurep
+			       next-method-p-p setq-p)
 	      (walk-method-lambda method-lambda
 				  required-parameters
 				  env
@@ -701,7 +734,7 @@ bootstrapping.
 	    (multiple-value-bind (walked-lambda-body
 				  walked-declarations
 				  walked-documentation)
-		(parse-body (cddr walked-lambda) env)
+		(parse-body (cddr walked-lambda))
 	      (declare (ignore walked-documentation))
 	      (when (or next-method-p-p call-next-method-p)
 		(setq plist (list* :needs-next-methods-p t plist)))
@@ -733,6 +766,7 @@ bootstrapping.
 					:call-next-method-p
 					,call-next-method-p
 					:next-method-p-p ,next-method-p-p
+			                :setq-p ,setq-p
 			                ;; we need to pass this along
 			                ;; so that NO-NEXT-METHOD can
 			                ;; be given a suitable METHOD
@@ -780,22 +814,26 @@ bootstrapping.
 (defmacro bind-simple-lexical-method-macros ((method-args next-methods)
 					     &body body)
   `(macrolet ((call-next-method-bind (&body body)
-		`(let ((.next-method. (car ,',next-methods))
-		       (,',next-methods (cdr ,',next-methods)))
-		   .next-method. ,',next-methods
-		   ,@body))
+	       `(let ((.next-method. (car ,',next-methods))
+		      (,',next-methods (cdr ,',next-methods)))
+		 .next-method. ,',next-methods
+		 ,@body))
 	      (call-next-method-body (method-name-declaration cnm-args)
-		`(if .next-method.
-		     (funcall (if (std-instance-p .next-method.)
-				  (method-function .next-method.)
-				  .next-method.) ; for early methods
-			      (or ,cnm-args ,',method-args)
-			      ,',next-methods)
-		     (apply #'call-no-next-method ',method-name-declaration
+	       `(if .next-method.
+		    (funcall (if (std-instance-p .next-method.)
+				 (method-function .next-method.)
+			     .next-method.) ; for early methods
+		             (or ,cnm-args ,',method-args)
+		             ,',next-methods)
+		    (apply #'call-no-next-method ',method-name-declaration
 		            (or ,cnm-args ,',method-args))))
 	      (next-method-p-body ()
-		`(not (null .next-method.))))
-     ,@body))
+	       `(not (null .next-method.)))
+	      (with-rebound-original-args ((call-next-method-p setq-p)
+					   &body body)
+		(declare (ignore call-next-method-p setq-p))
+		`(let () ,@body)))
+    ,@body))
 
 (defun call-no-next-method (method-name-declaration &rest args)
   (destructuring-bind (name) method-name-declaration
@@ -937,7 +975,7 @@ bootstrapping.
 	       `(((typep ,emf 'fixnum)
 		  (let ((.new-value. ,(car required-args+rest-arg))
 			(.slots. (get-slots-or-nil
-				  ,(car required-args+rest-arg))))
+				  ,(cadr required-args+rest-arg))))
 		    (when .slots.
 		      (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
 	   ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
@@ -971,15 +1009,21 @@ bootstrapping.
 	   (cond ((null args)
 		  (if (eql nreq 0)
 		      (invoke-fast-method-call emf)
-		      (error "wrong number of args")))
+		      (error 'simple-program-error
+			     :format-control "invalid number of arguments: 0"
+			     :format-arguments nil)))
 		 ((null (cdr args))
 		  (if (eql nreq 1)
 		      (invoke-fast-method-call emf (car args))
-		      (error "wrong number of args")))
+		      (error 'simple-program-error
+			     :format-control "invalid number of arguments: 1"
+			     :format-arguments nil)))
 		 ((null (cddr args))
 		  (if (eql nreq 2)
 		      (invoke-fast-method-call emf (car args) (cadr args))
-		      (error "wrong number of args")))
+		      (error 'simple-program-error
+			     :format-control "invalid number of arguments: 2"
+			     :format-arguments nil)))
 		 (t
 		  (apply (fast-method-call-function emf)
 			 (fast-method-call-pv-cell emf)
@@ -990,7 +1034,10 @@ bootstrapping.
 	    args
 	    (method-call-call-method-args emf)))
     (fixnum
-     (cond ((null args) (error "1 or 2 args were expected."))
+     (cond ((null args)
+	    (error 'simple-program-error
+		   :format-control "invalid number of arguments: 0"
+		   :format-arguments nil))
 	   ((null (cdr args))
 	    (let* ((slots (get-slots (car args)))
                    (value (clos-slots-ref slots emf)))
@@ -998,109 +1045,112 @@ bootstrapping.
 		  (slot-unbound-internal (car args) emf)
 		  value)))
 	   ((null (cddr args))
-             (setf (clos-slots-ref (get-slots (cadr args)) emf)
-		   (car args)))
-	   (t (error "1 or 2 args were expected."))))
+	    (setf (clos-slots-ref (get-slots (cadr args)) emf)
+		  (car args)))
+	   (t (error 'simple-program-error
+		     :format-control "invalid number of arguments"
+		     :format-arguments nil))))
     (fast-instance-boundp
      (if (or (null args) (cdr args))
-	 (error "1 arg was expected.")
-       (let ((slots (get-slots (car args))))
-	 (not (eq (clos-slots-ref slots
-				  (fast-instance-boundp-index emf))
-		  +slot-unbound+)))))
+	 (error 'simple-program-error
+		:format-control "invalid number of arguments"
+		:format-arguments nil)
+	 (let ((slots (get-slots (car args))))
+	   (not (eq (clos-slots-ref slots (fast-instance-boundp-index emf))
+		    +slot-unbound+)))))
     (function
      (apply emf args))))
 
 (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
 					   &body body)
-  `(macrolet ((narrowed-emf (emf)
-	        ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to
-		;; dispatch on the possibility that EMF might be of
-		;; type FIXNUM (as an optimized representation of a
-		;; slot accessor). But as far as I (WHN 2002-06-11)
-		;; can tell, it's impossible for such a representation
-		;; to end up as .NEXT-METHOD-CALL. By reassuring
-		;; INVOKE-E-M-F that when called from this context
-		;; it needn't worry about the FIXNUM case, we can
-		;; keep those cases from being compiled, which is
-		;; good both because it saves bytes and because it
-		;; avoids annoying type mismatch compiler warnings.
-		;;
-                ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type
-		;; system isn't smart enough about NOT and intersection
-		;; types to benefit from a (NOT FIXNUM) declaration
-		;; here. -- WHN 2002-06-12
-		;;
-		;; FIXME: Might the FUNCTION type be omittable here,
-		;; leaving only METHOD-CALLs? Failing that, could this
-		;; be documented somehow? (It'd be nice if the types
-		;; involved could be understood without solving the
-                ;; halting problem.)
-                `(the (or function method-call fast-method-call)
+  (let* ((all-params (append args (when rest-arg (list rest-arg))))
+	 (rebindings (mapcar (lambda (x) (list x x)) all-params)))
+    `(macrolet ((narrowed-emf (emf)
+		 ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to
+		 ;; dispatch on the possibility that EMF might be of
+		 ;; type FIXNUM (as an optimized representation of a
+		 ;; slot accessor). But as far as I (WHN 2002-06-11)
+		 ;; can tell, it's impossible for such a representation
+		 ;; to end up as .NEXT-METHOD-CALL. By reassuring
+		 ;; INVOKE-E-M-F that when called from this context
+		 ;; it needn't worry about the FIXNUM case, we can
+		 ;; keep those cases from being compiled, which is
+		 ;; good both because it saves bytes and because it
+		 ;; avoids annoying type mismatch compiler warnings.
+		 ;;
+		 ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type
+		 ;; system isn't smart enough about NOT and
+		 ;; intersection types to benefit from a (NOT FIXNUM)
+		 ;; declaration here. -- WHN 2002-06-12 (FIXME: maybe
+		 ;; it is now... -- CSR, 2003-06-07)
+		 ;;
+		 ;; FIXME: Might the FUNCTION type be omittable here,
+		 ;; leaving only METHOD-CALLs? Failing that, could this
+		 ;; be documented somehow? (It'd be nice if the types
+		 ;; involved could be understood without solving the
+		 ;; halting problem.)
+		 `(the (or function method-call fast-method-call)
 		   ,emf))
-	      (call-next-method-bind (&body body)
-               `(let () ,@body))
-	      (call-next-method-body (method-name-declaration cnm-args)
-               `(if ,',next-method-call
-                 ,(locally
-                   ;; This declaration suppresses a "deleting
-                   ;; unreachable code" note for the following IF when
-                   ;; REST-ARG is NIL. It is not nice for debugging
-                   ;; SBCL itself, but at least it keeps us from
-                   ;; annoying users.
-                   (declare (optimize (inhibit-warnings 3)))
-                   (if (and (null ',rest-arg)
-                            (consp cnm-args)
-                            (eq (car cnm-args) 'list))
-                       `(invoke-effective-method-function
-                         (narrowed-emf ,',next-method-call)
-			 nil
-                         ,@(cdr cnm-args))
-                       (let ((call `(invoke-effective-method-function
-                                     (narrowed-emf ,',next-method-call)
-                                     ,',(not (null rest-arg))
-                                     ,@',args
-                                     ,@',(when rest-arg `(,rest-arg)))))
-                         `(if ,cnm-args
-                           (bind-args ((,@',args
-                                        ,@',(when rest-arg
-					      `(&rest ,rest-arg)))
-                                       ,cnm-args)
-                            ,call)
-                           ,call))))
-		 ,(if (and (null ',rest-arg)
-			   (consp cnm-args)
-			   (eq (car cnm-args) 'list))
-		      `(call-no-next-method ',method-name-declaration
-			                    ,@(cdr cnm-args))
-		      `(call-no-next-method ',method-name-declaration
-			                    ,@',args
-			                    ,@',(when rest-arg
-						      `(,rest-arg))))))
-	      (next-method-p-body ()
-               `(not (null ,',next-method-call))))
-    ,@body))
+		(call-next-method-bind (&body body)
+		 `(let () ,@body))
+		(call-next-method-body (method-name-declaration cnm-args)
+		 `(if ,',next-method-call
+		      ,(locally
+			;; This declaration suppresses a "deleting
+			;; unreachable code" note for the following IF
+			;; when REST-ARG is NIL. It is not nice for
+			;; debugging SBCL itself, but at least it
+			;; keeps us from annoying users.
+			(declare (optimize (inhibit-warnings 3)))
+			(if (and (null ',rest-arg)
+				 (consp cnm-args)
+				 (eq (car cnm-args) 'list))
+			    `(invoke-effective-method-function
+			      (narrowed-emf ,',next-method-call)
+			      nil
+			      ,@(cdr cnm-args))
+			    (let ((call `(invoke-effective-method-function
+					  (narrowed-emf ,',next-method-call)
+					  ,',(not (null rest-arg))
+					  ,@',args
+					  ,@',(when rest-arg `(,rest-arg)))))
+			      `(if ,cnm-args
+				(bind-args ((,@',args
+					     ,@',(when rest-arg
+						       `(&rest ,rest-arg)))
+					    ,cnm-args)
+				 ,call)
+				,call))))
+		      ,(locally
+			;; As above, this declaration suppresses code
+			;; deletion notes.
+			(declare (optimize (inhibit-warnings 3)))
+			(if (and (null ',rest-arg)
+				 (consp cnm-args)
+				 (eq (car cnm-args) 'list))
+			    `(call-no-next-method ',method-name-declaration
+			      ,@(cdr cnm-args))
+			    `(call-no-next-method ',method-name-declaration
+			      ,@',args
+			      ,@',(when rest-arg
+					`(,rest-arg)))))))
+		(next-method-p-body ()
+		 `(not (null ,',next-method-call)))
+		(with-rebound-original-args ((cnm-p setq-p) &body body)
+		  (if (or cnm-p setq-p)
+		      `(let ,',rebindings
+			(declare (ignorable ,@',all-params))
+			,@body)
+		      `(let () ,@body))))
+      ,@body)))
 
 (defmacro bind-lexical-method-functions
-    ((&key call-next-method-p next-method-p-p
+    ((&key call-next-method-p next-method-p-p setq-p
 	   closurep applyp method-name-declaration)
      &body body)
   (cond ((and (null call-next-method-p) (null next-method-p-p)
-	      (null closurep)
-	      (null applyp))
+	      (null closurep) (null applyp) (null setq-p))
 	 `(let () ,@body))
-	((and (null closurep)
-	      (null applyp))
-	 ;; OK to use MACROLET, and all args are mandatory
-	 ;; (else APPLYP would be true).
-	 `(call-next-method-bind
-	    (macrolet ((call-next-method (&rest cnm-args)
-			 `(call-next-method-body ,',method-name-declaration
-			                         ,(when cnm-args
-						    `(list ,@cnm-args))))
-		       (next-method-p ()
-			 `(next-method-p-body)))
-	       ,@body)))
 	(t
 	 `(call-next-method-bind
 	    (flet (,@(and call-next-method-p
@@ -1110,8 +1160,9 @@ bootstrapping.
 			      cnm-args))))
 		   ,@(and next-method-p-p
 			  '((next-method-p ()
-			      (next-method-p-body)))))
-	      ,@body)))))
+			     (next-method-p-body)))))
+	      (with-rebound-original-args (,call-next-method-p ,setq-p)
+		,@body))))))
 
 (defmacro bind-args ((lambda-list args) &body body)
   (let ((args-tail '.args-tail.)
@@ -1178,8 +1229,14 @@ bootstrapping.
 		   (aux `(,var))))))
       (let ((bindings (mapcan #'process-var lambda-list)))
 	`(let* ((,args-tail ,args)
-		,@bindings)
-	   (declare (ignorable ,args-tail))
+		,@bindings
+		(.dummy0.
+		 ,@(when (eq state 'optional)
+		     `((unless (null ,args-tail)
+			 (error 'simple-program-error
+				:format-control "surplus arguments: ~S"
+				:format-arguments (list ,args-tail)))))))
+	   (declare (ignorable ,args-tail .dummy0.))
 	   ,@body)))))
 
 (defun get-key-arg-tail (keyword list)
@@ -1196,8 +1253,9 @@ bootstrapping.
 				   ; should be in the method definition
 	(closurep nil)		   ; flag indicating that #'CALL-NEXT-METHOD
 				   ; was seen in the body of a method
-	(next-method-p-p nil))     ; flag indicating that NEXT-METHOD-P
+	(next-method-p-p nil)      ; flag indicating that NEXT-METHOD-P
 				   ; should be in the method definition
+	(setq-p nil))
     (flet ((walk-function (form context env)
 	     (cond ((not (eq context :eval)) form)
 		   ;; FIXME: Jumping to a conclusion from the way it's used
@@ -1212,6 +1270,17 @@ bootstrapping.
 		   ((eq (car form) 'next-method-p)
 		    (setq next-method-p-p t)
 		    form)
+		   ((memq (car form) '(setq multiple-value-setq))
+		    ;; FIXME: this is possibly a little strong as
+		    ;; conditions go.  Ideally we would want to detect
+		    ;; which, if any, of the method parameters are
+		    ;; being set, and communicate that information to
+		    ;; e.g. SPLIT-DECLARATIONS.  However, the brute
+		    ;; force method doesn't really cost much; a little
+		    ;; loss of discrimination over IGNORED variables
+		    ;; should be all.  -- CSR, 2004-07-01
+		    (setq setq-p t)
+		    form)
 		   ((and (eq (car form) 'function)
 			 (cond ((eq (cadr form) 'call-next-method)
 				(setq call-next-method-p t)
@@ -1242,20 +1311,14 @@ bootstrapping.
 		   ((generic-function-name-p (car form))
 		    (optimize-generic-function-call
 		     form required-parameters env slots calls))
-		   ((and (eq (car form) 'asv-funcall)
-			 *optimize-asv-funcall-p*)
-		    (case (fourth form)
-		      (reader (push (third form) *asv-readers*))
-		      (writer (push (third form) *asv-writers*))
-		      (boundp (push (third form) *asv-boundps*)))
-		    `(,(second form) ,@(cddddr form)))
 		   (t form))))
 
       (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
 	(values walked-lambda
 		call-next-method-p
 		closurep
-		next-method-p-p)))))
+		next-method-p-p
+		setq-p)))))
 
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)
@@ -1335,13 +1398,14 @@ bootstrapping.
 	     (fboundp gf-spec))
     (let* ((gf (fdefinition gf-spec))
 	   (method (and (generic-function-p gf)
+                        (generic-function-methods gf)
 			(find-method gf
 				     qualifiers
                                      (parse-specializers specializers)
 				     nil))))
       (when method
-	(sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
-			       gf-spec qualifiers specializers))))
+	(style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
+		    gf-spec qualifiers specializers))))
   (let ((method (apply #'add-named-method
 		       gf-spec qualifiers specializers lambda-list
 		       :definition-source `((defmethod ,gf-spec
@@ -1363,7 +1427,7 @@ bootstrapping.
     method))
 
 (defun make-method-spec (gf-spec qualifiers unparsed-specializers)
-  `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
+  `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers))
 
 (defun initialize-method-function (initargs &optional return-function-p method)
   (let* ((mf (getf initargs :function))
@@ -1381,20 +1445,7 @@ bootstrapping.
 	(when mf
 	  (setq mf (set-fun-name mf method-spec)))
 	(when mff
-	  (let ((name `(,(or (get (car method-spec) 'fast-sym)
-			     (setf (get (car method-spec) 'fast-sym)
-				   ;; KLUDGE: If we're going to be
-				   ;; interning private symbols in our
-				   ;; a this way, it would be cleanest
-				   ;; to use a separate package
-				   ;; %PCL-PRIVATE or something, and
-				   ;; failing that, to use a special
-				   ;; symbol prefix denoting privateness.
-				   ;; -- WHN 19991201
-				   (intern (format nil "FAST-~A"
-						   (car method-spec))
-					   *pcl-package*)))
-			 ,@(cdr method-spec))))
+	  (let ((name `(fast-method ,@(cdr method-spec))))
 	    (set-fun-name mff name)
 	    (unless mf
 	      (set-mf-property :name name)))))
@@ -1469,15 +1520,15 @@ bootstrapping.
       (analyze-lambda-list lambda-list)
     (declare (ignore keyword-parameters))
     (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
-	   (old-ftype (if (sb-kernel:fun-type-p old) old nil))
-	   (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype)))
+	   (old-ftype (if (fun-type-p old) old nil))
+	   (old-restp (and old-ftype (fun-type-rest old-ftype)))
 	   (old-keys (and old-ftype
-			  (mapcar #'sb-kernel:key-info-name
-				  (sb-kernel:fun-type-keywords
+			  (mapcar #'key-info-name
+				  (fun-type-keywords
 				   old-ftype))))
-	   (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype)))
+	   (old-keysp (and old-ftype (fun-type-keyp old-ftype)))
 	   (old-allowp (and old-ftype
-			    (sb-kernel:fun-type-allowp old-ftype)))
+			    (fun-type-allowp old-ftype)))
 	   (keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
       `(function ,(append (make-list nrequired :initial-element t)
 			  (when (plusp noptional)
@@ -1495,8 +1546,6 @@ bootstrapping.
 		 *))))
 
 (defun defgeneric-declaration (spec lambda-list)
-  (when (consp spec)
-    (setq spec (get-setf-fun-name (cadr spec))))
   `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
 
 ;;;; early generic function support
@@ -1594,12 +1643,11 @@ bootstrapping.
 (defun arg-info-nkeys (arg-info)
   (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
 
-;;; Keep pages clean by not setting if the value is already the same.
-(defmacro esetf (pos val)
-  (let ((valsym (gensym "value")))
-    `(let ((,valsym ,val))
-       (unless (equal ,pos ,valsym)
-	 (setf ,pos ,valsym)))))
+(defun create-gf-lambda-list (lambda-list)
+  ;;; Create a gf lambda list from a method lambda list
+  (loop for x in lambda-list
+        collect (if (consp x) (list (car x)) x)
+        if (eq x '&key) do (loop-finish)))
 
 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
 			argument-precedence-order)
@@ -1628,20 +1676,21 @@ bootstrapping.
 	      (error "The lambda-list ~S is incompatible with ~
 		     existing methods of ~S."
 		     lambda-list gf))))
-	(when lambda-list-p
-	  (esetf (arg-info-lambda-list arg-info) lambda-list))
+        (setf (arg-info-lambda-list arg-info)
+	      (if lambda-list-p
+		  lambda-list
+                   (create-gf-lambda-list lambda-list)))
 	(when (or lambda-list-p argument-precedence-order
 		  (null (arg-info-precedence arg-info)))
-	  (esetf (arg-info-precedence arg-info)
-		 (compute-precedence lambda-list nreq
-				     argument-precedence-order)))
-	(esetf (arg-info-metatypes arg-info) (make-list nreq))
-	(esetf (arg-info-number-optional arg-info) nopt)
-	(esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
-	(esetf (arg-info-keys arg-info)
-	       (if lambda-list-p
-		   (if allow-other-keys-p t keywords)
-		   (arg-info-key/rest-p arg-info)))))
+	  (setf (arg-info-precedence arg-info)
+		(compute-precedence lambda-list nreq argument-precedence-order)))
+	(setf (arg-info-metatypes arg-info) (make-list nreq))
+	(setf (arg-info-number-optional arg-info) nopt)
+	(setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
+	(setf (arg-info-keys arg-info)
+	      (if lambda-list-p
+		  (if allow-other-keys-p t keywords)
+		  (arg-info-key/rest-p arg-info)))))
     (when new-method
       (check-method-arg-info gf arg-info new-method))
     (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
@@ -1654,11 +1703,10 @@ bootstrapping.
 			       (method-lambda-list method)))
     (flet ((lose (string &rest args)
 	     (error 'simple-program-error
-		    :format-control "attempt to add the method ~S ~
-                                     to the generic function ~S.~%~
-                                     But ~A"
-		    :format-arguments (list method gf
-					    (apply #'format nil string args))))
+		    :format-control "~@<attempt to add the method~2I~_~S~I~_~
+                                     to the generic function~2I~_~S;~I~_~
+                                     but ~?~:>"
+		    :format-arguments (list method gf string args)))
 	   (comparison-description (x y)
 	     (if (> x y) "more" "fewer")))
       (let ((gf-nreq (arg-info-number-required arg-info))
@@ -1675,13 +1723,13 @@ bootstrapping.
 	   (comparison-description nopt gf-nopt)))
 	(unless (eq (or keysp restp) gf-key/rest-p)
 	  (lose
-	   "the method and generic function differ in whether they accept~%~
+	   "the method and generic function differ in whether they accept~_~
 	    &REST or &KEY arguments."))
 	(when (consp gf-keywords)
 	  (unless (or (and restp (not keysp))
 		      allow-other-keys-p
 		      (every (lambda (k) (memq k keywords)) gf-keywords))
-	    (lose "the method does not accept each of the &KEY arguments~%~
+	    (lose "the method does not accept each of the &KEY arguments~2I~_~
 		   ~S."
 		  gf-keywords)))))))
 
@@ -1717,43 +1765,52 @@ bootstrapping.
 	  (setq type (cond ((null type) new-type)
 			   ((eq type new-type) type)
 			   (t nil)))))
-      (esetf (arg-info-metatypes arg-info) metatypes)
-      (esetf (gf-info-simple-accessor-type arg-info) type)))
+      (setf (arg-info-metatypes arg-info) metatypes)
+      (setf (gf-info-simple-accessor-type arg-info) type)))
   (when (or (not was-valid-p) first-p)
     (multiple-value-bind (c-a-m-emf std-p)
 	(if (early-gf-p gf)
 	    (values t t)
 	    (compute-applicable-methods-emf gf))
-      (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
-      (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p)
+      (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
+      (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)
       (unless (gf-info-c-a-m-emf-std-p arg-info)
-	(esetf (gf-info-simple-accessor-type arg-info) t))))
+	(setf (gf-info-simple-accessor-type arg-info) t))))
   (unless was-valid-p
     (let ((name (if (eq *boot-state* 'complete)
 		    (generic-function-name gf)
 		    (!early-gf-name gf))))
-      (esetf (gf-precompute-dfun-and-emf-p arg-info)
-	     (let* ((sym (if (atom name) name (cadr name)))
-		    (pkg-list (cons *pcl-package*
-				    (package-use-list *pcl-package*))))
-	       (and sym (symbolp sym)
-		    (not (null (memq (symbol-package sym) pkg-list)))
-		    (not (find #\space (symbol-name sym))))))))
-  (esetf (gf-info-fast-mf-p arg-info)
-	 (or (not (eq *boot-state* 'complete))
-	     (let* ((method-class (generic-function-method-class gf))
-		    (methods (compute-applicable-methods
-			      #'make-method-lambda
-			      (list gf (class-prototype method-class)
-				    '(lambda) nil))))
-	       (and methods (null (cdr methods))
-		    (let ((specls (method-specializers (car methods))))
-		      (and (classp (car specls))
-			   (eq 'standard-generic-function
-			       (class-name (car specls)))
-			   (classp (cadr specls))
-			   (eq 'standard-method
-			       (class-name (cadr specls)))))))))
+      (setf (gf-precompute-dfun-and-emf-p arg-info)
+	    (cond
+	      ((and (consp name)
+		    (member (car name)
+			    *internal-pcl-generalized-fun-name-symbols*))
+		nil)
+	      (t (let* ((symbol (fun-name-block-name name))
+			(package (symbol-package symbol)))
+		   (and (or (eq package *pcl-package*)
+			    (memq package (package-use-list *pcl-package*)))
+			;; FIXME: this test will eventually be
+			;; superseded by the *internal-pcl...* test,
+			;; above.  While we are in a process of
+			;; transition, however, it should probably
+			;; remain.
+			(not (find #\Space (symbol-name symbol))))))))))
+  (setf (gf-info-fast-mf-p arg-info)
+	(or (not (eq *boot-state* 'complete))
+	    (let* ((method-class (generic-function-method-class gf))
+		   (methods (compute-applicable-methods
+			     #'make-method-lambda
+			     (list gf (class-prototype method-class)
+				   '(lambda) nil))))
+	      (and methods (null (cdr methods))
+		   (let ((specls (method-specializers (car methods))))
+		     (and (classp (car specls))
+			  (eq 'standard-generic-function
+			      (class-name (car specls)))
+			  (classp (cadr specls))
+			  (eq 'standard-method
+			      (class-name (cadr specls)))))))))
   arg-info)
 
 ;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS.
@@ -1771,6 +1828,8 @@ bootstrapping.
 					    &allow-other-keys)
   (declare (ignore keys))
   (cond ((and existing (early-gf-p existing))
+	 (when lambda-list-p
+	   (set-arg-info existing :lambda-list lambda-list))
 	 existing)
 	((assoc spec *!generic-function-fixups* :test #'equal)
 	 (if existing
@@ -1789,14 +1848,14 @@ bootstrapping.
 (defun make-early-gf (spec &optional lambda-list lambda-list-p
 		      function argument-precedence-order)
   (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
-    (set-funcallable-instance-fun
+    (set-funcallable-instance-function
      fin
      (or function
 	 (if (eq spec 'print-object)
-	     #'(sb-kernel:instance-lambda (instance stream)
+	     #'(instance-lambda (instance stream)
 		 (print-unreadable-object (instance stream :identity t)
 		   (format stream "std-instance")))
-	     #'(sb-kernel:instance-lambda (&rest args)
+	     #'(instance-lambda (&rest args)
 		 (declare (ignore args))
 		 (error "The function of the funcallable-instance ~S~
 			 has not been set." fin)))))
@@ -1867,11 +1926,8 @@ bootstrapping.
 	      (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))))
+			     (method-lambda-list method))))
+                (create-gf-lambda-list ll))))
 	(arg-info-lambda-list arg-info))))
 
 (defmacro real-ensure-gf-internal (gf-class all-keys env)
@@ -1894,7 +1950,7 @@ bootstrapping.
     (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
       (unless (eq method-class '.shes-not-there.)
         (setf (getf ,all-keys :method-class)
-                (find-class method-class t ,env))))))
+	      (find-class method-class t ,env))))))
 
 (defun real-ensure-gf-using-class--generic-function
        (existing
@@ -2242,11 +2298,10 @@ bootstrapping.
 	      gf (method-generic-function method)
 	      temp (and gf (generic-function-name gf))
 	      name (if temp
-		       (intern-fun-name
-			 (make-method-spec temp
-					   (method-qualifiers method)
-					   (unparse-specializers
-					     (method-specializers method))))
+                       (make-method-spec temp
+                                         (method-qualifiers method)
+                                         (unparse-specializers
+                                          (method-specializers method)))
 		       (make-symbol (format nil "~S" method))))
 	(multiple-value-bind (gf-spec quals specls)
 	    (parse-defmethod spec)
@@ -2260,9 +2315,8 @@ bootstrapping.
 		 (and
 		   (setq method (get-method gf quals specls errorp))
 		   (setq name
-			 (intern-fun-name (make-method-spec gf-spec
-							    quals
-							    specls))))))))
+                         (make-method-spec
+                          gf-spec quals (unparse-specializers specls))))))))
     (values gf method name)))
 
 (defun extract-parameters (specialized-lambda-list)
@@ -2289,19 +2343,38 @@ bootstrapping.
     (declare (ignore ignore1 ignore2 ignore3))
     required-parameters))
 
-(defun parse-specialized-lambda-list (arglist &optional post-keyword)
-  ;;(declare (values parameters lambda-list specializers required-parameters))
+(define-condition specialized-lambda-list-error
+    (reference-condition simple-program-error)
+  ()
+  (:default-initargs :references (list '(:ansi-cl :section (3 4 3)))))
+
+(defun parse-specialized-lambda-list
+    (arglist
+     &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux))
+     &aux (specialized-lambda-list-keywords
+	   '(&optional &rest &key &allow-other-keys &aux)))
   (let ((arg (car arglist)))
     (cond ((null arglist) (values nil nil nil nil))
 	  ((eq arg '&aux)
-	   (values nil arglist nil))
+	   (values nil arglist nil nil))
 	  ((memq arg lambda-list-keywords)
-	   (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
-	     ;; Now, since we try to conform to ANSI, non-standard
-             ;; lambda-list-keywords should be treated as errors.
-	     (error 'simple-program-error
-                    :format-control "unrecognized lambda-list keyword ~S ~
-                     in arglist.~%"
+	   ;; non-standard lambda-list-keywords are errors.
+	   (unless (memq arg specialized-lambda-list-keywords)
+	     (error 'specialized-lambda-list-error
+		    :format-control "unknown specialized-lambda-list ~
+                                     keyword ~S~%"
+		    :format-arguments (list arg)))
+	   ;; no multiple &rest x &rest bla specifying
+	   (when (memq arg supplied-keywords)
+	     (error 'specialized-lambda-list-error
+		    :format-control "multiple occurrence of ~
+                                     specialized-lambda-list keyword ~S~%"
+		    :format-arguments (list arg)))
+	   ;; And no placing &key in front of &optional, either.
+	   (unless (memq arg allowed-keywords)
+	     (error 'specialized-lambda-list-error
+		    :format-control "misplaced specialized-lambda-list ~
+                                     keyword ~S~%"
 		    :format-arguments (list arg)))
 	   ;; When we are at a lambda-list keyword, the parameters
 	   ;; don't include the lambda-list keyword; the lambda-list
@@ -2309,22 +2382,34 @@ bootstrapping.
 	   ;; specializers are allowed to follow the lambda-list
 	   ;; keywords (at least for now).
 	   (multiple-value-bind (parameters lambda-list)
-	       (parse-specialized-lambda-list (cdr arglist) t)
-	     (when (eq arg '&rest)
-	       ;; check, if &rest is followed by a var ...
-	       (when (or (null lambda-list)
-			 (memq (car lambda-list) lambda-list-keywords))
-		 (error "Error in lambda-list:~%~
-                         After &REST, a DEFMETHOD lambda-list ~
-                         must be followed by at least one variable.")))
+	       (parse-specialized-lambda-list (cdr arglist)
+					      (cons arg supplied-keywords)
+					      (if (eq arg '&key)
+						  (cons '&allow-other-keys
+							(cdr (member arg allowed-keywords)))
+						(cdr (member arg allowed-keywords))))
+	     (when (and (eq arg '&rest)
+			(or (null lambda-list)
+			    (memq (car lambda-list)
+				  specialized-lambda-list-keywords)
+			    (not (or (null (cadr lambda-list))
+				     (memq (cadr lambda-list)
+					   specialized-lambda-list-keywords)))))
+	       (error 'specialized-lambda-list-error
+		      :format-control
+		      "in a specialized-lambda-list, excactly one ~
+                       variable must follow &REST.~%"
+		      :format-arguments nil))
 	     (values parameters
 		     (cons arg lambda-list)
 		     ()
 		     ())))
-	  (post-keyword
+	  (supplied-keywords
 	   ;; After a lambda-list keyword there can be no specializers.
 	   (multiple-value-bind (parameters lambda-list)
-	       (parse-specialized-lambda-list (cdr arglist) t)
+	       (parse-specialized-lambda-list (cdr arglist)
+					      supplied-keywords
+					      allowed-keywords)
 	     (values (cons (if (listp arg) (car arg) arg) parameters)
 		     (cons arg lambda-list)
 		     ()