X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=32848970d1fa5ccde6ad71d8f7403dcb62ebdb17;hb=4e3b57699314dbd3883470d9b196287b178f3e6d;hp=f1ae7e5aee2fbe95e5ccdc575994eb7ed85f2dfe;hpb=ec6d4bd97d9adc6f4003747d8ca92fad7766ccfd;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index f1ae7e5..3284897 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -90,7 +90,6 @@ bootstrapping.
 (declaim (notinline make-a-method
 		    add-named-method
 		    ensure-generic-function-using-class
-
 		    add-method
 		    remove-method))
 
@@ -157,6 +156,11 @@ bootstrapping.
       standard-compute-effective-method))))
 
 (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)))
   (let ((initargs ())
 	(methods ()))
     (flet ((duplicate-option (name)
@@ -399,7 +403,8 @@ bootstrapping.
 				   ,,(cadr specializer))
 				`',specializer))
 			  specializers))
-	 unspecialized-lambda-list method-class-name
+	 unspecialized-lambda-list
+	 method-class-name
 	 initargs-form
 	 pv-table-symbol))))
 
@@ -441,7 +446,24 @@ bootstrapping.
 	(extract-declarations 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)).
+		 (declare (%method-name (,name
+					 ,@qualifiers
+					 ,specializers)))
 		 (declare (%method-lambda-list ,@lambda-list))
 		 ,@declarations
 		 ,@real-body)
@@ -450,7 +472,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))
@@ -941,31 +964,38 @@ bootstrapping.
 (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
 					   &body body)
   `(macrolet ((call-next-method-bind (&body body)
-		`(let () ,@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")))
+               `(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
+                         ,',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")))
 	      (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)