X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=0bef77fa961138a5db9da3a5421830edc26600d9;hb=bb1ead258cdbd5cbd0fe25e16cb6a201873b630b;hp=d04a4c0376e935726e4183d0fd8b13f74eeca197;hpb=f06adcc6e3ce995dd9612de86355eebcc63bd0c6;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index d04a4c0..0bef77f 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -11,8 +11,6 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
-(load "assertoid.lisp")
-
 (defpackage "CLOS-IMPURE"
   (:use "CL" "ASSERTOID" "TEST-UTIL"))
 (in-package "CLOS-IMPURE")
@@ -654,6 +652,7 @@
 (assert (= (bug222 t) 1))
 
 ;;; also, a test case to guard against bogus environment hacking:
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (setq bug222-b 3))
 ;;; this should at the least compile:
@@ -664,8 +663,10 @@
 ;;; and it would be nice (though not specified by ANSI) if the answer
 ;;; were as follows:
 (let ((x (make-string-output-stream)))
-  ;; not specified by ANSI
-  (assert (= (bug222-b t x) 3))
+  (let ((value (bug222-b t x)))
+    ;; not specified by ANSI
+    #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
+    (assert (= value 3)))
   ;; specified.
   (assert (char= (char (get-output-stream-string x) 0) #\1)))
 
@@ -1064,14 +1065,18 @@
 (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))
+(with-test (:name (:defmethod (setf find-class) integer))
+  (mapcar #'eval
+          '(
+            (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))
@@ -1280,5 +1285,120 @@
                   (slot-value test 'x))))
   (assert (= 13 (slot-value test 'x))))
 
+;;; Using class instances as specializers, reported by Pascal Costanza, ref CLHS 7.6.2
+(defclass class-as-specializer-test ()
+   ())
+(eval `(defmethod class-as-specializer-test1 ((x ,(find-class 'class-as-specializer-test)))
+          'foo))
+(assert (eq 'foo (class-as-specializer-test1 (make-instance 'class-as-specializer-test))))
+(funcall (compile nil `(lambda ()
+                         (defmethod class-as-specializer-test2 ((x ,(find-class 'class-as-specializer-test)))
+                           'bar))))
+(assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test))))
+
+;;; CHANGE-CLASS and tricky allocation.
+(defclass foo-to-be-changed ()
+  ((a :allocation :class :initform 1)))
+(defclass bar-to-be-changed (foo-to-be-changed) ())
+(defvar *bar-to-be-changed* (make-instance 'bar-to-be-changed))
+(defclass baz-to-be-changed ()
+  ((a :allocation :instance :initform 2)))
+(change-class *bar-to-be-changed* 'baz-to-be-changed)
+(assert (= (slot-value *bar-to-be-changed* 'a) 1))
+
+;;; proper name and class redefinition
+(defvar *to-be-renamed1* (defclass to-be-renamed1 () ()))
+(defvar *to-be-renamed2* (defclass to-be-renamed2 () ()))
+(setf (find-class 'to-be-renamed1) (find-class 'to-be-renamed2))
+(defvar *renamed1* (defclass to-be-renamed1 () ()))
+(assert (not (eq *to-be-renamed1* *to-be-renamed2*)))
+(assert (not (eq *to-be-renamed1* *renamed1*)))
+(assert (not (eq *to-be-renamed2* *renamed1*)))
+
+;;; CLASS-NAME (and various other standardized generic functions) have
+;;; their effective methods precomputed; in the process of rearranging
+;;; (SETF FIND-CLASS) and FINALIZE-INHERITANCE, this broke.
+(defclass class-with-odd-class-name-method ()
+  ((a :accessor class-name)))
+
+;;; another case where precomputing (this time on PRINT-OBJET) and
+;;; lazily-finalized classes caused problems.  (report from James Y
+;;; Knight sbcl-devel 20-07-2006)
+
+(defclass base-print-object () ())
+;;; this has the side-effect of finalizing BASE-PRINT-OBJECT, and
+;;; additionally the second specializer (STREAM) changes the cache
+;;; structure to require two keys, not just one.
+(defmethod print-object ((o base-print-object) (s stream))
+  nil)
+
+;;; unfinalized as yet
+(defclass sub-print-object (base-print-object) ())
+;;; the accessor causes an eager finalization
+(defclass subsub-print-object (sub-print-object)
+  ((a :accessor a)))
+
+;;; triggers a discriminating function (and so cache) recomputation.
+;;; The method on BASE-PRINT-OBJECT will cause the system to attempt
+;;; to fill the cache for all subclasses of BASE-PRINT-OBJECT which
+;;; have valid wrappers; however, in the course of doing so, the
+;;; SUB-PRINT-OBJECT class gets finalized, which invalidates the
+;;; SUBSUB-PRINT-OBJECT wrapper; if an invalid wrapper gets into a
+;;; cache with more than one key, then failure ensues.
+(reinitialize-instance #'print-object)
+
+;;; bug in long-form method combination: if there's an applicable
+;;; method not part of any method group, we need to call
+;;; INVALID-METHOD-ERROR.  (MC27 test case from Bruno Haible)
+(define-method-combination mc27 ()
+  ((normal ())
+   (ignored (:ignore :unused)))
+  `(list 'result
+    ,@(mapcar #'(lambda (method) `(call-method ,method)) normal)))
+(defgeneric test-mc27 (x)
+  (:method-combination mc27)
+  (:method :ignore ((x number)) (/ 0)))
+(assert (raises-error? (test-mc27 7)))
+
+(define-method-combination mc27prime ()
+  ((normal ())
+   (ignored (:ignore)))
+  `(list 'result ,@(mapcar (lambda (m) `(call-method ,m)) normal)))
+(defgeneric test-mc27prime (x)
+  (:method-combination mc27prime)
+  (:method :ignore ((x number)) (/ 0)))
+(assert (equal '(result) (test-mc27prime 3)))
+(assert (raises-error? (test-mc27 t))) ; still no-applicable-method
+
+;;; more invalid wrappers.  This time for a long-standing bug in the
+;;; compiler's expansion for TYPEP on various class-like things, with
+;;; user-visible consequences.
+(defclass obsolete-again () ())
+(defvar *obsolete-again* (make-instance 'obsolete-again))
+(defvar *obsolete-again-hash* (sxhash *obsolete-again*))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (streamp *obsolete-again*)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (= (sxhash *obsolete-again*) *obsolete-again-hash*))
+(compile (defun is-a-structure-object-p (x) (typep x 'structure-object)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (is-a-structure-object-p *obsolete-again*)))
+
+;;; overeager optimization of slot-valuish things
+(defclass listoid ()
+  ((caroid :initarg :caroid)
+   (cdroid :initarg :cdroid :initform nil)))
+(defmethod lengthoid ((x listoid))
+  (let ((result 0))
+    (loop until (null x)
+          do (incf result) (setq x (slot-value x 'cdroid)))
+    result))
+(with-test (:name ((:setq :method-parameter) slot-value))
+  (assert (= (lengthoid (make-instance 'listoid)) 1))
+  (assert (= (lengthoid
+              (make-instance 'listoid :cdroid
+                             (make-instance 'listoid :cdroid
+                                            (make-instance 'listoid))))
+             3)))
 
 ;;;; success