Declare types of *MACHINE-VERSION*, *{SHORT,LONG}-SITE-NAME*, *ED-FUNCTIONS*
[sbcl.git] / tests / clos-1.impure.lisp
blobf3e9d338552c29f0e8d20078702abe8fc3dcf681
1 ;;;; miscellaneous side-effectful tests of CLOS
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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")
18 (defpackage "CLOS-1"
19 (:use "CL" "ASSERTOID" "TEST-UTIL"))
21 ;;; tests that various optimization paths for slot-valuish things
22 ;;; respect class redefinitions.
23 (defclass foo ()
24 ((a :initarg :a)))
26 (defvar *foo* (make-instance 'foo :a 1))
28 (defmethod a-of ((x foo))
29 (slot-value x 'a))
30 (defmethod b-of ((x foo))
31 (slot-value x 'b))
32 (defmethod c-of ((x foo))
33 (slot-value x 'c))
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-error (b-of *foo*))
41 (assert-error (c-of *foo*))))
43 (defclass 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-error (c-of *foo*))))
54 (defclass foo ()
55 ((c :initarg :c :initform t :allocation :class)
56 (b :initarg :b :initform 3)
57 (a :initarg :a)))
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*)))))
67 (defclass foo ()
68 ((a :initarg :a)
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*)))))
80 (defclass 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-error (slot-value *foo* 'a))
86 (assert-error (a-of *foo*))
87 (assert-error (funcall fun *foo*))
88 (assert (= 3 (b-of *foo*)))
89 (assert-error (c-of *foo*))))
91 ;;; test that :documentation argument to slot specifiers are used as
92 ;;; the docstrings of accessor methods.
93 (defclass foo ()
94 ((a :reader a-of :documentation "docstring for A")
95 (b :writer set-b-of :documentation "docstring for B")
96 (c :accessor c :documentation "docstring for C")))
98 (flet ((doc (fun)
99 (documentation fun t)))
100 (assert (string= (doc (find-method #'a-of nil '(foo))) "docstring for A"))
101 (assert (string= (doc (find-method #'set-b-of nil '(t foo))) "docstring for B"))
102 (assert (string= (doc (find-method #'c nil '(foo))) "docstring for C"))
103 (assert (string= (doc (find-method #'(setf c) nil '(t foo))) "docstring for C")))
105 ;;; some nasty tests of NO-NEXT-METHOD.
106 (defvar *method-with-no-next-method*)
107 (defvar *nnm-count* 0)
108 (defun make-nnm-tester (x)
109 (setq *method-with-no-next-method* (defmethod nnm-tester ((y (eql x))) (call-next-method))))
110 (make-nnm-tester 1)
111 (defmethod no-next-method ((gf (eql #'nnm-tester)) method &rest args)
112 (declare (ignore args))
113 (assert (eql method *method-with-no-next-method*))
114 (incf *nnm-count*))
115 (with-test (:name (no-next-method :unknown-specializer))
116 (nnm-tester 1)
117 (assert (= *nnm-count* 1)))
118 (let ((gf #'nnm-tester))
119 (reinitialize-instance gf :name 'new-nnm-tester)
120 (setf (fdefinition 'new-nnm-tester) gf))
121 (with-test (:name (no-next-method :gf-name-changed))
122 (new-nnm-tester 1)
123 (assert (= *nnm-count* 2)))
125 ;;; Tests the compiler's incremental rejiggering of GF types.
126 (fmakunbound 'foo)
127 (with-test (:name :keywords-supplied-in-methods-ok-1)
128 (assert
129 (null
130 (nth-value
132 (progn
133 (defgeneric foo (x &key))
134 (defmethod foo ((x integer) &key bar) (list x bar))
135 (compile nil '(lambda () (foo (read) :bar 10))))))))
137 (fmakunbound 'foo)
138 (with-test (:name :keywords-supplied-in-methods-ok-2)
139 (assert
140 (nth-value
142 (progn
143 (defgeneric foo (x &key))
144 (defmethod foo ((x integer) &key bar) (list x bar))
145 ;; On second thought...
146 (remove-method #'foo (find-method #'foo () '(integer)))
147 (compile nil '(lambda () (foo (read) :bar 10)))))))
149 ;; If the GF has &REST with no &KEY, not all methods are required to
150 ;; parse the tail of the arglist as keywords, so we don't treat the
151 ;; function type as having &KEY in it.
152 (fmakunbound 'foo)
153 (with-test (:name :gf-rest-method-key)
154 (defgeneric foo (x &rest y))
155 (defmethod foo ((i integer) &key w) (list i w))
156 ;; 1.0.20.30 failed here.
157 (assert
158 (null (nth-value 1 (compile nil '(lambda () (foo 5 :w 10 :foo 15))))))
159 (assert
160 (not (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo)))))
162 ;; If the GF has &KEY and &ALLOW-OTHER-KEYS, the methods' keys can be
163 ;; anything, and we don't warn about unrecognized keys.
164 (fmakunbound 'foo)
165 (with-test (:name :gf-allow-other-keys)
166 (defgeneric foo (x &key &allow-other-keys))
167 (defmethod foo ((i integer) &key y z) (list i y z))
168 ;; Correctness of a GF's ftype was previously ensured by the compiler,
169 ;; and only if a lambda was compiled that referenced the GF, in a way
170 ;; that was just barely non-broken enough to make the compiler happy.
171 ;; Now the FTYPE is computed the instant anyone asks for it.
172 (assert (equal (mapcar 'sb-kernel:key-info-name
173 (sb-kernel:fun-type-keywords
174 (sb-int:proclaimed-ftype 'foo)))
175 '(:y :z)))
176 (assert
177 (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :y 15))))))
178 (assert
179 (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :foo 15))))))
180 (assert
181 (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo)))
182 (assert
183 (sb-kernel::args-type-allowp (sb-int:proclaimed-ftype 'foo))))
185 ;; If any method has &ALLOW-OTHER-KEYS, 7.6.4 point 5 seems to say the
186 ;; GF should be construed to have &ALLOW-OTHER-KEYS.
187 (fmakunbound 'foo)
188 (with-test (:name :method-allow-other-keys)
189 (defgeneric foo (x &key))
190 (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y))
191 (assert (null (nth-value 1 (compile nil '(lambda () (foo 10 :foo 20))))))
192 (assert (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo)))
193 (assert (sb-kernel::args-type-allowp (sb-int:proclaimed-ftype 'foo))))
195 (fmakunbound 'foo)
196 (with-test (:name (defmethod symbol-macrolet))
197 (symbol-macrolet ((cnm (call-next-method)))
198 (defmethod foo ((x number)) (1+ cnm)))
199 (defmethod foo ((x t)) 3)
200 (assert (= (foo t) 3))
201 (assert (= (foo 3) 4)))
203 (fmakunbound 'foo)
204 (define-symbol-macro magic-cnm (call-next-method))
205 (with-test (:name (defmethod define-symbol-macro))
206 (defmethod foo ((x number)) (1- magic-cnm))
207 (defmethod foo ((x t)) 3)
208 (assert (= (foo t) 3))
209 (assert (= (foo 3) 2)))