X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=c4b2bda3ffafce4ee0280f899c4a239d3c311032;hb=742e0b2aed0e06a5ac6036c6b576088e3f91208f;hp=0d67f60823d528358932c52c621d5d4ee45ee124;hpb=07e690d6ec0491352758ac278f2fa828a0a92e90;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 0d67f60..c4b2bda 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -189,7 +189,7 @@ bootstrapping.
 			:format-control "The declaration specifier ~S ~
                                          is not allowed inside DEFGENERIC."
 			:format-arguments (list (cadr option))))
-	       (push (cdr option) (initarg :declarations)))
+	       (push (cadr option) (initarg :declarations)))
 	      ((:argument-precedence-order :method-combination)
 	       (if (initarg car-option)
 		   (duplicate-option car-option)
@@ -239,7 +239,7 @@ bootstrapping.
   (apply #'ensure-generic-function
          fun-name
          :lambda-list lambda-list
-         :definition-source `((defgeneric ,fun-name) ,*load-truename*)
+         :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
          initargs))
 
 ;;; As per section 3.4.2 of the ANSI spec, generic function lambda
@@ -515,6 +515,13 @@ bootstrapping.
 		 ;; 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)))
@@ -726,6 +733,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
@@ -769,18 +784,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)
@@ -1011,7 +1040,7 @@ bootstrapping.
 		   ,emf))
 	      (call-next-method-bind (&body body)
                `(let () ,@body))
-	      (call-next-method-body (cnm-args)
+	      (call-next-method-body (method-name-declaration cnm-args)
                `(if ,',next-method-call
                  ,(locally
                    ;; This declaration suppresses a "deleting
@@ -1039,34 +1068,38 @@ bootstrapping.
                                        ,cnm-args)
                             ,call)
                            ,call))))
-                 (error "no next method")))
+		 ,(locally
+		   ;; As above, this declaration supresses 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))
 
 (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)))))
@@ -1306,7 +1339,7 @@ bootstrapping.
 		       :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)))
@@ -1613,11 +1646,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))
@@ -1634,13 +1666,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)))))))
 
@@ -1764,7 +1796,7 @@ bootstrapping.
     (!bootstrap-set-slot 'standard-generic-function
 			 fin
 			 'source
-			 *load-truename*)
+			 *load-pathname*)
     (set-fun-name fin spec)
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)