1 ;;;; miscellaneous side-effectful tests of CLOS
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 ;;; clos.impure.lisp was getting too big and confusing
16 (load "assertoid.lisp")
19 (:use "CL" "ASSERTOID" "TEST-UTIL"))
21 ;;; tests that various optimization paths for slot-valuish things
22 ;;; respect class redefinitions.
26 (defvar *foo* (make-instance 'foo :a 1))
28 (defmethod a-of ((x foo))
30 (defmethod b-of ((x foo))
32 (defmethod c-of ((x foo))
35 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
36 (dotimes (i 4) ; KLUDGE: get caches warm
37 (assert (= 1 (slot-value *foo* 'a)))
38 (assert (= 1 (a-of *foo*)))
39 (assert (= 1 (funcall fun *foo*)))
40 (assert (raises-error? (b-of *foo*)))
41 (assert (raises-error? (c-of *foo*)))))
44 ((b :initarg :b :initform 3) (a :initarg :a)))
46 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
47 (dotimes (i 4) ; KLUDGE: get caches warm
48 (assert (= 1 (slot-value *foo* 'a)))
49 (assert (= 1 (a-of *foo*)))
50 (assert (= 1 (funcall fun *foo*)))
51 (assert (= 3 (b-of *foo*)))
52 (assert (raises-error? (c-of *foo*)))))
55 ((c :initarg :c :initform t :allocation :class)
56 (b :initarg :b :initform 3)
59 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
60 (dotimes (i 4) ; KLUDGE: get caches warm
61 (assert (= 1 (slot-value *foo* 'a)))
62 (assert (= 1 (a-of *foo*)))
63 (assert (= 1 (funcall fun *foo*)))
64 (assert (= 3 (b-of *foo*)))
65 (assert (eq t (c-of *foo*)))))
69 (b :initarg :b :initform 3)
70 (c :initarg :c :initform t)))
72 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
73 (dotimes (i 4) ; KLUDGE: get caches warm
74 (assert (= 1 (slot-value *foo* 'a)))
75 (assert (= 1 (a-of *foo*)))
76 (assert (= 1 (funcall fun *foo*)))
77 (assert (= 3 (b-of *foo*)))
78 (assert (eq t (c-of *foo*)))))
81 ((b :initarg :b :initform 3)))
83 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
84 (dotimes (i 4) ; KLUDGE: get caches warm
85 (assert (raises-error? (slot-value *foo* 'a)))
86 (assert (raises-error? (a-of *foo*)))
87 (assert (raises-error? (funcall fun *foo*)))
88 (assert (= 3 (b-of *foo*)))
89 (assert (raises-error? (c-of *foo*)))))