[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp,1.78,1.79

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8895/src/pcl

Modified Files:
	boot.lisp 
Log Message:
0.8.11.15:
	Fix bug 276.  Woo yay.  Now we can be evil in DEFMETHODs again.
	... also log a couple more HaibleMOPBugs


Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -d -r1.78 -r1.79
--- boot.lisp	19 Oct 2003 19:09:12 -0000	1.78
+++ boot.lisp	16 Jun 2004 21:00:24 -0000	1.79
@@ -502,7 +502,6 @@
   (declare (ignore env))
   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
       (parse-specialized-lambda-list lambda-list)
-    (declare (ignore parameters))
     (multiple-value-bind (real-body declarations documentation)
 	(parse-body body)
       (values `(lambda ,unspecialized-lambda-list
@@ -670,8 +669,9 @@
 		  ;; it can avoid run-time type dispatch overhead,
 		  ;; which can be a huge win for Python.)
 		  ;;
-		  ;; FIXME: Perhaps these belong in
-		  ;; ADD-METHOD-DECLARATIONS instead of here?
+		  ;; KLUDGE: when I tried moving these to
+		  ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
+		  ;; why.  -- CSR, 2004-06-16
 		  ,@(mapcar #'parameter-specializer-declaration-in-defmethod
 			    parameters
 			    specializers)))
@@ -717,7 +717,8 @@
 			       ((eq p '&aux)
 				(return nil))))))
 	  (multiple-value-bind
-	      (walked-lambda call-next-method-p closurep next-method-p-p)
+		(walked-lambda call-next-method-p closurep
+			       next-method-p-p setq-p)
 	      (walk-method-lambda method-lambda
 				  required-parameters
 				  env
@@ -758,6 +759,7 @@
 					:call-next-method-p
 					,call-next-method-p
 					:next-method-p-p ,next-method-p-p
+			                :setq-p ,setq-p
 			                ;; we need to pass this along
 			                ;; so that NO-NEXT-METHOD can
 			                ;; be given a suitable METHOD
@@ -820,8 +822,9 @@
 		            (or ,cnm-args ,',method-args))))
 	      (next-method-p-body ()
 	       `(not (null .next-method.)))
-	      (with-rebound-original-args ((call-next-method-p) &body body)
-		(declare (ignore call-next-method-p))
+	      (with-rebound-original-args ((call-next-method-p setq-p)
+					   &body body)
+		(declare (ignore call-next-method-p setq-p))
 		`(let () ,@body)))
     ,@body))
 
@@ -1114,8 +1117,8 @@
 					`(,rest-arg)))))))
 		(next-method-p-body ()
 		 `(not (null ,',next-method-call)))
-		(with-rebound-original-args ((cnm-p) &body body)
-		  (if cnm-p
+		(with-rebound-original-args ((cnm-p setq-p) &body body)
+		  (if (or cnm-p setq-p)
 		      `(let ,',rebindings
 			(declare (ignorable ,@',all-params))
 			,@body)
@@ -1123,11 +1126,11 @@
       ,@body)))
 
 (defmacro bind-lexical-method-functions
-    ((&key call-next-method-p next-method-p-p
+    ((&key call-next-method-p next-method-p-p setq-p
 	   closurep applyp method-name-declaration)
      &body body)
   (cond ((and (null call-next-method-p) (null next-method-p-p)
-	      (null closurep) (null applyp))
+	      (null closurep) (null applyp) (null setq-p))
 	 `(let () ,@body))
 	(t
 	 `(call-next-method-bind
@@ -1139,7 +1142,7 @@
 		   ,@(and next-method-p-p
 			  '((next-method-p ()
 			     (next-method-p-body)))))
-	      (with-rebound-original-args (,call-next-method-p)
+	      (with-rebound-original-args (,call-next-method-p ,setq-p)
 		,@body))))))
 
 (defmacro bind-args ((lambda-list args) &body body)
@@ -1231,8 +1234,9 @@
 				   ; should be in the method definition
 	(closurep nil)		   ; flag indicating that #'CALL-NEXT-METHOD
 				   ; was seen in the body of a method
-	(next-method-p-p nil))     ; flag indicating that NEXT-METHOD-P
+	(next-method-p-p nil)      ; flag indicating that NEXT-METHOD-P
 				   ; should be in the method definition
+	(setq-p nil))
     (flet ((walk-function (form context env)
 	     (cond ((not (eq context :eval)) form)
 		   ;; FIXME: Jumping to a conclusion from the way it's used
@@ -1247,6 +1251,9 @@
 		   ((eq (car form) 'next-method-p)
 		    (setq next-method-p-p t)
 		    form)
+		   ((eq (car form) 'setq)
+		    (setq setq-p t)
+		    form)
 		   ((and (eq (car form) 'function)
 			 (cond ((eq (cadr form) 'call-next-method)
 				(setq call-next-method-p t)
@@ -1283,7 +1290,8 @@
 	(values walked-lambda
 		call-next-method-p
 		closurep
-		next-method-p-p)))))
+		next-method-p-p
+		setq-p)))))
 
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)