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

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 28ab7ae..dfcb369 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -191,6 +191,7 @@
   ((a-slot :initarg :a-slot :accessor a-slot)
    (b-slot :initarg :b-slot :accessor b-slot)
    (c-slot :initarg :c-slot :accessor c-slot)))
+
 (let ((foo (make-instance 'class-with-slots
 			  :a-slot 1
 			  :b-slot 2
@@ -292,8 +293,8 @@
 (macrolet ((assert-program-error (form)
 	     `(multiple-value-bind (value error)
 	          (ignore-errors ,form)
-	        (assert (null value))
-	        (assert (typep error 'program-error)))))
+	        (unless (and (null value) (typep error 'program-error))
+                  (error "~S failed: ~S, ~S" ',form value error)))))
   (assert-program-error (defclass foo001 () (a b a)))
   (assert-program-error (defclass foo002 () 
 			  (a b) 
@@ -433,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)
@@ -450,8 +565,19 @@
 (defmethod incompatible-ll-test-2 ((x integer) &key bar) bar)
 (assert (= (length
 	    (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2))
-(assert (equal (incompatible-ll-test-2 t 1 2) '(1 2)))
+
+;;; Per Christophe, this is an illegal method call because of 7.6.5
+(assert (raises-error? (incompatible-ll-test-2 t 1 2)))
+
 (assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes))
+
+(defmethod incompatible-ll-test-3 ((x integer)) x)
+(remove-method #'incompatible-ll-test-3
+               (find-method #'incompatible-ll-test-3
+                            nil
+                            (list (find-class 'integer))))
+(assert (raises-error? (defmethod incompatible-ll-test-3 (x y) (list x y))))
+
 
 ;;; Attempting to instantiate classes with forward references in their
 ;;; CPL should signal errors (FIXME: of what type?)
@@ -820,6 +946,228 @@
   (setf x (/ x 2))
   x)
 (assert (= (fum 3) 3/2))
+(defmethod fii ((x fixnum))
+  (declare (special x))
+  (setf x (/ x 2))
+  x)
+(assert (= (fii 1) 1/2))
+(defvar *faa*)
+(defmethod faa ((*faa* string-stream))
+  (setq *faa* (make-broadcast-stream *faa*))
+  (write-line "Break, you sucker!" *faa*)
+  'ok)
+(assert (eq 'ok (faa (make-string-output-stream))))
+(defmethod fex ((x fixnum) (y fixnum))
+  (multiple-value-setq (x y) (values (/ x y) (/ y x)))
+  (list x y))
+(assert (equal (fex 5 3) '(5/3 3/5)))
+
+;;; Bug reported by Zach Beane; incorrect return of (function
+;;; ',fun-name) in defgeneric
+(assert
+ (typep (funcall (compile nil
+                          '(lambda () (flet ((nonsense () nil))
+                                        (defgeneric nonsense ())))))
+        'generic-function))
+
+(assert
+ (typep (funcall (compile nil
+                          '(lambda () (flet ((nonsense-2 () nil))
+                                        (defgeneric nonsense-2 ()
+                                          (:method () t))))))
+        'generic-function))
+
+;;; bug reported by Bruno Haible: (setf find-class) using a
+;;; forward-referenced class
+(defclass fr-sub (fr-super) ())
+(setf (find-class 'fr-alt) (find-class 'fr-super))
+(assert (eq (find-class 'fr-alt) (find-class 'fr-super)))
+
+
+;;; ANSI Figure 4-8: all defined classes.  Check that we can define
+;;; methods on all of these.
+(progn
+  (defgeneric method-for-defined-classes (x))
+  (dolist (c '(arithmetic-error 
+	       generic-function simple-error array hash-table 
+	       simple-type-error 
+	       bit-vector integer simple-warning             
+	       broadcast-stream list standard-class             
+	       built-in-class logical-pathname standard-generic-function  
+	       cell-error method standard-method            
+	       character method-combination standard-object            
+	       class null storage-condition          
+	       complex number stream                     
+	       concatenated-stream package stream-error               
+	       condition package-error string                     
+	       cons parse-error string-stream              
+	       control-error pathname structure-class            
+	       division-by-zero print-not-readable structure-object           
+	       echo-stream program-error style-warning              
+	       end-of-file random-state symbol                     
+	       error ratio synonym-stream             
+	       file-error rational t                          
+	       file-stream reader-error two-way-stream             
+	       float readtable type-error                 
+	       floating-point-inexact real unbound-slot               
+	       floating-point-invalid-operation restart unbound-variable
+	       floating-point-overflow sequence undefined-function 
+	       floating-point-underflow serious-condition vector 
+	       function simple-condition warning))
+    (eval `(defmethod method-for-defined-classes ((x ,c)) (princ x))))
+  (assert (string= (with-output-to-string (*standard-output*)
+		     (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)