X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=292e76333763fa1c20192c7d72af304f9359e545;hb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;hp=dbf5fa84b6b3190bddd7efa5bc5ab8ff4053da74;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index dbf5fa8..292e763 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -36,10 +36,10 @@
 (defun pv-cache-limit-fn (nlines)
   (default-limit-fn nlines))
 
-(defstruct (pv-table
-	     (:predicate pv-tablep)
-	     (:constructor make-pv-table-internal
-			   (slot-name-lists call-list)))
+(defstruct (pv-table (:predicate pv-tablep)
+		     (:constructor make-pv-table-internal
+				   (slot-name-lists call-list))
+		     (:copier nil))
   (cache nil :type (or cache null))
   (pv-size 0 :type fixnum)
   (slot-name-lists nil :type list)
@@ -160,18 +160,23 @@
   (unless (listp wrappers) (setq wrappers (list wrappers)))
   (let* ((not-simple-p-cell (list nil))
 	 (elements
-	  (gathering1 (collecting)
-	    (iterate ((slot-names (list-elements slot-name-lists)))
+          (let ((elements nil))
+            (dolist (slot-names slot-name-lists)
 	      (when slot-names
 		(let* ((wrapper     (pop wrappers))
 		       (std-p (typep wrapper 'wrapper))
 		       (class       (wrapper-class* wrapper))
 		       (class-slots (and std-p (wrapper-class-slots wrapper))))
 		  (dolist (slot-name (cdr slot-names))
-		    (gather1
-		     (when std-p
-		       (compute-pv-slot slot-name wrapper class
-					class-slots not-simple-p-cell))))))))))
+                    ;; Original PCL code had this idiom.  why not:
+                    ;;
+                    ;; (WHEN STD-P
+                    ;;   (PUSH ...)) ?
+                    (push (when std-p
+                            (compute-pv-slot slot-name wrapper class
+                                             class-slots not-simple-p-cell))
+                          elements)))))
+            (nreverse elements))))
     (if (car not-simple-p-cell)
 	(make-permutation-vector (cons t elements))
 	(or (gethash elements *pvs*)
@@ -182,8 +187,8 @@
   (declare (ignore call-list wrappers))
   #||
   (map 'vector
-       #'(lambda (call)
-	   (compute-emf-from-wrappers call wrappers))
+       (lambda (call)
+	 (compute-emf-from-wrappers call wrappers))
        call-list)
   ||#
   '#())
@@ -194,18 +199,18 @@
     (destructuring-bind (gf-name nreq restp arg-info) call
       (if (eq gf-name 'make-instance)
 	  (error "should not get here") ; there is another mechanism for this.
-	  #'(lambda (&rest args)
-	      (if (not (eq *boot-state* 'complete))
-		  (apply (gdefinition gf-name) args)
-		  (let* ((gf (gdefinition gf-name))
-			 (arg-info (arg-info-reader gf))
-			 (classes '?)
-			 (types '?)
-			 (emf (cache-miss-values-internal gf arg-info
-							  wrappers classes types
-							  'caching)))
-		    (update-all-pv-tables call wrappers emf)
-		    (invoke-emf emf args))))))))
+	  (lambda (&rest args)
+	    (if (not (eq *boot-state* 'complete))
+		(apply (gdefinition gf-name) args)
+		(let* ((gf (gdefinition gf-name))
+		       (arg-info (arg-info-reader gf))
+		       (classes '?)
+		       (types '?)
+		       (emf (cache-miss-values-internal gf arg-info
+							wrappers classes types
+							'caching)))
+		  (update-all-pv-tables call wrappers emf)
+		  (invoke-emf emf args))))))))
 ||#
 
 (defun make-permutation-vector (indexes)
@@ -266,26 +271,26 @@
 	 (std-p (typep cwrapper 'wrapper))
 	 (class-slots (and std-p (wrapper-class-slots cwrapper)))
 	 (class-slot-p-cell (list nil))
-	 (new-values (mapcar #'(lambda (slot-name)
-				 (cons slot-name
-				       (when std-p
-					 (compute-pv-slot
-					  slot-name cwrapper class
-					  class-slots class-slot-p-cell))))
+	 (new-values (mapcar (lambda (slot-name)
+			       (cons slot-name
+				     (when std-p
+				       (compute-pv-slot
+					slot-name cwrapper class
+					class-slots class-slot-p-cell))))
 			     slot-names))
 	 (pv-tables nil))
     (dolist (slot-name slot-names)
       (map-pv-table-references-of
        slot-name
-       #'(lambda (pv-table pv-offset-list)
-	   (declare (ignore pv-offset-list))
-	   (pushnew pv-table pv-tables))))
+       (lambda (pv-table pv-offset-list)
+	 (declare (ignore pv-offset-list))
+	 (pushnew pv-table pv-tables))))
     (dolist (pv-table pv-tables)
       (let* ((cache (pv-table-cache pv-table))
 	     (slot-name-lists (pv-table-slot-name-lists pv-table))
 	     (pv-size (pv-table-pv-size pv-table))
 	     (pv-map (make-array pv-size :initial-element nil)))
-	(let ((map-index 1)(param-index 0))
+	(let ((map-index 1) (param-index 0))
 	  (dolist (slot-name-list slot-name-lists)
 	    (dolist (slot-name (cdr slot-name-list))
 	      (let ((a (assoc slot-name new-values)))
@@ -294,10 +299,10 @@
 	      (incf map-index))
 	    (incf param-index)))
 	(when cache
-	  (map-cache #'(lambda (wrappers pv-cell)
-			 (setf (car pv-cell)
-			       (update-slots-in-pv wrappers (car pv-cell)
-						   cwrapper pv-size pv-map)))
+	  (map-cache (lambda (wrappers pv-cell)
+		       (setf (car pv-cell)
+			     (update-slots-in-pv wrappers (car pv-cell)
+						 cwrapper pv-size pv-map)))
 		     cache))))))
 
 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
@@ -383,8 +388,7 @@
 				       slots
 				       calls)
   (declare (ignore required-parameters env slots calls))
-  (or (and (eq (car form) 'make-instance)
-	   (expand-make-instance-form form))
+  (or ; (optimize-reader ...)?
       form))
 
 (defun can-optimize-access (form required-parameters env)
@@ -415,20 +419,18 @@
     ;; against 'THE scattered through the PCL code.
     (setq var (caddr var)))
   (when (symbolp var)
-    (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
-						  var
-						  env)))
+    (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
 	   (parameter-or-nil (car (memq (or rebound? var)
 					required-parameters))))
       (when parameter-or-nil
-	(let* ((class-name (caddr (variable-declaration '%class
-							parameter-or-nil
-							env)))
+	(let* ((class-name (caddr (var-declaration '%class
+						   parameter-or-nil
+						   env)))
 	       (class (find-class class-name nil)))
 	  (when (or (not (eq *boot-state* 'complete))
 		    (and class (not (class-finalized-p class))))
 	    (setq class nil))
-	  (when (and class-name (not (eq class-name 't)))
+	  (when (and class-name (not (eq class-name t)))
 	    (when (or (null type)
 		      (not (and class
 				(memq *the-class-structure-object*
@@ -520,13 +522,13 @@
 		     ,parameter)
 		    ,new-value))
 	    (:boundp
-	     'T)))
+	     t)))
 	(let* ((parameter-entry (assq parameter slots))
 	       (slot-entry      (assq slot-name (cdr parameter-entry)))
 	       (position (posq parameter-entry slots))
 	       (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
 	  (unless parameter-entry
-	    (error "internal error in slot optimization"))
+	    (bug "slot optimization bewilderment: O-I-A"))
 	  (unless slot-entry
 	    (setq slot-entry (list slot-name))
 	    (push slot-entry (cdr parameter-entry)))
@@ -554,7 +556,7 @@
 	 (position (posq parameter-entry slots))
 	 (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
     (unless parameter-entry
-      (error "internal error in slot optimization"))
+      (error "slot optimization bewilderment: O-A-C"))
     (unless slot-entry
       (setq slot-entry (list name))
       (push slot-entry (cdr parameter-entry)))
@@ -574,13 +576,15 @@
 	     (eq (car form) 'the))
     (setq form (caddr form)))
   (or (and (symbolp form)
-	   (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
-							 form env)))
+	   (let* ((rebound? (caddr (var-declaration '%variable-rebinding
+						    form
+						    env)))
 		  (parameter-or-nil (car (assq (or rebound? form) slots))))
 	     (when parameter-or-nil
-	       (let* ((class-name (caddr (variable-declaration
-					  'class parameter-or-nil env))))
-		 (when (and class-name (not (eq class-name 't)))
+	       (let* ((class-name (caddr (var-declaration 'class
+							  parameter-or-nil
+							  env))))
+		 (when (and class-name (not (eq class-name t)))
 		   (position parameter-or-nil slots :key #'car))))))
       (if (constantp form)
 	  (let ((form (eval form)))
@@ -596,8 +600,8 @@
 	   (non-required-args (nthcdr nreq args))
 	   (required-args (ldiff args non-required-args))
 	   (call-spec (list (car gf-call-form) nreq restp
-			    (mapcar #'(lambda (form)
-					(optimize-gf-call-internal form slots env))
+			    (mapcar (lambda (form)
+				      (optimize-gf-call-internal form slots env))
 				    (if all-args-p
 					args
 					required-args))))
@@ -633,7 +637,7 @@
 	 (standard-class-p class)
 	 (not (eq class *the-class-t*)) ; shouldn't happen, though.
 	 (let ((slotd (find-slot-definition class slot-name)))
-	   (and slotd (classp (slot-definition-allocation slotd)))))))
+	   (and slotd (eq :class (slot-definition-allocation slotd)))))))
 
 (defun skip-fast-slot-access-p (class-form slot-name-form type)
   (let ((class (and (constantp class-form) (eval class-form)))
@@ -655,16 +659,16 @@
 (defmacro instance-read-internal (pv slots pv-offset default &optional type)
   (unless (member type '(nil :instance :class :default))
     (error "illegal type argument to ~S: ~S" 'instance-read-internal type))
-  (if (eq type ':default)
+  (if (eq type :default)
       default
       (let* ((index (gensym))
 	     (value index))
 	`(locally (declare #.*optimize-speed*)
 	  (let ((,index (pvref ,pv ,pv-offset)))
 	    (setq ,value (typecase ,index
-			   ,@(when (or (null type) (eq type ':instance))
-			       `((fixnum (%instance-ref ,slots ,index))))
-			   ,@(when (or (null type) (eq type ':class))
+			   ,@(when (or (null type) (eq type :instance))
+			       `((fixnum (clos-slots-ref ,slots ,index))))
+			   ,@(when (or (null type) (eq type :class))
 			       `((cons (cdr ,index))))
 			   (t +slot-unbound+)))
 	    (if (eq ,value +slot-unbound+)
@@ -677,7 +681,7 @@
       `(instance-read-internal .pv. ,(slot-vector-symbol position)
 	,pv-offset (accessor-slot-value ,parameter ,slot-name)
 	,(if (generate-fast-class-slot-access-p class slot-name)
-	     ':class ':instance))))
+	     :class :instance))))
 
 (defmacro instance-reader (pv-offset parameter position gf-name class)
   (declare (ignore class))
@@ -690,15 +694,16 @@
 				      &optional type)
   (unless (member type '(nil :instance :class :default))
     (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
-  (if (eq type ':default)
+  (if (eq type :default)
       default
       (let* ((index (gensym)))
 	`(locally (declare #.*optimize-speed*)
 	  (let ((,index (pvref ,pv ,pv-offset)))
 	    (typecase ,index
-	      ,@(when (or (null type) (eq type ':instance))
-		  `((fixnum (setf (%instance-ref ,slots ,index) ,new-value))))
-	      ,@(when (or (null type) (eq type ':class))
+	      ,@(when (or (null type) (eq type :instance))
+                      `((fixnum (setf (clos-slots-ref ,slots ,index)
+				      ,new-value))))
+	      ,@(when (or (null type) (eq type :class))
 		  `((cons (setf (cdr ,index) ,new-value))))
 	      (t ,default)))))))
 
@@ -714,7 +719,7 @@
 	,pv-offset ,new-value
 	(accessor-set-slot-value ,parameter ,slot-name ,new-value)
 	,(if (generate-fast-class-slot-access-p class slot-name)
-	     ':class ':instance))))
+	     :class :instance))))
 
 (defmacro instance-writer (pv-offset
 			   parameter
@@ -726,7 +731,7 @@
   `(instance-write-internal .pv. ,(slot-vector-symbol position)
     ,pv-offset ,new-value
     (,(if (consp gf-name)
-	  (get-setf-function-name gf-name)
+	  (get-setf-fun-name gf-name)
 	  gf-name)
      (instance-accessor-parameter ,parameter)
      ,new-value)
@@ -736,16 +741,17 @@
 				       &optional type)
   (unless (member type '(nil :instance :class :default))
     (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
-  (if (eq type ':default)
+  (if (eq type :default)
       default
       (let* ((index (gensym)))
 	`(locally (declare #.*optimize-speed*)
 	  (let ((,index (pvref ,pv ,pv-offset)))
 	    (typecase ,index
-	      ,@(when (or (null type) (eq type ':instance))
-		  `((fixnum (not (eq (%instance-ref ,slots ,index)
-				     +slot-unbound+)))))
-	      ,@(when (or (null type) (eq type ':class))
+	      ,@(when (or (null type) (eq type :instance))
+		  `((fixnum (not (and ,slots
+                                      (eq (clos-slots-ref ,slots ,index)
+                                          +slot-unbound+))))))
+	      ,@(when (or (null type) (eq type :class))
 		  `((cons (not (eq (cdr ,index) +slot-unbound+)))))
 	      (t ,default)))))))
 
@@ -755,7 +761,7 @@
       `(instance-boundp-internal .pv. ,(slot-vector-symbol position)
 	,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
 	,(if (generate-fast-class-slot-access-p class slot-name)
-	     ':class ':instance))))
+	     :class :instance))))
 
 ;;; This magic function has quite a job to do indeed.
 ;;;
@@ -776,8 +782,8 @@
 (defun slot-name-lists-from-slots (slots calls)
   (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
     (let* ((slot-name-lists
-	    (mapcar #'(lambda (parameter-entry)
-			(cons nil (mapcar #'car (cdr parameter-entry))))
+	    (mapcar (lambda (parameter-entry)
+		      (cons nil (mapcar #'car (cdr parameter-entry))))
 		    slots))
 	   (call-list
 	    (mapcar #'car calls)))
@@ -785,22 +791,22 @@
 	(dolist (arg (cdr call))
 	  (when (integerp arg)
 	    (setf (car (nth arg slot-name-lists)) t))))
-      (setq slot-name-lists (mapcar #'(lambda (r+snl)
-					(when (or (car r+snl) (cdr r+snl))
-					  r+snl))
+      (setq slot-name-lists (mapcar (lambda (r+snl)
+				      (when (or (car r+snl) (cdr r+snl))
+					r+snl))
 				    slot-name-lists))
       (let ((cvt (apply #'vector
 			(let ((i -1))
-			  (mapcar #'(lambda (r+snl)
-				      (when r+snl (incf i)))
+			  (mapcar (lambda (r+snl)
+				    (when r+snl (incf i)))
 				  slot-name-lists)))))
-	(setq call-list (mapcar #'(lambda (call)
-				    (cons (car call)
-					  (mapcar #'(lambda (arg)
-						      (if (integerp arg)
-							  (svref cvt arg)
-							  arg))
-						  (cdr call))))
+	(setq call-list (mapcar (lambda (call)
+				  (cons (car call)
+					(mapcar (lambda (arg)
+						  (if (integerp arg)
+						      (svref cvt arg)
+						      arg))
+						(cdr call))))
 				call-list)))
       (values slot-name-lists call-list))))
 
@@ -872,25 +878,26 @@
 
 (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
 		      &body body)
-  (with-gathering ((slot-vars (collecting))
-		   (pv-parameters (collecting)))
-    (iterate ((slots (list-elements slot-name-lists))
-	      (required-parameter (list-elements required-parameters))
-	      (i (interval :from 0)))
-      (when slots
-	(gather required-parameter pv-parameters)
-	(gather (slot-vector-symbol i) slot-vars)))
-    `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars)
+  (let (slot-vars pv-parameters)
+    (loop for slots in slot-name-lists
+          for required-parameter in required-parameters
+          for i from 0
+          do (when slots
+               (push required-parameter pv-parameters)
+               (push (slot-vector-symbol i) slot-vars)))
+    `(pv-binding1 (.pv. .calls. ,pv-table-symbol
+                   ,(nreverse pv-parameters) ,(nreverse slot-vars))
        ,@body)))
 
 (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
 		       &body body)
   `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
-     (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
-	       slot-vars pv-parameters))
+     (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
+		     slot-vars pv-parameters))
 	,@body)))
 
-;;; This gets used only when the default MAKE-METHOD-LAMBDA is overridden.
+;;; This gets used only when the default MAKE-METHOD-LAMBDA is
+;;; overridden.
 (defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
 		  &rest forms)
   `(let* ((.pv-table. ,pv-table-symbol)
@@ -904,19 +911,24 @@
      ,pv ,calls
      ,@forms))
 
-(defvar *non-variable-declarations*
+(defvar *non-var-declarations*
   ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
   ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
   ;; SBCL doesn't have 'em, VALUES should probably be removed from
   ;; this list.
-  '(values %method-name %method-lambda-list
-    optimize ftype inline notinline))
-
-(defvar *variable-declarations-with-argument*
+  '(values
+    %method-name
+    %method-lambda-list
+    optimize
+    ftype
+    inline
+    notinline))
+
+(defvar *var-declarations-with-arg*
   '(%class
     type))
 
-(defvar *variable-declarations-without-argument*
+(defvar *var-declarations-without-arg*
   '(ignore
     ignorable special dynamic-extent
     ;; FIXME: Possibly this entire list and variable could go away.
@@ -944,20 +956,20 @@
 	  (dolist (form (cdr decl))
 	    (when (consp form)
 	      (let ((declaration-name (car form)))
-		(if (member declaration-name *non-variable-declarations*)
+		(if (member declaration-name *non-var-declarations*)
 		    (push `(declare ,form) outer-decls)
 		    (let ((arg-p
 			   (member declaration-name
-				   *variable-declarations-with-argument*))
+				   *var-declarations-with-arg*))
 			  (non-arg-p
 			   (member declaration-name
-				   *variable-declarations-without-argument*))
+				   *var-declarations-without-arg*))
 			  (dname (list (pop form)))
 			  (inners nil) (outers nil))
 		      (unless (or arg-p non-arg-p)
 			;; FIXME: This warning, and perhaps the
-			;; various *VARIABLE-DECLARATIONS-FOO* and/or
-			;; *NON-VARIABLE-DECLARATIONS* variables,
+			;; various *VAR-DECLARATIONS-FOO* and/or
+			;; *NON-VAR-DECLARATIONS* variables,
 			;; could probably go away now that we're not
 			;; trying to be portable between different
 			;; CLTL1 hosts the way PCL was. (Note that to
@@ -969,18 +981,17 @@
 			(Assuming it is a variable declaration without argument)."
 			      declaration-name 'split-declarations
 			      declaration-name
-			      '*non-variable-declarations*
-			      '*variable-declarations-with-argument*
-			      '*variable-declarations-without-argument*)
-			(push declaration-name
-			      *variable-declarations-without-argument*))
+			      '*non-var-declarations*
+			      '*var-declarations-with-arg*
+			      '*var-declarations-without-arg*)
+			(push declaration-name *var-declarations-without-arg*))
 		      (when arg-p
 			(setq dname (append dname (list (pop form)))))
 		      (dolist (var form)
 			(if (member var args)
 			    ;; Quietly remove IGNORE declarations on
 			    ;; args when a next-method is involved, to
-			    ;; prevent compiler warns about ignored
+			    ;; prevent compiler warnings about ignored
 			    ;; args being read.
 			    (unless (and calls-next-method-p
 					 (eq (car dname) 'ignore))
@@ -993,9 +1004,34 @@
 	  (setq body (cdr body)))
     (values outer-decls inner-decls body)))
 
+;;; Pull a name out of the %METHOD-NAME declaration in the function
+;;; body given, or return NIL if no %METHOD-NAME declaration is found.
+(defun body-method-name (body)
+  (multiple-value-bind (real-body declarations documentation)
+      (parse-body body nil)
+    (declare (ignore documentation real-body))
+    (let ((name-decl (get-declaration '%method-name declarations)))
+      (and name-decl
+	   (destructuring-bind (name) name-decl
+	     name)))))
+
+;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
+;;; declaration (which is a naming style internal to PCL) into an
+;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
+;;; throughout SBCL, understood by the main compiler); or if there's
+;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
+;;; lambda expression.
+(defun name-method-lambda (method-lambda)
+  (let ((method-name (body-method-name (cddr method-lambda))))
+    (if method-name
+	`(named-lambda ,method-name ,(rest method-lambda))
+	method-lambda)))
+
 (defun make-method-initargs-form-internal (method-lambda initargs env)
   (declare (ignore env))
-  (let (method-lambda-args lmf lmf-params)
+  (let (method-lambda-args
+	lmf ; becomes body of function
+	lmf-params)
     (if (not (and (= 3 (length method-lambda))
 		  (= 2 (length (setq method-lambda-args (cadr method-lambda))))
 		  (consp (setq lmf (third method-lambda)))
@@ -1004,47 +1040,57 @@
 		      (cadr (setq lmf-params (cadr lmf))))
 		  (eq (cadr method-lambda-args)
 		      (caddr lmf-params))))
-	`(list* :function #',method-lambda
+	`(list* :function ,(name-method-lambda method-lambda)
 		',initargs)
 	(let* ((lambda-list (car lmf-params))
-	       (nreq 0)(restp nil)(args nil))
+	       (nreq 0)
+	       (restp nil)
+	       (args nil))
 	  (dolist (arg lambda-list)
 	    (when (member arg '(&optional &rest &key))
-	      (setq restp t)(return nil))
-	    (when (eq arg '&aux) (return nil))
-	    (incf nreq)(push arg args))
+	      (setq restp t)
+	      (return nil))
+	    (when (eq arg '&aux)
+	      (return nil))
+	    (incf nreq)
+	    (push arg args))
 	  (setq args (nreverse args))
-	  (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp))
+	  (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp))
 	  (make-method-initargs-form-internal1
 	   initargs (cddr lmf) args lmf-params restp)))))
 
 (defun make-method-initargs-form-internal1
     (initargs body req-args lmf-params restp)
-  (multiple-value-bind (outer-decls inner-decls body)
+  (multiple-value-bind (outer-decls inner-decls body-sans-decls)
       (split-declarations
        body req-args (getf (cdr lmf-params) :call-next-method-p))
     (let* ((rest-arg (when restp '.rest-arg.))
 	   (args+rest-arg (if restp
 			      (append req-args (list rest-arg))
 			      req-args)))
-      `(list* :fast-function
-	(lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
-	  (declare (ignorable .pv-cell. .next-method-call.))
-	  ,@outer-decls
-	  (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
-			      &rest forms)
-		       (declare (ignore pv-table-symbol pv-parameters))
-		       `(let ((,pv (car .pv-cell.))
-			      (,calls (cdr .pv-cell.)))
-			  (declare ,(make-pv-type-declaration pv)
-				   ,(make-calls-type-declaration calls))
-			  ,pv ,calls
-			  ,@forms)))
-	    (fast-lexical-method-functions
-	     (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
-	      ,@(cdddr lmf-params))
-	     ,@inner-decls
-	     ,@body)))
+      `(list*
+	:fast-function
+	(named-lambda
+	 ,(or (body-method-name body) '.method.) ; function name
+	 (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
+	 ;; body of the function
+	 (declare (ignorable .pv-cell. .next-method-call.))
+	 ,@outer-decls
+	 (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
+			     &rest forms)
+			    (declare (ignore pv-table-symbol
+					     pv-parameters))
+			    `(let ((,pv (car .pv-cell.))
+				   (,calls (cdr .pv-cell.)))
+			       (declare ,(make-pv-type-declaration pv)
+					,(make-calls-type-declaration calls))
+			       ,pv ,calls
+			       ,@forms)))
+	   (fast-lexical-method-functions
+	    (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+	     ,@(cdddr lmf-params))
+	    ,@inner-decls
+	    ,@body-sans-decls)))
 	',initargs))))
 
 ;;; Use arrays and hash tables and the fngen stuff to make this much
@@ -1055,28 +1101,29 @@
 (defun method-function-from-fast-function (fmf)
   (declare (type function fmf))
   (let* ((method-function nil) (pv-table nil)
-	 (arg-info (method-function-get fmf ':arg-info))
+	 (arg-info (method-function-get fmf :arg-info))
 	 (nreq (car arg-info))
 	 (restp (cdr arg-info)))
     (setq method-function
-	  #'(lambda (method-args next-methods)
-	      (unless pv-table
-		(setq pv-table (method-function-pv-table fmf)))
-	      (let* ((pv-cell (when pv-table
-				(get-method-function-pv-cell
-				 method-function method-args pv-table)))
-		     (nm (car next-methods))
-		     (nms (cdr next-methods))
-		     (nmc (when nm
-			    (make-method-call :function (if (std-instance-p nm)
-							    (method-function nm)
-							    nm)
-					      :call-method-args (list nms)))))
-		(if restp
-		    (let* ((rest (nthcdr nreq method-args))
-			   (args (ldiff method-args rest)))
-		      (apply fmf pv-cell nmc (nconc args (list rest))))
-		    (apply fmf pv-cell nmc method-args)))))
+	  (lambda (method-args next-methods)
+	    (unless pv-table
+	      (setq pv-table (method-function-pv-table fmf)))
+	    (let* ((pv-cell (when pv-table
+			      (get-method-function-pv-cell
+			       method-function method-args pv-table)))
+		   (nm (car next-methods))
+		   (nms (cdr next-methods))
+		   (nmc (when nm
+			  (make-method-call
+			   :function (if (std-instance-p nm)
+					 (method-function nm)
+					 nm)
+			   :call-method-args (list nms)))))
+	      (if restp
+		  (let* ((rest (nthcdr nreq method-args))
+			 (args (ldiff method-args rest)))
+		    (apply fmf pv-cell nmc (nconc args (list rest))))
+		  (apply fmf pv-cell nmc method-args)))))
     (let* ((fname (method-function-get fmf :name))
 	   (name `(,(or (get (car fname) 'method-sym)
 			(setf (get (car fname) 'method-sym)
@@ -1085,7 +1132,7 @@
 				    (intern (subseq str 5) *pcl-package*)
 				    (car fname)))))
 		    ,@(cdr fname))))
-      (set-function-name method-function name))
+      (set-fun-name method-function name))
     (setf (method-function-get method-function :fast-function) fmf)
     method-function))
 
@@ -1108,7 +1155,7 @@
 	 (w-t pv-wrappers))
     (dolist (arg args)
       (setq w (wrapper-of arg))
-      (unless (eq 't (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
+      (when (invalid-wrapper-p w)
 	(setq w (check-wrapper-validity arg)))
       (setf (car w-t) w))
       (setq w-t (cdr w-t))