From 5b43e28a5a9f0fcdefc2132840492e2e382876c6 Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Thu, 21 Aug 2003 11:38:41 +0000
Subject: [PATCH] 0.8.2.52: 	Partial fix for method definition protocol 
 ... ANSI in its wisdom saith that the mere addition of a
 bogus 		method to a generic function is not cause
 for signalling 		an error.  Signal a warning
 instead, and defer the error 		to when the function
 is called. 	Factor out common testing code into a
 sourceable script, and 	adjust the clos tests to
 reflect this new interpretation

---
 NEWS                      |    4 ++
 src/pcl/dfun.lisp         |   20 +++++----
 src/pcl/methods.lisp      |   27 ++++++++++++
 tests/clos.test.sh        |   59 ++------------------------
 tests/compiler.test.sh    |   99 +------------------------------------------
 tests/expect.sh           |  102 +++++++++++++++++++++++++++++++++++++++++++++
 tests/threads.impure.lisp |    3 ++
 version.lisp-expr         |    2 +-
 8 files changed, 153 insertions(+), 163 deletions(-)
 create mode 100644 tests/expect.sh

diff --git a/NEWS b/NEWS
index c55253a..7b8d526 100644
--- a/NEWS
+++ b/NEWS
@@ -1989,6 +1989,10 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2:
     ** ASSOC now ignores NIL elements in an alist.
     ** CEILING now gives the right answer with MOST-NEGATIVE-FIXNUM
        and (1+ MOST-POSITIVE-FIXNUM) answers.
+    ** The addition of a method with invalid qualifiers to a generic
+       function does not cause an error to be signalled immediately;
+       a warning is signalled, and the error is generated only on
+       calling the generic function.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles
diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 2acc37e..d51705b 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -763,17 +763,19 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; considered as state transitions.
 (defvar *lazy-dfun-compute-p* t)
 (defvar *early-p* nil)
+(defvar *max-emf-precomputation-methods* 0)
 
 (defun finalize-specializers (gf)
-  (let ((all-finalized t))
-    (dolist (method (generic-function-methods gf))
-      (dolist (specializer (method-specializers method))
-	(when (and (classp specializer)
-		   (not (class-finalized-p specializer)))
-	  (if (class-has-a-forward-referenced-superclass-p specializer)
-	      (setq all-finalized nil)
-	      (finalize-inheritance specializer)))))
-    all-finalized))
+  (let ((methods (generic-function-methods gf)))
+    (when (< (length methods) *max-emf-precomputation-methods*)
+      (let ((all-finalized t))
+	(dolist (method methods all-finalized)
+	  (dolist (specializer (method-specializers method))
+	    (when (and (classp specializer)
+		       (not (class-finalized-p specializer)))
+	      (if (class-has-a-forward-referenced-superclass-p specializer)
+		  (setq all-finalized nil)
+		  (finalize-inheritance specializer)))))))))
 
 (defun make-initial-dfun (gf)
   (let ((initial-dfun
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 855c907..ab5110e 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -494,6 +494,33 @@
 		 (setq remove-again-p nil))
 	    (when remove-again-p
 	      (remove-method generic-function method))))
+
+	;; KLUDGE II: ANSI saith that it is not an error to add a
+	;; method with invalid qualifiers to a generic function of the
+	;; wrong kind; it's only an error at generic function
+	;; invocation time; I dunno what the rationale was, and it
+	;; sucks.  Nevertheless, it's probably a programmer error, so
+	;; let's warn anyway. -- CSR, 2003-08-20
+	(let ((mc (generic-function-method-combination generic-functioN)))
+	  (cond
+	    ((eq mc *standard-method-combination*)
+	     (when (and qualifiers
+			(or (cdr qualifiers)
+			    (not (memq (car qualifiers)
+				       '(:around :before :after)))))
+	       (warn "~@<Invalid qualifiers for standard method combination ~
+                      in method ~S:~2I~_~S.~@:>"
+		     method qualifiers)))
+	    ((short-method-combination-p mc)
+	     (let ((mc-name (method-combination-type mc)))
+	       (when (or (null qualifiers)
+			 (cdr qualifiers)
+			 (and (neq (car qualifiers) :around)
+			      (neq (car qualifiers) mc-name)))
+		 (warn "~@<Invalid qualifiers for ~S method combination ~
+                        in method ~S:~2I~_~S.~@:>"
+		       mc-name method qualifiers))))))
+	
 	(unless skip-dfun-update-p
 	  (update-ctors 'add-method
 			:generic-function generic-function
diff --git a/tests/clos.test.sh b/tests/clos.test.sh
index 65dd5d8..174fceb 100644
--- a/tests/clos.test.sh
+++ b/tests/clos.test.sh
@@ -11,61 +11,7 @@
 # absolutely no warranty. See the COPYING and CREDITS files for
 # more information.
 
-# Check that compiling and loading the file $1 generates an error
-# at load time; also that just loading it directly (into the
-# interpreter) generates an error.
-expect_load_error ()
-{
-    # Test compiling and loading.
-    $SBCL <<EOF
-	(compile-file "$1")
-	;;; But loading the file should fail.
-	(multiple-value-bind (value0 value1) (ignore-errors (load *))
-	    (assert (null value0))
-	    (format t "VALUE1=~S (~A)~%" value1 value1)
-	    (assert (typep value1 'error)))
-	(sb-ext:quit :unix-status 52)
-EOF
-    if [ $? != 52 ]; then
-	echo compile-and-load $1 test failed: $?
-	exit 1
-    fi
-
-    # Test loading into the interpreter.
-    $SBCL <<EOF
-	(multiple-value-bind (value0 value1) (ignore-errors (load "$1"))
-	    (assert (null value0))
-	    (format t "VALUE1=~S (~A)~%" value1 value1)
-	    (assert (typep value1 'error)))
-	(sb-ext:quit :unix-status 52)
-EOF
-    if [ $? != 52 ]; then
-	echo load-into-interpreter $1 test failed: $?
-	exit 1
-    fi
-}
-
-# Test that a file compiles cleanly, with no ERRORs, WARNINGs or
-# STYLE-WARNINGs.
-#
-# Maybe this wants to be in a compiler.test.sh script?  This function
-# was originally written to test APD's patch for slot readers and
-# writers not being known to the compiler. -- CSR, 2002-08-14
-expect_clean_compile () 
-{
-    $SBCL <<EOF
-        (multiple-value-bind (pathname warnings-p failure-p)
-            (compile-file "$1")
-          (declare (ignore pathname))
-          (assert (not warnings-p))
-          (assert (not failure-p))
-          (sb-ext:quit :unix-status 52))
-EOF
-    if [ $? != 52 ]; then
-        echo clean-compile $1 test failed: $?
-        exit 1
-    fi
-}
+. expect.sh
 
 base_tmpfilename="clos-test-$$-tmp"
 tmpfilename="$base_tmpfilename.lisp"
@@ -78,6 +24,7 @@ cat > $tmpfilename <<EOF
     ;; This definition has too many qualifiers, so loading the
     ;; DEFMETHOD should fail.
     (defmethod zut progn :around ((x integer)) (print "integer"))
+    (zut 1)
 EOF
 expect_load_error $tmpfilename
 
@@ -89,6 +36,7 @@ cat > $tmpfilename <<EOF
     ;; This definition is missing the PROGN qualifier, and so the
     ;; DEFMETHOD should fail.
     (defmethod zut ((x integer)) (print "integer"))
+    (zut 1)
 EOF
 expect_load_error $tmpfilename
 
@@ -103,6 +51,7 @@ cat > $tmpfilename <<EOF
     ;; This definition has too many qualifiers, so loading the
     ;; DEFMETHOD should fail.
     (defmethod zut progn :around ((x integer)) (print "integer"))
+    (zut 1)
 EOF
 expect_load_error $tmpfilename
 
diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index 65d0341..4c731b2 100644
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -11,104 +11,7 @@
 # absolutely no warranty. See the COPYING and CREDITS files for
 # more information.
 
-# FIXME: the functions below should be in their own file, sourced by
-# each of the *.test.sh scripts.
-
-# Check that compiling and loading the file $1 generates an error
-# at load time; also that just loading it directly (into the
-# interpreter) generates an error.
-expect_load_error ()
-{
-    # Test compiling and loading.
-    $SBCL <<EOF
-	(compile-file "$1")
-	;;; But loading the file should fail.
-	(multiple-value-bind (value0 value1) (ignore-errors (load *))
-	    (assert (null value0))
-	    (format t "VALUE1=~S (~A)~%" value1 value1)
-	    (assert (typep value1 'error)))
-	(sb-ext:quit :unix-status 52)
-EOF
-    if [ $? != 52 ]; then
-	echo compile-and-load $1 test failed: $?
-	exit 1
-    fi
-
-    # Test loading into the interpreter.
-    $SBCL <<EOF
-	(multiple-value-bind (value0 value1) (ignore-errors (load "$1"))
-	    (assert (null value0))
-	    (format t "VALUE1=~S (~A)~%" value1 value1)
-	    (assert (typep value1 'error)))
-	(sb-ext:quit :unix-status 52)
-EOF
-    if [ $? != 52 ]; then
-	echo load-into-interpreter $1 test failed: $?
-	exit 1
-    fi
-}
-
-# Test that a file compiles cleanly, with no ERRORs, WARNINGs or
-# STYLE-WARNINGs.
-expect_clean_compile () 
-{
-    $SBCL <<EOF
-        (multiple-value-bind (pathname warnings-p failure-p)
-            (compile-file "$1")
-          (declare (ignore pathname))
-          (assert (not warnings-p))
-          (assert (not failure-p))
-          (sb-ext:quit :unix-status 52))
-EOF
-    if [ $? != 52 ]; then
-        echo clean-compile $1 test failed: $?
-        exit 1
-    fi
-}
-
-expect_warned_compile ()
-{
-    $SBCL <<EOF
-        (multiple-value-bind (pathname warnings-p failure-p)
-            (compile-file "$1")
-          (declare (ignore pathname))
-          (assert warnings-p)
-          (assert (not failure-p))
-          (sb-ext:quit :unix-status 52))
-EOF
-    if [ $? != 52 ]; then
-        echo warn-compile $1 test failed: $?
-        exit 1
-    fi
-}
-
-expect_failed_compile ()
-{
-    $SBCL <<EOF
-        (multiple-value-bind (pathname warnings-p failure-p)
-            (compile-file "$1")
-          (declare (ignore pathname warnings-p))
-          (assert failure-p)
-          (sb-ext:quit :unix-status 52))
-EOF
-    if [ $? != 52 ]; then
-        echo fail-compile $1 test failed: $?
-        exit 1
-    fi
-}
-
-fail_on_compiler_note ()
-{
-    $SBCL <<EOF
-        (handler-bind ((sb-ext:compiler-note #'error))
-          (compile-file "$1")
-          (sb-ext:quit :unix-status 52))
-EOF
-    if [ $? != 52]; then
-        echo compiler-note $1 test failed: $?
-        exit 1
-    fi
-}
+. expect.sh
 
 base_tmpfilename="compiler-test-$$-tmp"
 tmpfilename="$base_tmpfilename.lisp"
diff --git a/tests/expect.sh b/tests/expect.sh
new file mode 100644
index 0000000..9a209fa
--- /dev/null
+++ b/tests/expect.sh
@@ -0,0 +1,102 @@
+# file to be sourced by scripts wanting to test the compiler
+
+# Check that compiling and loading the file $1 generates an error
+# at load time; also that just loading it directly (into the
+# interpreter) generates an error.
+expect_load_error ()
+{
+    # Test compiling and loading.
+    $SBCL <<EOF
+	(compile-file "$1")
+	;;; But loading the file should fail.
+	(multiple-value-bind (value0 value1) (ignore-errors (load *))
+	    (assert (null value0))
+	    (format t "VALUE1=~S (~A)~%" value1 value1)
+	    (assert (typep value1 'error)))
+	(sb-ext:quit :unix-status 52)
+EOF
+    if [ $? != 52 ]; then
+	echo compile-and-load $1 test failed: $?
+	exit 1
+    fi
+
+    # Test loading into the interpreter.
+    $SBCL <<EOF
+	(multiple-value-bind (value0 value1) (ignore-errors (load "$1"))
+	    (assert (null value0))
+	    (format t "VALUE1=~S (~A)~%" value1 value1)
+	    (assert (typep value1 'error)))
+	(sb-ext:quit :unix-status 52)
+EOF
+    if [ $? != 52 ]; then
+	echo load-into-interpreter $1 test failed: $?
+	exit 1
+    fi
+}
+
+# Test that a file compiles cleanly, with no ERRORs, WARNINGs or
+# STYLE-WARNINGs.
+#
+# Maybe this wants to be in a compiler.test.sh script?  This function
+# was originally written to test APD's patch for slot readers and
+# writers not being known to the compiler. -- CSR, 2002-08-14
+expect_clean_compile () 
+{
+    $SBCL <<EOF
+        (multiple-value-bind (pathname warnings-p failure-p)
+            (compile-file "$1")
+          (declare (ignore pathname))
+          (assert (not warnings-p))
+          (assert (not failure-p))
+          (sb-ext:quit :unix-status 52))
+EOF
+    if [ $? != 52 ]; then
+        echo clean-compile $1 test failed: $?
+        exit 1
+    fi
+}
+
+expect_warned_compile ()
+{
+    $SBCL <<EOF
+        (multiple-value-bind (pathname warnings-p failure-p)
+            (compile-file "$1")
+          (declare (ignore pathname))
+          (assert warnings-p)
+          (assert (not failure-p))
+          (sb-ext:quit :unix-status 52))
+EOF
+    if [ $? != 52 ]; then
+        echo warn-compile $1 test failed: $?
+        exit 1
+    fi
+}
+
+expect_failed_compile ()
+{
+    $SBCL <<EOF
+        (multiple-value-bind (pathname warnings-p failure-p)
+            (compile-file "$1")
+          (declare (ignore pathname warnings-p))
+          (assert failure-p)
+          (sb-ext:quit :unix-status 52))
+EOF
+    if [ $? != 52 ]; then
+        echo fail-compile $1 test failed: $?
+        exit 1
+    fi
+}
+
+fail_on_compiler_note ()
+{
+    $SBCL <<EOF
+        (handler-bind ((sb-ext:compiler-note #'error))
+          (compile-file "$1")
+          (sb-ext:quit :unix-status 52))
+EOF
+    if [ $? != 52]; then
+        echo compiler-note $1 test failed: $?
+        exit 1
+    fi
+}
+
diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 36111ea..0477691 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -125,4 +125,7 @@
     (sleep 5))
   (terminate-thread child))
 
+;; better would be "wait until all child threads have exited"
+(sleep 3)
+
 (sb-ext:quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index bdaa751..d01d91b 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.2.51"
+"0.8.2.52"
-- 
1.7.10.4