X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=05b8f8713e86f49b1c340a08eb0d4ca6254f6bd5;hb=4a4da2875171c4802af72defcb71d720e8fa8093;hp=405a219ad43c8b8dbdd40a3e5b41d9a9d2c34c22;hpb=28b4b70473ad927acb2aee6d3a8cb3f107b02864;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 405a219..05b8f87 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?)
@@ -683,5 +809,259 @@
   (list x y))
 (assert (equal (bug262 1 2) '(1 2)))
 
+;;; salex on #lisp 2003-10-13 reported that type declarations inside
+;;; WITH-SLOTS are too hairy to be checked
+(defun ensure-no-notes (form)
+  (handler-case (compile nil `(lambda () ,form))
+    (sb-ext:compiler-note (c)
+      ;; FIXME: it would be better to check specifically for the "type
+      ;; is too hairy" note
+      (error c))))
+(defvar *x*)
+(ensure-no-notes '(with-slots (a) *x*
+                   (declare (integer a))
+                   a))
+(ensure-no-notes '(with-slots (a) *x*
+                   (declare (integer a))
+                   (declare (notinline slot-value))
+                   a))
+
+;;; from CLHS 7.6.5.1
+(defclass character-class () ((char :initarg :char)))
+(defclass picture-class () ((glyph :initarg :glyph)))
+(defclass character-picture-class (character-class picture-class) ())
+
+(defmethod width ((c character-class) &key font) font)
+(defmethod width ((p picture-class) &key pixel-size) pixel-size)
+
+(assert (raises-error? 
+	 (width (make-instance 'character-class :char #\Q) 
+		:font 'baskerville :pixel-size 10)
+	 program-error))
+(assert (raises-error?
+	 (width (make-instance 'picture-class :glyph #\Q)
+		:font 'baskerville :pixel-size 10)
+	 program-error))
+(assert (eq (width (make-instance 'character-picture-class :char #\Q)
+		   :font 'baskerville :pixel-size 10)
+	    'baskerville))
+
+;;; class redefinition shouldn't give any warnings, in the usual case
+(defclass about-to-be-redefined () ((some-slot :accessor some-slot)))
+(handler-bind ((warning #'error))
+  (defclass about-to-be-redefined () ((some-slot :accessor some-slot))))
+
+;;; attempts to add accessorish methods to generic functions with more
+;;; complex lambda lists should fail
+(defgeneric accessoroid (object &key &allow-other-keys))
+(assert (raises-error?
+	 (defclass accessoroid-class () ((slot :accessor accessoroid)))
+	 program-error))
+
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass shared-slot-and-redefinition ()
+  ((size :initarg :size :initform 1 :allocation :class)))
+(let ((i (make-instance 'shared-slot-and-redefinition)))
+  (defclass shared-slot-and-redefinition ()
+    ((size :initarg :size :initform 2 :allocation :class)))
+  (assert (= (slot-value i 'size) 1)))
+
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass superclass-born-to-be-obsoleted () (a))
+(defclass subclass-born-to-be-obsoleted (superclass-born-to-be-obsoleted) ())
+(defparameter *born-to-be-obsoleted*
+  (make-instance 'subclass-born-to-be-obsoleted))
+(defparameter *born-to-be-obsoleted-obsoleted* nil)
+(defmethod update-instance-for-redefined-class
+    ((o subclass-born-to-be-obsoleted) a d pl &key)
+  (setf *born-to-be-obsoleted-obsoleted* t))
+(make-instances-obsolete 'superclass-born-to-be-obsoleted)
+(slot-boundp *born-to-be-obsoleted* 'a)
+(assert *born-to-be-obsoleted-obsoleted*)
+
+;;; additional test suggested by Bruno Haible sbcl-devel 2004-04-21
+(defclass super-super-obsoleted () (a))
+(defclass super-obsoleted-1 (super-super-obsoleted) ())
+(defclass super-obsoleted-2 (super-super-obsoleted) ())
+(defclass obsoleted (super-obsoleted-1 super-obsoleted-2) ())
+(defparameter *obsoleted* (make-instance 'obsoleted))
+(defparameter *obsoleted-counter* 0)
+(defmethod update-instance-for-redefined-class ((o obsoleted) a d pl &key)
+  (incf *obsoleted-counter*))
+(make-instances-obsolete 'super-super-obsoleted)
+(slot-boundp *obsoleted* 'a)
+(assert (= *obsoleted-counter* 1))
+
+;;; shared -> local slot transfers of inherited slots, reported by
+;;; Bruno Haible
+(let (i)
+  (defclass super-with-magic-slot () 
+    ((magic :initarg :size :initform 1 :allocation :class)))
+  (defclass sub-of-super-with-magic-slot (super-with-magic-slot) ())
+  (setq i (make-instance 'sub-of-super-with-magic-slot))
+  (defclass super-with-magic-slot () 
+    ((magic :initarg :size :initform 2)))
+  (assert (= 1 (slot-value i 'magic))))
+
+;;; MAKE-INSTANCES-OBSOLETE return values
+(defclass one-more-to-obsolete () ())
+(assert (eq 'one-more-to-obsolete 
+	    (make-instances-obsolete 'one-more-to-obsolete)))
+(assert (eq (find-class 'one-more-to-obsolete) 
+	    (make-instances-obsolete (find-class 'one-more-to-obsolete))))
+
+;;; Sensible error instead of a BUG. Reported by Thomas Burdick.
+(multiple-value-bind (value err)
+    (ignore-errors
+      (defclass slot-def-with-duplicate-accessors ()
+	((slot :writer get-slot :reader get-slot))))
+  (assert (typep err 'error))
+  (assert (not (typep err 'sb-int:bug))))
+
+;;; BUG 321: errors in parsing DEFINE-METHOD-COMBINATION arguments
+;;; lambda lists.
+
+(define-method-combination w-args ()
+  ((method-list *))
+  (:arguments arg1 arg2 &aux (extra :extra))
+  `(progn ,@(mapcar (lambda (method) `(call-method ,method)) method-list)))
+(defgeneric mc-test-w-args (p1 p2 s)
+  (:method-combination w-args)
+  (:method ((p1 number) (p2 t) s)
+    (vector-push-extend (list 'number p1 p2) s))
+  (:method ((p1 string) (p2 t) s)
+    (vector-push-extend (list 'string p1 p2) s))
+  (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s)))
+(let ((v (make-array 0 :adjustable t :fill-pointer t)))
+  (assert (= (mc-test-w-args 1 2 v) 1))
+  (assert (equal (aref v 0) '(number 1 2)))
+  (assert (equal (aref v 1) '(t 1 2))))
+
+;;; BUG 276: declarations and mutation.
+(defmethod fee ((x fixnum))
+  (setq x (/ x 2))
+  x)
+(assert (= (fee 1) 1/2))
+(defmethod fum ((x fixnum))
+  (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))))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)