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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index e05b509..37afe01 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -806,7 +806,22 @@ bootstrapping.
   (unless (constantp restp)
     (error "The RESTP argument is not constant."))
   (setq restp (eval restp))
-  `(progn
+  `(locally
+
+     ;; In sbcl-0.6.11.43, the compiler would issue bogus warnings
+     ;; about type mismatches in unreachable code when we
+     ;; macroexpanded the GET-SLOTS-OR-NIL expressions here and
+     ;; byte-compiled the code. GET-SLOTS-OR-NIL is now an inline
+     ;; function instead of a macro, which seems sufficient to solve
+     ;; the problem all by itself (probably because of some quirk in
+     ;; the relative order of expansion and type inference) but we
+     ;; also use overkill by NOTINLINEing GET-SLOTS-OR-NIL, because it
+     ;; looks as though (1) inlining isn't that much of a win anyway,
+     ;; and (2a) once you miss the FAST-METHOD-CALL clause you're
+     ;; going to be slow anyway, but (2b) code bloat still hurts even
+     ;; when it's off the critical path.
+     (declare (notinline get-slots-or-nil))
+
      (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))
@@ -963,8 +978,8 @@ bootstrapping.
 	      (null closurep)
 	      (null applyp))
 	 `(let () ,@body))
-	 ((and (null closurep)
-	       (null applyp))
+	((and (null closurep)
+	      (null applyp))
 	 ;; OK to use MACROLET, and all args are mandatory
 	 ;; (else APPLYP would be true).
 	 `(call-next-method-bind
@@ -1190,7 +1205,6 @@ bootstrapping.
   (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)
     (load-defmethod-internal class name quals specls
 			     ll initargs pv-table-symbol)))
 
@@ -1523,7 +1537,7 @@ bootstrapping.
 	      method
 	      gf
 	      (apply #'format nil string args)))
-	   (compare (x y)
+	   (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,11 +1546,11 @@ 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~%~
@@ -1746,7 +1760,11 @@ 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