X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=dfcb369e651554cfdcd1664c94bb0789503afbc2;hb=16a6592367eec7c5e9da668ec42fd260e7705b0c;hp=731cfdfa892eeaf013103fe5101e416827a06796;hpb=e0b874267a9b4a074277a963a62999b1698af572;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 731cfdf..dfcb369 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -434,6 +434,120 @@
 		    form)))
 	    'dmc-test-return))
 
+;;; DEFINE-METHOD-COMBINATION should, according to the description in 7.7,
+;;; allow you to do everything in the body forms yourself if you specify  
+;;; exactly one method group whose qualifier-pattern is *
+;;;
+;;; The specific language is:
+;;; "The use of method group specifiers provides a convenient syntax to select 
+;;; methods, to divide them among the possible roles, and to perform the 
+;;; necessary error checking. It is possible to perform further filtering of 
+;;; methods in the body forms by using normal list-processing operations and 
+;;; the functions method-qualifiers and invalid-method-error. It is permissible
+;;; to use setq on the variables named in the method group specifiers and to 
+;;; bind additional variables. It is also possible to bypass the method group
+;;; specifier mechanism and do everything in the body forms. This is 
+;;; accomplished by writing a single method group with * as its only 
+;;; qualifier-pattern; the variable is then bound to a list of all of the 
+;;; applicable methods, in most-specific-first order."
+(define-method-combination wam-test-method-combination-a ()
+  ((all-methods *))
+  (do ((methods all-methods (rest methods))
+       (primary nil)
+       (around nil))
+      ((null methods)
+       (let ((primary (nreverse primary))
+	     (around (nreverse around)))
+	 (if primary
+	      (let ((form (if (rest primary)
+			     `(call-method ,(first primary) ,(rest primary))
+			     `(call-method ,(first primary)))))
+		(if around
+		    `(call-method ,(first around) (,@(rest around)
+						   (make-method ,form)))
+		    form))
+	      `(make-method (error "No primary methods")))))
+    (let* ((method (first methods))
+	   (qualifier (first (method-qualifiers method))))
+      (cond
+	((equal :around qualifier)
+	 (push method around))
+	((null qualifier)
+	 (push method primary))))))
+
+(defgeneric wam-test-mc-a (val)
+  (:method-combination wam-test-method-combination-a))
+(assert (raises-error? (wam-test-mc-a 13)))
+(defmethod wam-test-mc-a ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-a 13) 13))
+(defmethod wam-test-mc-a :around ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-a 13) 26))
+
+;;; DEFINE-METHOD-COMBINATION 
+;;; When two methods are in the same method group and have the same 
+;;; specializers, their sort order within the group may be ambiguous. Therefore,
+;;; we should throw an error when we have two methods in the same group with
+;;; the same specializers /as long as/ we have more than one method group
+;;; or our single method group qualifier-pattern is not *. This resolves the
+;;; apparent conflict with the above 'It is also possible to bypass' language.
+;;;
+;;; The language specifying this behavior is:
+;;; "Note that two methods with identical specializers, but with different 
+;;; qualifiers, are not ordered by the algorithm described in Step 2 of the 
+;;; method selection and combination process described in Section 7.6.6 
+;;; (Method Selection and Combination). Normally the two methods play different
+;;; roles in the effective method because they have different qualifiers, and 
+;;; no matter how they are ordered in the result of Step 2, the effective 
+;;; method is the same. If the two methods play the same role and their order 
+;;; matters, an error is signaled. This happens as part of the qualifier 
+;;; pattern matching in define-method-combination."
+;;;
+;;; Note that the spec pretty much equates 'method group' and 'role'.
+;; First we ensure that it fails correctly when there is more than one
+;; method group
+(define-method-combination wam-test-method-combination-b ()
+  ((around (:around))
+   (primary * :required t))
+  (let ((form (if (rest primary)
+		  `(call-method ,(first primary) ,(rest primary))
+		  `(call-method ,(first primary)))))
+    (if around
+	`(call-method ,(first around) (,@(rest around)
+				       (make-method ,form)))
+	form)))
+
+(defgeneric wam-test-mc-b (val)
+  (:method-combination wam-test-method-combination-b))
+(defmethod wam-test-mc-b ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-b 13) 13))
+(defmethod wam-test-mc-b :around ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-b 13) 26))
+(defmethod wam-test-mc-b :somethingelse ((val number)) 
+  (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (raises-error? (wam-test-mc-b 13)))
+
+;;; now, ensure that it fails with a single group with a qualifier-pattern
+;;; that is not *
+(define-method-combination wam-test-method-combination-c ()
+  ((methods listp :required t))
+  (if (rest methods)
+      `(call-method ,(first methods) ,(rest methods))
+      `(call-method ,(first methods))))
+
+(defgeneric wam-test-mc-c (val)
+  (:method-combination wam-test-method-combination-c))
+(assert (raises-error? (wam-test-mc-c 13)))
+(defmethod wam-test-mc-c :foo ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-c 13) 13))
+(defmethod wam-test-mc-c :bar ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (raises-error? (wam-test-mc-c 13)))
+
 ;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is
 ;;; given:
 (defmethod incompatible-ll-test-1 (x) x)
@@ -905,11 +1019,155 @@
 		     (method-for-defined-classes #\3))
 		   "3")))
 
+
+
+;;; When class definition does not complete due to a bad accessor
+;;; name, do not cause an error when a new accessor name is provided
+;;; during class redefinition
+
+(defun existing-name (object)
+  (list object))
+
+(assert (raises-error? (defclass redefinition-of-accessor-class ()
+                         ((slot :accessor existing-name)))))
+
+(defclass redefinition-of-accessor-class ()
+  ((slot :accessor new-name)))
+
+
+
 (load "package-ctor-bug.lisp")
 (assert (= (package-ctor-bug:test) 3))
 (delete-package "PACKAGE-CTOR-BUG")
 (load "package-ctor-bug.lisp")
 (assert (= (package-ctor-bug:test) 3))
 
+(deftype defined-type () 'integer)
+(assert (raises-error?
+         (defmethod method-on-defined-type ((x defined-type)) x)))
+(deftype defined-type-and-class () 'integer)
+(setf (find-class 'defined-type-and-class) (find-class 'integer))
+(defmethod method-on-defined-type-and-class ((x defined-type-and-class))
+  (1+ x))
+(assert (= (method-on-defined-type-and-class 3) 4))
+
+;; bug 281
+(let ((sb-pcl::*max-emf-precomputation-methods* 0))
+  (eval '(defgeneric bug-281 (x)
+	  (:method-combination +)
+	  (:method ((x symbol)) 1)
+	  (:method + ((x number)) x)))
+  (assert (= 1 (bug-281 1)))
+  (assert (= 4.2 (bug-281 4.2)))
+  (multiple-value-bind (val err) (ignore-errors (bug-281 'symbol))
+    (assert (not val))
+    (assert (typep err 'error))))
+
+;;; RESTART-CASE and CALL-METHOD
+
+;;; from Bruno Haible
+
+(defun rc-cm/prompt-for-new-values ()
+  (format *debug-io* "~&New values: ")
+  (finish-output *debug-io*)
+  (list (read *debug-io*)))
+
+(defun rc-cm/add-method-restarts (form method)
+  (let ((block (gensym))
+	(tag (gensym)))
+    `(block ,block
+      (tagbody
+	 ,tag
+	 (return-from ,block
+	   (restart-case ,form
+	     (method-redo ()
+	       :report (lambda (stream)
+			 (format stream "Try calling ~S again." ,method))
+	       (go ,tag))
+	     (method-return (l)
+	       :report (lambda (stream)
+			 (format stream "Specify return values for ~S call."
+				 ,method))
+	       :interactive (lambda () (rc-cm/prompt-for-new-values))
+	       (return-from ,block (values-list l)))))))))
+
+(defun rc-cm/convert-effective-method (efm)
+  (if (consp efm)
+      (if (eq (car efm) 'call-method)
+	  (let ((method-list (third efm)))
+	    (if (or (typep (first method-list) 'method) (rest method-list))
+		;; Reduce the case of multiple methods to a single one.
+		;; Make the call to the next-method explicit.
+		(rc-cm/convert-effective-method
+		 `(call-method ,(second efm)
+		   ((make-method
+		     (call-method ,(first method-list) ,(rest method-list))))))
+		;; Now the case of at most one method.
+		(if (typep (second efm) 'method)
+		    ;; Wrap the method call in a RESTART-CASE.
+		    (rc-cm/add-method-restarts
+		     (cons (rc-cm/convert-effective-method (car efm))
+			   (rc-cm/convert-effective-method (cdr efm)))
+		     (second efm))
+		    ;; Normal recursive processing.
+		    (cons (rc-cm/convert-effective-method (car efm))
+			  (rc-cm/convert-effective-method (cdr efm))))))
+	  (cons (rc-cm/convert-effective-method (car efm))
+		(rc-cm/convert-effective-method (cdr efm))))
+      efm))
+
+(define-method-combination standard-with-restarts ()
+  ((around (:around))
+   (before (:before))
+   (primary () :required t)
+   (after (:after)))
+  (flet ((call-methods-sequentially (methods)
+	   (mapcar #'(lambda (method)
+		       `(call-method ,method))
+		   methods)))
+    (let ((form (if (or before after (rest primary))
+                    `(multiple-value-prog1
+                       (progn
+                         ,@(call-methods-sequentially before)
+                         (call-method ,(first primary) ,(rest primary)))
+		      ,@(call-methods-sequentially (reverse after)))
+                    `(call-method ,(first primary)))))
+      (when around
+	(setq form
+	      `(call-method ,(first around)
+		(,@(rest around) (make-method ,form)))))
+      (rc-cm/convert-effective-method form))))
+
+(defgeneric rc-cm/testgf16 (x)
+  (:method-combination standard-with-restarts))
+(defclass rc-cm/testclass16a () ())
+(defclass rc-cm/testclass16b (rc-cm/testclass16a) ())
+(defclass rc-cm/testclass16c (rc-cm/testclass16a) ())
+(defclass rc-cm/testclass16d (rc-cm/testclass16b rc-cm/testclass16c) ())
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16a))
+  (list 'a
+        (not (null (find-restart 'method-redo)))
+        (not (null (find-restart 'method-return)))))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16b))
+  (cons 'b (call-next-method)))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16c))
+  (cons 'c (call-next-method)))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16d))
+  (cons 'd (call-next-method)))
+(assert (equal (rc-cm/testgf16 (make-instance 'rc-cm/testclass16d))
+	       '(d b c a t t)))
+
+;;; test case from Gerd Moellmann
+(define-method-combination r-c/c-m-1 ()
+  ((primary () :required t))
+  `(restart-case (call-method ,(first primary))
+     ()))
+
+(defgeneric r-c/c-m-1-gf ()
+  (:method-combination r-c/c-m-1)
+  (:method () nil))
+
+(assert (null (r-c/c-m-1-gf)))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)