X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=14e6984fc6056d90c80e90d2c94c467de96e674f;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=e05b50957ec145731bdea0f7f234b56cd33fcb42;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index e05b509..14e6984 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -78,19 +78,9 @@ bootstrapping.
 ;;; then things break.)
 (declaim (declaration class))
 
-;;; FIXME: SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY-HOOK shouldn't be a
-;;; separate function. Instead, we should define a simple placeholder
-;;; version of SB-PCL:CHECK-WRAPPER-VALIDITY where
-;;; SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY is defined now, then just
-;;; let the later real PCL DEFUN of SB-PCL:CHECK-WRAPPER-VALIDITY
-;;; overwrite it.
-(setf (symbol-function 'sb-kernel::pcl-check-wrapper-validity-hook)
-      #'check-wrapper-validity)
-
 (declaim (notinline make-a-method
 		    add-named-method
 		    ensure-generic-function-using-class
-
 		    add-method
 		    remove-method))
 
@@ -109,7 +99,7 @@ bootstrapping.
   (let ((name (car fns))
 	(early-name (cadr fns)))
     (setf (gdefinition name)
-            (set-function-name
+            (set-fun-name
              (lambda (&rest args)
 	       (apply (fdefinition early-name) args))
              name))))
@@ -131,12 +121,12 @@ bootstrapping.
       (standard-generic-function t t)
       real-get-method))
     (ensure-generic-function-using-class
-     ((generic-function function-name
+     ((generic-function fun-name
 			&key generic-function-class environment
 			&allow-other-keys)
       (generic-function t)
       real-ensure-gf-using-class--generic-function)
-     ((generic-function function-name
+     ((generic-function fun-name
 			&key generic-function-class environment
 			&allow-other-keys)
       (null t)
@@ -156,10 +146,13 @@ bootstrapping.
       (generic-function standard-method-combination t)
       standard-compute-effective-method))))
 
-(defmacro defgeneric (function-name lambda-list &body options)
-  (expand-defgeneric function-name lambda-list options))
-
-(defun expand-defgeneric (function-name lambda-list options)
+(defmacro defgeneric (fun-name lambda-list &body options)
+  (declare (type list lambda-list))
+  (unless (legal-fun-name-p fun-name)
+    (error 'simple-program-error
+	   :format-control "illegal generic function name ~S"
+	   :format-arguments (list fun-name)))
+  (check-gf-lambda-list lambda-list)
   (let ((initargs ())
 	(methods ()))
     (flet ((duplicate-option (name)
@@ -171,23 +164,58 @@ bootstrapping.
 		    (arglist (elt qab arglist-pos))
 		    (qualifiers (subseq qab 0 arglist-pos))
 		    (body (nthcdr (1+ arglist-pos) qab)))
-	       (when (not (equal (cadr (getf initargs :method-combination))
-				 qualifiers))
-		 (error "bad method specification in DEFGENERIC ~A~%~
-			 -- qualifier mismatch for lambda list ~A"
-			function-name arglist))
-	       `(defmethod ,function-name ,@qualifiers ,arglist ,@body))))
+	       `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body)
+                      (generic-function-initial-methods #',fun-name)))))
       (macrolet ((initarg (key) `(getf initargs ,key)))
 	(dolist (option options)
 	  (let ((car-option (car option)))
 	    (case car-option
 	      (declare
-	       (push (cdr option) (initarg :declarations)))
-	      ((:argument-precedence-order :method-combination)
-	       (if (initarg car-option)
-		   (duplicate-option car-option)
-		   (setf (initarg car-option)
-			 `',(cdr option))))
+	       (when (and
+		      (consp (cadr option))
+		      (member (first (cadr option))
+			      ;; FIXME: this list is slightly weird.
+			      ;; ANSI (on the DEFGENERIC page) in one
+			      ;; place allows only OPTIMIZE; in
+			      ;; another place gives this list of
+			      ;; disallowed declaration specifiers.
+			      ;; This seems to be the only place where
+			      ;; the FUNCTION declaration is
+			      ;; mentioned; TYPE seems to be missing.
+			      ;; Very strange.  -- CSR, 2002-10-21
+			      '(declaration ftype function
+				inline notinline special)))
+		 (error 'simple-program-error
+			:format-control "The declaration specifier ~S ~
+                                         is not allowed inside DEFGENERIC."
+			:format-arguments (list (cadr 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))
@@ -208,28 +236,76 @@ bootstrapping.
 		`',(initarg :declarations))))
       `(progn
 	 (eval-when (:compile-toplevel :load-toplevel :execute)
-	   (compile-or-load-defgeneric ',function-name))
-         (load-defgeneric ',function-name ',lambda-list ,@initargs)
-	 ,@(mapcar #'expand-method-definition methods)
-	 `,(function ,function-name)))))
-
-(defun compile-or-load-defgeneric (function-name)
-  (sb-kernel:proclaim-as-function-name function-name)
-  (sb-kernel:note-name-defined function-name :function)
-  (unless (eq (info :function :where-from function-name) :declared)
-    (setf (info :function :where-from function-name) :defined)
-    (setf (info :function :type function-name)
-	  (sb-kernel:specifier-type 'function))))
-
-(defun load-defgeneric (function-name lambda-list &rest initargs)
-  (when (fboundp function-name)
-    (sb-kernel::style-warn "redefining ~S in DEFGENERIC" function-name))
+	   (compile-or-load-defgeneric ',fun-name))
+         (load-defgeneric ',fun-name ',lambda-list ,@initargs)
+        ,@(mapcar #'expand-method-definition methods)
+	 #',fun-name))))
+
+(defun compile-or-load-defgeneric (fun-name)
+  (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)
+	  (specifier-type 'function))))
+
+(defun load-defgeneric (fun-name lambda-list &rest initargs)
+  (when (fboundp 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)
+              do (remove-method fun method))
+        (setf (generic-function-initial-methods fun) '()))))
   (apply #'ensure-generic-function
-	 function-name
-	 :lambda-list lambda-list
-	 :definition-source `((defgeneric ,function-name)
-			      ,*load-truename*)
-	 initargs))
+         fun-name
+         :lambda-list lambda-list
+         :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.
+(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))))
+    (multiple-value-bind (required optional restp rest keyp keys allowp
+                          auxp aux morep more-context more-count)
+	(parse-lambda-list lambda-list)
+      (declare (ignore required)) ; since they're no different in a gf ll
+      (declare (ignore restp rest)) ; since they're no different in a gf ll
+      (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way
+      (declare (ignore aux)) ; since we require AUXP=NIL
+      (declare (ignore more-context more-count)) ; safely ignored unless MOREP
+      ;; no defaults allowed for &OPTIONAL arguments
+      (dolist (i optional)
+	(ensure i (or (symbolp i)
+		      (and (consp i) (symbolp (car i)) (null (cdr i))))))
+      ;; no defaults allowed for &KEY arguments
+      (when keyp
+	(dolist (i keys)
+	  (ensure i (or (symbolp i)
+			(and (consp i)
+			     (or (symbolp (car i))
+				 (and (consp (car i))
+				      (symbolp (caar i))
+				      (symbolp (cadar i))
+				      (null (cddar i))))
+			     (null (cdr i)))))))
+      ;; no &AUX allowed
+      (when auxp
+	(error "&AUX is not allowed in a generic function lambda list: ~S"
+	       lambda-list))
+      ;; Oh, *puhlease*... not specifically as per section 3.4.2 of
+      ;; the ANSI spec, but the CMU CL &MORE extension does not
+      ;; belong here!
+      (aver (not morep)))))
 
 (defmacro defmethod (&rest args &environment env)
   (multiple-value-bind (name qualifiers lambda-list body)
@@ -280,11 +356,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
@@ -292,53 +363,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)))
@@ -348,18 +409,18 @@ bootstrapping.
 				 initargs-form &optional pv-table-symbol)
   (let (fn
 	fn-lambda)
-    (if (and (interned-symbol-p (function-name-block-name name))
+    (if (and (interned-symbol-p (fun-name-block-name name))
 	     (every #'interned-symbol-p qualifiers)
-	     (every #'(lambda (s)
-			(if (consp s)
-			    (and (eq (car s) 'eql)
-				 (constantp (cadr s))
-				 (let ((sv (eval (cadr s))))
-				   (or (interned-symbol-p sv)
-				       (integerp sv)
-				       (and (characterp sv)
-					    (standard-char-p sv)))))
-			    (interned-symbol-p s)))
+	     (every (lambda (s)
+		      (if (consp s)
+			  (and (eq (car s) 'eql)
+			       (constantp (cadr s))
+			       (let ((sv (eval (cadr s))))
+				 (or (interned-symbol-p sv)
+				     (integerp sv)
+				     (and (characterp sv)
+					  (standard-char-p sv)))))
+			  (interned-symbol-p s)))
 		    specializers)
 	     (consp initargs-form)
 	     (eq (car initargs-form) 'list*)
@@ -373,7 +434,7 @@ bootstrapping.
 				     `(,(car specl) ,(eval (cadr specl)))
 				   specl))
 			       specializers))
-	       (mname `(,(if (eq (cadr initargs-form) ':function)
+	       (mname `(,(if (eq (cadr initargs-form) :function)
 			     'method 'fast-method)
 			,name ,@qualifiers ,specls))
 	       (mname-sym (intern (let ((*print-pretty* nil)
@@ -396,13 +457,14 @@ bootstrapping.
 	       pv-table-symbol)))
 	(make-defmethod-form-internal
 	 name qualifiers
-	 `(list ,@(mapcar #'(lambda (specializer)
-			      (if (consp specializer)
-				  ``(,',(car specializer)
-				     ,,(cadr specializer))
-				  `',specializer))
+	 `(list ,@(mapcar (lambda (specializer)
+			    (if (consp specializer)
+				``(,',(car specializer)
+				   ,,(cadr specializer))
+				`',specializer))
 			  specializers))
-	 unspecialized-lambda-list method-class-name
+	 unspecialized-lambda-list
+	 method-class-name
 	 initargs-form
 	 pv-table-symbol))))
 
@@ -440,11 +502,35 @@ bootstrapping.
   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
       (parse-specialized-lambda-list lambda-list)
     (declare (ignore parameters))
-    (multiple-value-bind (documentation declarations real-body)
-	(extract-declarations body env)
+    (multiple-value-bind (real-body declarations documentation)
+	(parse-body body env)
       (values `(lambda ,unspecialized-lambda-list
 		 ,@(when documentation `(,documentation))
-		 (declare (%method-name ,(list name qualifiers specializers)))
+		 ;; (Old PCL code used a somewhat different style of
+		 ;; list for %METHOD-NAME values. Our names use
+		 ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the
+		 ;; method names look more like what you see in a
+		 ;; DEFMETHOD form.)
+		 ;;
+		 ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at
+		 ;; least the code to set up named BLOCKs around the
+		 ;; bodies of methods, depends on the function's base
+		 ;; name being the first element of the %METHOD-NAME
+		 ;; list. It would be good to remove this dependency,
+		 ;; perhaps by building the BLOCK here, or by using
+		 ;; another declaration (e.g. %BLOCK-NAME), so that
+		 ;; our method debug names are free to have any format,
+		 ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
+		 ;;
+		 ;; Further, as of sbcl-0.7.9.10, the code to
+		 ;; implement NO-NEXT-METHOD is coupled to the form of
+		 ;; this declaration; see the definition of
+		 ;; CALL-NO-NEXT-METHOD (and the passing of
+		 ;; METHOD-NAME-DECLARATION arguments around the
+		 ;; various CALL-NEXT-METHOD logic).
+		 (declare (%method-name (,name
+					 ,@qualifiers
+					 ,specializers)))
 		 (declare (%method-lambda-list ,@lambda-list))
 		 ,@declarations
 		 ,@real-body)
@@ -453,7 +539,8 @@ bootstrapping.
 (defun real-make-method-initargs-form (proto-gf proto-method
 				       method-lambda initargs env)
   (declare (ignore proto-gf proto-method))
-  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+  (unless (and (consp method-lambda)
+	       (eq (car method-lambda) 'lambda))
     (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~
 	    is not a lambda form."
 	   method-lambda))
@@ -521,16 +608,34 @@ bootstrapping.
 	 ;; weirdness when bootstrapping.. -- WHN 20000610
 	 '(ignorable))
 	(t
-	 ;; Otherwise, we can make Python very happy.
-	 `(type ,specializer ,parameter))))
+	 ;; Otherwise, we can usually make Python very happy.
+	 (let ((type (info :type :kind specializer)))
+	   (ecase type
+	     ((:primitive :defined :instance :forthcoming-defclass-type)
+	      `(type ,specializer ,parameter))
+	     ((nil)
+	      (let ((class (find-class specializer nil)))
+		(if class
+		    `(type ,(class-name class) ,parameter)
+		    (progn
+		      ;; 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))))))))))
 
 (defun make-method-lambda-internal (method-lambda &optional env)
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
     (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
 	    is not a lambda form."
 	   method-lambda))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations (cddr method-lambda) env)
+  (multiple-value-bind (real-body declarations documentation)
+      (parse-body (cddr method-lambda) env)
     (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)))
@@ -549,7 +654,7 @@ bootstrapping.
 		  ;; These declarations seem to be used by PCL to pass
 		  ;; information to itself; when I tried to delete 'em
 		  ;; ca. 0.6.10 it didn't work. I'm not sure how
-		  ;; they work, but note the (VARIABLE-DECLARATION '%CLASS ..)
+		  ;; they work, but note the (VAR-DECLARATION '%CLASS ..)
 		  ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
 		  ,@(remove nil
 			    (mapcar (lambda (a s) (and (symbolp s)
@@ -593,8 +698,7 @@ bootstrapping.
 		   (declare (ignorable ,@required-parameters))
 		   ,class-declarations
 		   ,@declarations
-		   (block ,(function-name-block-name
-			    generic-function-name)
+		   (block ,(fun-name-block-name generic-function-name)
 		     ,@real-body)))
 	       (constant-value-p (and (null (cdr real-body))
 				      (constantp (car real-body))))
@@ -618,10 +722,11 @@ bootstrapping.
 				  env
 				  slots
 				  calls)
-	    (multiple-value-bind
-		(ignore walked-declarations walked-lambda-body)
-		(extract-declarations (cddr walked-lambda))
-	      (declare (ignore ignore))
+	    (multiple-value-bind (walked-lambda-body
+				  walked-declarations
+				  walked-documentation)
+		(parse-body (cddr walked-lambda) env)
+	      (declare (ignore walked-documentation))
 	      (when (or next-method-p-p call-next-method-p)
 		(setq plist (list* :needs-next-methods-p t plist)))
 	      (when (some #'cdr slots)
@@ -652,6 +757,14 @@ bootstrapping.
 					:call-next-method-p
 					,call-next-method-p
 					:next-method-p-p ,next-method-p-p
+			                ;; we need to pass this along
+			                ;; so that NO-NEXT-METHOD can
+			                ;; be given a suitable METHOD
+			                ;; argument; we need the
+			                ;; QUALIFIERS and SPECIALIZERS
+			                ;; inside the declaration to
+			                ;; give to FIND-METHOD.
+			                :method-name-declaration ,name-decl
 					:closurep ,closurep
 					:applyp ,applyp)
 			  ,@walked-declarations
@@ -683,10 +796,10 @@ bootstrapping.
 					  rest-arg
 					  &rest lmf-options)
 					 &body body)
- `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
-    (bind-lexical-method-functions (,@lmf-options)
-      (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
-	,@body))))
+  `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
+     (bind-lexical-method-functions (,@lmf-options)
+       (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
+	 ,@body))))
 
 (defmacro bind-simple-lexical-method-macros ((method-args next-methods)
 					     &body body)
@@ -695,18 +808,32 @@ bootstrapping.
 		       (,',next-methods (cdr ,',next-methods)))
 		   .next-method. ,',next-methods
 		   ,@body))
-	      (call-next-method-body (cnm-args)
+	      (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)
-		     (error "no next method")))
+		     (apply #'call-no-next-method ',method-name-declaration
+		            (or ,cnm-args ,',method-args))))
 	      (next-method-p-body ()
 		`(not (null .next-method.))))
      ,@body))
 
+(defun call-no-next-method (method-name-declaration &rest args)
+  (destructuring-bind (name) method-name-declaration
+    (destructuring-bind (name &rest qualifiers-and-specializers) name
+      ;; KLUDGE: inefficient traversal, but hey.  This should only
+      ;; happen on the slow error path anyway.
+      (let* ((qualifiers (butlast qualifiers-and-specializers))
+	     (specializers (car (last qualifiers-and-specializers)))
+	     (method (find-method (gdefinition name) qualifiers specializers)))
+	(apply #'no-next-method
+	       (method-generic-function method)
+	       method
+	       args)))))
+
 (defstruct (method-call (:copier nil))
   (function #'identity :type function)
   call-method-args)
@@ -751,11 +878,8 @@ bootstrapping.
 #-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defvar *allow-emf-call-tracing-p* nil)
-(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t)
-
-) ; EVAL-WHEN
+  (defvar *allow-emf-call-tracing-p* nil)
+  (defvar *enable-emf-call-tracing-p* #-sb-show nil #+sb-show t))
 
 ;;;; effective method functions
 
@@ -805,11 +929,25 @@ bootstrapping.
 						&rest required-args+rest-arg)
   (unless (constantp restp)
     (error "The RESTP argument is not constant."))
+  ;; FIXME: The RESTP handling here is confusing and maybe slightly
+  ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if
+  ;;   (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
+  ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
   (setq restp (eval restp))
   `(progn
      (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
      (cond ((typep ,emf 'fast-method-call)
-	     (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+	    (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+	   ;; "What," you may wonder, "do these next two clauses do?"
+	   ;; In that case, you are not a PCL implementor, for they
+	   ;; considered this to be self-documenting.:-| Or CSR, for
+	   ;; that matter, since he can also figure it out by looking
+	   ;; at it without breaking stride. For the rest of us,
+	   ;; though: From what the code is doing with .SLOTS. and
+	   ;; whatnot, evidently it's implementing SLOT-VALUEish and
+	   ;; GET-SLOT-VALUEish things. Then we can reason backwards
+	   ;; and conclude that setting EMF to a FIXNUM is an
+	   ;; optimized way to represent these slot access operations.
 	   ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
 	       `(((typep ,emf 'fixnum)
 		  (let* ((.slots. (get-slots-or-nil
@@ -823,19 +961,13 @@ bootstrapping.
 	       `(((typep ,emf 'fixnum)
 		  (let ((.new-value. ,(car required-args+rest-arg))
 			(.slots. (get-slots-or-nil
-				  ,(car required-args+rest-arg))))
-                    (when .slots.
-                         (setf (clos-slots-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 (clos-slots-ref
-				   .slots. (fast-instance-boundp-index ,emf))
-				  +slot-unbound+)))))))
-	   ||#
+				  ,(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
+	   ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
+	   ;; there was no explanation and presumably the code is 10+
+	   ;; years stale, I simply deleted it. -- WHN)
 	   (t
 	    (etypecase ,emf
 	      (method-call
@@ -902,83 +1034,96 @@ bootstrapping.
 		  +slot-unbound+)))))
     (function
      (apply emf args))))
-
-;; KLUDGE: A comment from the original PCL said "This can be improved alot."
-(defun gf-make-function-from-emf (gf emf)
-  (etypecase emf
-    (fast-method-call (let* ((arg-info (gf-arg-info gf))
-			     (nreq (arg-info-number-required arg-info))
-			     (restp (arg-info-applyp arg-info)))
-			#'(lambda (&rest args)
-			    (trace-emf-call emf t args)
-			    (apply (fast-method-call-function emf)
-				   (fast-method-call-pv-cell emf)
-				   (fast-method-call-next-method-call emf)
-				   (if restp
-				       (let* ((rest-args (nthcdr nreq args))
-					      (req-args (ldiff args
-							       rest-args)))
-					 (nconc req-args rest-args))
-				       args)))))
-    (method-call #'(lambda (&rest args)
-		     (trace-emf-call emf t args)
-		     (apply (method-call-function emf)
-			    args
-			    (method-call-call-method-args emf))))
-    (function emf)))
 
 (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
 					   &body body)
-  `(macrolet ((call-next-method-bind (&body body)
-		`(let () ,@body))
-	      (call-next-method-body (cnm-args)
-		`(if ,',next-method-call
-		     ,(if (and (null ',rest-arg)
-			       (consp cnm-args)
-			       (eq (car cnm-args) 'list))
-			  `(invoke-effective-method-function
-			    ,',next-method-call nil
-			    ,@(cdr cnm-args))
-			  (let ((call `(invoke-effective-method-function
-					,',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)))
-		     (error "no next method")))
+  `(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)
+		   ,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))))
+		 ,(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))))
-     ,@body))
+               `(not (null ,',next-method-call))))
+    ,@body))
 
 (defmacro bind-lexical-method-functions
-    ((&key call-next-method-p next-method-p-p closurep applyp)
+    ((&key call-next-method-p next-method-p-p
+	   closurep applyp method-name-declaration)
      &body body)
   (cond ((and (null call-next-method-p) (null next-method-p-p)
 	      (null closurep)
 	      (null applyp))
 	 `(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 ,(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
-			  '((call-next-method (&rest cnm-args)
-			      (call-next-method-body cnm-args))))
+			  `((call-next-method (&rest cnm-args)
+			     (call-next-method-body
+			      ,method-name-declaration
+			      cnm-args))))
 		   ,@(and next-method-p-p
 			  '((next-method-p ()
 			      (next-method-p-body)))))
@@ -1018,8 +1163,9 @@ bootstrapping.
 						      ,(cadr var)))))))
 		   (rest `((,var ,args-tail)))
 		   (key (cond ((not (consp var))
-			       `((,var (get-key-arg ,(keywordicate var)
-						    ,args-tail))))
+			       `((,var (car
+					(get-key-arg-tail ,(keywordicate var)
+					                  ,args-tail)))))
 			      ((null (cddr var))
 			       (multiple-value-bind (keyword variable)
 				   (if (consp (car var))
@@ -1027,8 +1173,9 @@ bootstrapping.
 					       (cadar var))
 				       (values (keywordicate (car var))
 					       (car var)))
-				 `((,key (get-key-arg1 ',keyword ,args-tail))
-				   (,variable (if (consp ,key)
+				 `((,key (get-key-arg-tail ',keyword
+					                   ,args-tail))
+				   (,variable (if ,key
 						  (car ,key)
 						  ,(cadr var))))))
 			      (t
@@ -1038,27 +1185,33 @@ bootstrapping.
 					       (cadar var))
 				       (values (keywordicate (car var))
 					       (car var)))
-				 `((,key (get-key-arg1 ',keyword ,args-tail))
+				 `((,key (get-key-arg-tail ',keyword
+					                   ,args-tail))
 				   (,(caddr var) ,key)
-				   (,variable (if (consp ,key)
+				   (,variable (if ,key
 						  (car ,key)
 						  ,(cadr var))))))))
 		   (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 (keyword list)
-  (loop (when (atom list) (return nil))
-	(when (eq (car list) keyword) (return (cadr list)))
-	(setq list (cddr list))))
-
-(defun get-key-arg1 (keyword list)
-  (loop (when (atom list) (return nil))
-	(when (eq (car list) keyword) (return (cdr list)))
-	(setq list (cddr list))))
+(defun get-key-arg-tail (keyword list)
+  (loop for (key . tail) on list by #'cddr
+	when (null tail) do
+	  ;; FIXME: Do we want to export this symbol? Or maybe use an
+	  ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form?
+	  (sb-c::%odd-key-args-error)
+	when (eq key keyword)
+	  return tail))
 
 (defun walk-method-lambda (method-lambda required-parameters env slots calls)
   (let ((call-next-method-p nil)   ; flag indicating that CALL-NEXT-METHOD
@@ -1068,7 +1221,7 @@ bootstrapping.
 	(next-method-p-p nil))     ; flag indicating that NEXT-METHOD-P
 				   ; should be in the method definition
     (flet ((walk-function (form context env)
-	     (cond ((not (eq context ':eval)) form)
+	     (cond ((not (eq context :eval)) form)
 		   ;; FIXME: Jumping to a conclusion from the way it's used
 		   ;; above, perhaps CONTEXT should be called SITUATION
 		   ;; (after the term used in the ANSI specification of
@@ -1094,8 +1247,9 @@ bootstrapping.
 		   ((and (memq (car form)
                                '(slot-value set-slot-value slot-boundp))
 			 (constantp (caddr form)))
-                     (let ((parameter
-                            (can-optimize-access form required-parameters env)))
+                     (let ((parameter (can-optimize-access form
+							   required-parameters
+							   env)))
                       (let ((fun (ecase (car form)
                                    (slot-value #'optimize-slot-value)
                                    (set-slot-value #'optimize-set-slot-value)
@@ -1110,13 +1264,6 @@ 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)))
@@ -1126,7 +1273,7 @@ bootstrapping.
 		next-method-p-p)))))
 
 (defun generic-function-name-p (name)
-  (and (legal-function-name-p name)
+  (and (legal-fun-name-p name)
        (gboundp name)
        (if (eq *boot-state* 'complete)
 	   (standard-generic-function-p (gdefinition name))
@@ -1187,10 +1334,9 @@ bootstrapping.
 (defun load-defmethod
     (class name quals specls ll initargs &optional pv-table-symbol)
   (setq initargs (copy-tree initargs))
-  (let ((method-spec (or (getf initargs ':method-spec)
+  (let ((method-spec (or (getf initargs :method-spec)
 			 (make-method-spec name quals specls))))
-    (setf (getf initargs ':method-spec) method-spec)
-    (record-definition 'method method-spec)
+    (setf (getf initargs :method-spec) method-spec)
     (load-defmethod-internal class name quals specls
 			     ll initargs pv-table-symbol)))
 
@@ -1198,7 +1344,7 @@ bootstrapping.
     (method-class gf-spec qualifiers specializers lambda-list
 		  initargs pv-table-symbol)
   (when pv-table-symbol
-    (setf (getf (getf initargs ':plist) :pv-table-symbol)
+    (setf (getf (getf initargs :plist) :pv-table-symbol)
 	  pv-table-symbol))
   (when (and (eq *boot-state* 'complete)
 	     (fboundp gf-spec))
@@ -1209,14 +1355,14 @@ bootstrapping.
                                      (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
 						,@qualifiers
 					      ,specializers)
-					    ,*load-truename*)
+					    ,*load-pathname*)
 		       initargs)))
     (unless (or (eq method-class 'standard-method)
 		(eq (find-class method-class nil) (class-of method)))
@@ -1235,12 +1381,12 @@ bootstrapping.
   `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
 
 (defun initialize-method-function (initargs &optional return-function-p method)
-  (let* ((mf (getf initargs ':function))
-	 (method-spec (getf initargs ':method-spec))
-	 (plist (getf initargs ':plist))
-	 (pv-table-symbol (getf plist ':pv-table-symbol))
+  (let* ((mf (getf initargs :function))
+	 (method-spec (getf initargs :method-spec))
+	 (plist (getf initargs :plist))
+	 (pv-table-symbol (getf plist :pv-table-symbol))
 	 (pv-table nil)
-	 (mff (getf initargs ':fast-function)))
+	 (mff (getf initargs :fast-function)))
     (flet ((set-mf-property (p v)
 	     (when mf
 	       (setf (method-function-get mf p) v))
@@ -1248,7 +1394,7 @@ bootstrapping.
 	       (setf (method-function-get mff p) v))))
       (when method-spec
 	(when mf
-	  (setq mf (set-function-name mf method-spec)))
+	  (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)
@@ -1264,7 +1410,7 @@ bootstrapping.
 						   (car method-spec))
 					   *pcl-package*)))
 			 ,@(cdr method-spec))))
-	    (set-function-name mff name)
+	    (set-fun-name mff name)
 	    (unless mf
 	      (set-mf-property :name name)))))
       (when plist
@@ -1284,7 +1430,7 @@ bootstrapping.
 
 (defun analyze-lambda-list (lambda-list)
   (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
-	 (parse-key-argument (arg)
+	 (parse-key-arg (arg)
 	   (if (listp arg)
 	       (if (listp (car arg))
 		   (caar arg)
@@ -1294,6 +1440,7 @@ bootstrapping.
 	  (noptional 0)
 	  (keysp nil)
 	  (restp nil)
+          (nrest 0)
 	  (allow-other-keys-p nil)
 	  (keywords ())
 	  (keyword-parameters ())
@@ -1314,9 +1461,13 @@ bootstrapping.
 	    (ecase state
 	      (required  (incf nrequired))
 	      (optional  (incf noptional))
-	      (key       (push (parse-key-argument x) keywords)
+	      (key       (push (parse-key-arg x) keywords)
 			 (push x keyword-parameters))
-	      (rest      ()))))
+	      (rest      (incf nrest)))))
+      (when (and restp (zerop nrest))
+        (error "Error in lambda-list:~%~
+                After &REST, a DEFGENERIC lambda-list ~
+                must be followed by at least one variable."))
       (values nrequired noptional keysp restp allow-other-keys-p
 	      (reverse keywords)
 	      (reverse keyword-parameters)))))
@@ -1333,15 +1484,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:function-type-p old) old nil))
-	   (old-restp (and old-ftype (sb-kernel:function-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:function-type-keywords
+			  (mapcar #'key-info-name
+				  (fun-type-keywords
 				   old-ftype))))
-	   (old-keysp (and old-ftype (sb-kernel:function-type-keyp old-ftype)))
+	   (old-keysp (and old-ftype (fun-type-keyp old-ftype)))
 	   (old-allowp (and old-ftype
-			    (sb-kernel:function-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)
@@ -1351,8 +1502,8 @@ bootstrapping.
 			    '(&rest t))
 			  (when (or keysp old-keysp)
 			    (append '(&key)
-				    (mapcar #'(lambda (key)
-						`(,key t))
+				    (mapcar (lambda (key)
+					      `(,key t))
 					    keywords)
 				    (when (or allow-other-keys-p old-allowp)
 				      '(&allow-other-keys)))))
@@ -1360,44 +1511,44 @@ bootstrapping.
 
 (defun defgeneric-declaration (spec lambda-list)
   (when (consp spec)
-    (setq spec (get-setf-function-name (cadr spec))))
+    (setq spec (get-setf-fun-name (cadr spec))))
   `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
 
 ;;;; early generic function support
 
 (defvar *!early-generic-functions* ())
 
-(defun ensure-generic-function (function-name
+(defun ensure-generic-function (fun-name
 				&rest all-keys
 				&key environment
 				&allow-other-keys)
   (declare (ignore environment))
-  (let ((existing (and (gboundp function-name)
-		       (gdefinition function-name))))
+  (let ((existing (and (gboundp fun-name)
+		       (gdefinition fun-name))))
     (if (and existing
 	     (eq *boot-state* 'complete)
 	     (null (generic-function-p existing)))
-	(generic-clobbers-function function-name)
+	(generic-clobbers-function fun-name)
 	(apply #'ensure-generic-function-using-class
-	       existing function-name all-keys))))
+	       existing fun-name all-keys))))
 
-(defun generic-clobbers-function (function-name)
+(defun generic-clobbers-function (fun-name)
   (error 'simple-program-error
 	 :format-control "~S already names an ordinary function or a macro."
-	 :format-arguments (list function-name)))
+	 :format-arguments (list fun-name)))
 
 (defvar *sgf-wrapper*
   (boot-make-wrapper (early-class-size 'standard-generic-function)
 		     'standard-generic-function))
 
 (defvar *sgf-slots-init*
-  (mapcar #'(lambda (canonical-slot)
-	      (if (memq (getf canonical-slot :name) '(arg-info source))
-		  +slot-unbound+
-		  (let ((initfunction (getf canonical-slot :initfunction)))
-		    (if initfunction
-			(funcall initfunction)
-			+slot-unbound+))))
+  (mapcar (lambda (canonical-slot)
+	    (if (memq (getf canonical-slot :name) '(arg-info source))
+		+slot-unbound+
+		(let ((initfunction (getf canonical-slot :initfunction)))
+		  (if initfunction
+		      (funcall initfunction)
+		      +slot-unbound+))))
 	  (early-collect-inheritance 'standard-generic-function)))
 
 (defvar *sgf-method-class-index*
@@ -1456,11 +1607,11 @@ bootstrapping.
   (length (arg-info-metatypes arg-info)))
 
 (defun arg-info-nkeys (arg-info)
-  (count-if #'(lambda (x) (neq x t)) (arg-info-metatypes 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")))
+  (with-unique-names (valsym)
     `(let ((,valsym ,val))
        (unless (equal ,pos ,valsym)
 	 (setf ,pos ,valsym)))))
@@ -1479,7 +1630,7 @@ bootstrapping.
       (setq lambda-list (gf-lambda-list gf)))
     (when (or lambda-list-p
 	      (and first-p
-		   (eq (arg-info-lambda-list arg-info) ':no-lambda-list)))
+		   (eq (arg-info-lambda-list arg-info) :no-lambda-list)))
       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
 	  (analyze-lambda-list lambda-list)
 	(when (and methods (not first-p))
@@ -1517,13 +1668,12 @@ bootstrapping.
 			       (early-method-lambda-list method)
 			       (method-lambda-list method)))
     (flet ((lose (string &rest args)
-	     (error
-	      "attempt to add the method ~S to the generic function ~S.~%~
-	       But ~A"
-	      method
-	      gf
-	      (apply #'format nil string args)))
-	   (compare (x y)
+	     (error 'simple-program-error
+		    :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))
 	    (gf-nopt (arg-info-number-optional arg-info))
@@ -1532,20 +1682,20 @@ bootstrapping.
 	(unless (= nreq gf-nreq)
 	  (lose
 	   "the method has ~A required arguments than the generic function."
-	   (compare nreq gf-nreq)))
+	   (comparison-description nreq gf-nreq)))
 	(unless (= nopt gf-nopt)
 	  (lose
-	   "the method has ~S optional arguments than the generic function."
-	   (compare nopt gf-nopt)))
+	   "the method has ~A optional arguments than the generic function."
+	   (comparison-description nopt gf-nopt)))
 	(unless (eq (or keysp restp) gf-key/rest-p)
-	  (error
-	   "The method and generic function differ in whether they accept~%~
+	  (lose
+	   "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~%~
+		      (every (lambda (k) (memq k keywords)) gf-keywords))
+	    (lose "the method does not accept each of the &KEY arguments~2I~_~
 		   ~S."
 		  gf-keywords)))))))
 
@@ -1597,12 +1747,21 @@ bootstrapping.
 		    (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))))))))
+	     (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))))))))))
   (esetf (gf-info-fast-mf-p arg-info)
 	 (or (not (eq *boot-state* 'complete))
 	     (let* ((method-class (generic-function-method-class gf))
@@ -1631,13 +1790,15 @@ bootstrapping.
 (defun ensure-generic-function-using-class (existing spec &rest keys
 					    &key (lambda-list nil
 							      lambda-list-p)
+					    argument-precedence-order
 					    &allow-other-keys)
   (declare (ignore keys))
   (cond ((and existing (early-gf-p existing))
 	 existing)
 	((assoc spec *!generic-function-fixups* :test #'equal)
 	 (if existing
-	     (make-early-gf spec lambda-list lambda-list-p existing)
+	     (make-early-gf spec lambda-list lambda-list-p existing
+			    argument-precedence-order)
 	     (error "The function ~S is not already defined." spec)))
 	(existing
 	 (error "~S should be on the list ~S."
@@ -1645,18 +1806,20 @@ bootstrapping.
 		'*!generic-function-fixups*))
 	(t
 	 (pushnew spec *!early-generic-functions* :test #'equal)
-	 (make-early-gf spec lambda-list lambda-list-p))))
+	 (make-early-gf spec lambda-list lambda-list-p nil
+			argument-precedence-order))))
 
-(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
+(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-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)))))
@@ -1665,13 +1828,17 @@ bootstrapping.
     (!bootstrap-set-slot 'standard-generic-function
 			 fin
 			 'source
-			 *load-truename*)
-    (set-function-name fin spec)
+			 *load-pathname*)
+    (set-fun-name fin spec)
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)
       (when lambda-list-p
 	(proclaim (defgeneric-declaration spec lambda-list))
-	(set-arg-info fin :lambda-list lambda-list)))
+	(if argument-precedence-order
+	    (set-arg-info fin
+			  :lambda-list lambda-list
+			  :argument-precedence-order argument-precedence-order)
+	    (set-arg-info fin :lambda-list lambda-list))))
     fin))
 
 (defun set-dfun (gf &optional dfun cache info)
@@ -1712,7 +1879,7 @@ bootstrapping.
   (let ((arg-info (if (eq *boot-state* 'complete)
 		      (gf-arg-info gf)
 		      (early-gf-arg-info gf))))
-    (if (eq ':no-lambda-list (arg-info-lambda-list arg-info))
+    (if (eq :no-lambda-list (arg-info-lambda-list arg-info))
 	(let ((methods (if (eq *boot-state* 'complete)
 			   (generic-function-methods gf)
 			   (early-gf-methods gf))))
@@ -1746,11 +1913,15 @@ bootstrapping.
 	 (setf (getf ,all-keys :method-combination)
 	       (find-method-combination (class-prototype ,gf-class)
 					(car combin)
-					(cdr combin)))))))
+					(cdr combin)))))
+    (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))))))
 
 (defun real-ensure-gf-using-class--generic-function
        (existing
-	function-name
+	fun-name
 	&rest all-keys
 	&key environment (lambda-list nil lambda-list-p)
 	     (generic-function-class 'standard-generic-function gf-class-p)
@@ -1762,11 +1933,11 @@ bootstrapping.
   (prog1
       (apply #'reinitialize-instance existing all-keys)
     (when lambda-list-p
-      (proclaim (defgeneric-declaration function-name lambda-list)))))
+      (proclaim (defgeneric-declaration fun-name lambda-list)))))
 
 (defun real-ensure-gf-using-class--null
        (existing
-	function-name
+	fun-name
 	&rest all-keys
 	&key environment (lambda-list nil lambda-list-p)
 	     (generic-function-class 'standard-generic-function)
@@ -1774,13 +1945,13 @@ bootstrapping.
   (declare (ignore existing))
   (real-ensure-gf-internal generic-function-class all-keys environment)
   (prog1
-      (setf (gdefinition function-name)
+      (setf (gdefinition fun-name)
 	    (apply #'make-instance generic-function-class
-		   :name function-name all-keys))
+		   :name fun-name all-keys))
     (when lambda-list-p
-      (proclaim (defgeneric-declaration function-name lambda-list)))))
+      (proclaim (defgeneric-declaration fun-name lambda-list)))))
 
-(defun get-generic-function-info (gf)
+(defun get-generic-fun-info (gf)
   ;; values   nreq applyp metatypes nkeys arg-info
   (multiple-value-bind (applyp metatypes arg-info)
       (let* ((arg-info (if (early-gf-p gf)
@@ -1791,7 +1962,7 @@ bootstrapping.
 		metatypes
 		arg-info))
     (values (length metatypes) applyp metatypes
-	    (count-if #'(lambda (x) (neq x t)) metatypes)
+	    (count-if (lambda (x) (neq x t)) metatypes)
 	    arg-info)))
 
 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
@@ -1807,17 +1978,17 @@ bootstrapping.
     ;; Note that the use of not symbolp in this call to every should be
     ;; read as 'classp' we can't use classp itself because it doesn't
     ;; exist yet.
-    (if (every #'(lambda (s) (not (symbolp s))) specializers)
+    (if (every (lambda (s) (not (symbolp s))) specializers)
 	(setq parsed specializers
-	      unparsed (mapcar #'(lambda (s)
-				   (if (eq s t) t (class-name s)))
+	      unparsed (mapcar (lambda (s)
+				 (if (eq s t) t (class-name s)))
 			       specializers))
 	(setq unparsed specializers
 	      parsed ()))
     (list :early-method		  ;This is an early method dammit!
 
-	  (getf initargs ':function)
-	  (getf initargs ':fast-function)
+	  (getf initargs :function)
+	  (getf initargs :fast-function)
 
 	  parsed		  ;The parsed specializers. This is used
 				  ;by early-method-specializers to cache
@@ -1994,13 +2165,13 @@ bootstrapping.
     (dolist (early-gf-spec *!early-generic-functions*)
       (/show early-gf-spec)
       (let* ((gf (gdefinition early-gf-spec))
-	     (methods (mapcar #'(lambda (early-method)
-				  (let ((args (copy-list (fifth
-							  early-method))))
-				    (setf (fourth args)
-					  (early-method-specializers
-					   early-method t))
-				    (apply #'real-make-a-method args)))
+	     (methods (mapcar (lambda (early-method)
+				(let ((args (copy-list (fifth
+							early-method))))
+				  (setf (fourth args)
+					(early-method-specializers
+					 early-method t))
+				  (apply #'real-make-a-method args)))
 			      (early-gf-methods gf))))
 	(setf (generic-function-method-class gf) *the-class-standard-method*)
 	(setf (generic-function-method-combination gf)
@@ -2015,27 +2186,27 @@ bootstrapping.
       (/show fixup)
       (let* ((fspec (car fixup))
 	     (gf (gdefinition fspec))
-	     (methods (mapcar #'(lambda (method)
-				  (let* ((lambda-list (first method))
-					 (specializers (second method))
-					 (method-fn-name (third method))
-					 (fn-name (or method-fn-name fspec))
-					 (fn (fdefinition fn-name))
-					 (initargs
-					  (list :function
-						(set-function-name
-						 #'(lambda (args next-methods)
-						     (declare (ignore
-							       next-methods))
-						     (apply fn args))
-						 `(call ,fn-name)))))
-				    (declare (type function fn))
-				    (make-a-method 'standard-method
-						   ()
-						   lambda-list
-						   specializers
-						   initargs
-						   nil)))
+	     (methods (mapcar (lambda (method)
+				(let* ((lambda-list (first method))
+				       (specializers (second method))
+				       (method-fn-name (third method))
+				       (fn-name (or method-fn-name fspec))
+				       (fn (fdefinition fn-name))
+				       (initargs
+					(list :function
+					      (set-fun-name
+					       (lambda (args next-methods)
+						 (declare (ignore
+							   next-methods))
+						 (apply fn args))
+					       `(call ,fn-name)))))
+				  (declare (type function fn))
+				  (make-a-method 'standard-method
+						 ()
+						 lambda-list
+						 specializers
+						 initargs
+						 nil)))
 			      (cdr fixup))))
 	(setf (generic-function-method-class gf) *the-class-standard-method*)
 	(setf (generic-function-method-combination gf)
@@ -2094,7 +2265,7 @@ bootstrapping.
 	      gf (method-generic-function method)
 	      temp (and gf (generic-function-name gf))
 	      name (if temp
-		       (intern-function-name
+		       (intern-fun-name
 			 (make-method-spec temp
 					   (method-qualifiers method)
 					   (unparse-specializers
@@ -2112,9 +2283,9 @@ bootstrapping.
 		 (and
 		   (setq method (get-method gf quals specls errorp))
 		   (setq name
-			 (intern-function-name (make-method-spec gf-spec
-								 quals
-								 specls))))))))
+			 (intern-fun-name (make-method-spec gf-spec
+							    quals
+							    specls))))))))
     (values gf method name)))
 
 (defun extract-parameters (specialized-lambda-list)
@@ -2149,17 +2320,12 @@ bootstrapping.
 	   (values nil arglist nil))
 	  ((memq arg lambda-list-keywords)
 	   (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
-	     ;; Warn about non-standard lambda-list-keywords, but then
-	     ;; go on to treat them like a standard lambda-list-keyword
-	     ;; what with the warning its probably ok.
-	     ;;
-	     ;; FIXME: This shouldn't happen now that this is maintained
-	     ;; as part of SBCL, should it? Perhaps this is now
-	     ;; "internal error: unrecognized lambda-list keyword ~S"?
-	     (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
-		    Assuming that the symbols following it are parameters,~%~
-		    and not allowing any parameter specializers to follow it."
-		   arg))
+	     ;; 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.~%"
+		    :format-arguments (list arg)))
 	   ;; When we are at a lambda-list keyword, the parameters
 	   ;; don't include the lambda-list keyword; the lambda-list
 	   ;; does include the lambda-list keyword; and no
@@ -2167,6 +2333,13 @@ bootstrapping.
 	   ;; 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.")))
 	     (values parameters
 		     (cons arg lambda-list)
 		     ()
@@ -2204,17 +2377,17 @@ bootstrapping.
 	   (and (symbolp instance)
 		`((declare (%variable-rebinding ,in ,instance)))))
        ,in
-       (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
-				     (let ((variable-name
-					    (if (symbolp slot-entry)
-						slot-entry
-						(car slot-entry)))
-					   (slot-name
-					    (if (symbolp slot-entry)
-						slot-entry
-						(cadr slot-entry))))
-				       `(,variable-name
-					  (slot-value ,in ',slot-name))))
+       (symbol-macrolet ,(mapcar (lambda (slot-entry)
+				   (let ((var-name
+					  (if (symbolp slot-entry)
+					      slot-entry
+					      (car slot-entry)))
+					 (slot-name
+					  (if (symbolp slot-entry)
+					      slot-entry
+					      (cadr slot-entry))))
+				     `(,var-name
+				       (slot-value ,in ',slot-name))))
 				 slots)
 			,@body))))
 
@@ -2228,10 +2401,9 @@ bootstrapping.
 	   (and (symbolp instance)
 		`((declare (%variable-rebinding ,in ,instance)))))
        ,in
-       (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
-				   (let ((variable-name (car slot-entry))
+       (symbol-macrolet ,(mapcar (lambda (slot-entry)
+				   (let ((var-name (car slot-entry))
 					 (accessor-name (cadr slot-entry)))
-				     `(,variable-name
-					(,accessor-name ,in))))
-			       slots)
+				     `(,var-name (,accessor-name ,in))))
+				 slots)
 	  ,@body))))