X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=1e705908039c34a6aad313334b7e4b3d2e9e3b64;hb=3bbbfec26f90bc005c2ff5c8de0ceb0f95f1a52b;hp=b1dd8c7392eac7ca305b863d39e79a9eadcbf8c7;hpb=138ba28006d97560d270d8da3cf3c99012e9053d;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index b1dd8c7..1e70590 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -115,7 +115,7 @@
 (defgeneric born-to-be-redefined (x))
 (assert (eq (born-to-be-redefined 1) 'int))
 
-;;; in the removal of ITERATE from SB-PCL, a bug was introduced
+;;; In the removal of ITERATE from SB-PCL, a bug was introduced
 ;;; preventing forward-references and also change-class (which
 ;;; forward-references used interally) from working properly.  One
 ;;; symptom was reported by Brian Spilsbury (sbcl-devel 2002-04-08),
@@ -130,7 +130,6 @@
   ((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
@@ -139,6 +138,79 @@
     (assert (= (a-slot bar) 1))
     (assert (= (b-slot bar) 2))
     (assert (= (c-slot bar) 3))))
+
+;;; some more CHANGE-CLASS testing, now that we have an ANSI-compliant
+;;; version (thanks to Espen Johnsen)
+(defclass from-class ()
+  ((foo :initarg :foo :accessor foo)))
+(defclass to-class ()
+  ((foo :initarg :foo :accessor foo)
+   (bar :initarg :bar :accessor bar)))
+(let* ((from (make-instance 'from-class :foo 1))
+       (to (change-class from 'to-class :bar 2)))
+  (assert (= (foo to) 1))
+  (assert (= (bar to) 2)))
+
+;;; Until Pierre Mai's patch (sbcl-devel 2002-06-18, merged in
+;;; sbcl-0.7.4.39) the :MOST-SPECIFIC-LAST option had no effect.
+(defgeneric bug180 ((x t))
+  (:method-combination list :most-specific-last))
+(defmethod bug180 list ((x number))
+  'number)
+(defmethod bug180 list ((x fixnum))
+  'fixnum)
+(assert (equal (bug180 14) '(number fixnum)))
+
+;;; printing a structure class should not loop indefinitely (or cause
+;;; a stack overflow):
+(defclass test-printing-structure-class ()
+  ((slot :initarg :slot))
+  (:metaclass structure-class))
+(print (make-instance 'test-printing-structure-class :slot 2))
+
+;;; structure-classes should behave nicely when subclassed
+(defclass super-structure ()
+  ((a :initarg :a :accessor a-accessor)
+   (b :initform 2 :reader b-reader))
+  (:metaclass structure-class))
+(defclass sub-structure (super-structure)
+  ((c :initarg :c :writer c-writer :accessor c-accessor))
+  (:metaclass structure-class))
+(let ((foo (make-instance 'sub-structure :a 1 :c 3)))
+  (assert (= (a-accessor foo) 1))
+  (assert (= (b-reader foo) 2))
+  (assert (= (c-accessor foo) 3))
+  (setf (a-accessor foo) 4)
+  (c-writer 5 foo)
+  (assert (= (a-accessor foo) 4))
+  (assert (= (c-accessor foo) 5)))
+
+;;; At least as of sbcl-0.7.4, PCL has code to support a special
+;;; encoding of effective method functions for slot accessors as
+;;; FIXNUMs. Given this special casing, it'd be easy for slot accessor
+;;; functions to get broken in special ways even though ordinary
+;;; generic functions work. As of sbcl-0.7.4 we didn't have any tests
+;;; for that possibility. Now we have a few tests:
+(defclass fish ()
+  ((fin :reader ffin :writer ffin!)
+   (tail :reader ftail :writer ftail!)))
+(defvar *fish* (make-instance 'fish))
+(ffin! 'triangular-fin *fish*)
+(defclass cod (fish) ())
+(defvar *cod* (make-instance 'cod))
+(defparameter *clos-dispatch-side-fx* (make-array 0 :fill-pointer 0))
+(defmethod ffin! (new-fin (cod cod))
+  (format t "~&about to set ~S fin to ~S~%" cod new-fin)
+  (vector-push-extend '(cod) *clos-dispatch-side-fx*)
+  (prog1
+      (call-next-method)
+    (format t "~&done setting ~S fin to ~S~%" cod new-fin)))
+(defmethod ffin! :before (new-fin (cod cod))
+  (vector-push-extend '(:before cod) *clos-dispatch-side-fx*)
+  (format t "~&exploring the CLOS dispatch zoo with COD fins~%"))
+(ffin! 'almost-triang-fin *cod*)
+(assert (eq (ffin *cod*) 'almost-triang-fin))
+(assert (equalp #((:before cod) (cod)) *clos-dispatch-side-fx*))
 
 ;;;; success