Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / tests / clos-1.impure.lisp
1 ;;;; miscellaneous side-effectful tests of CLOS
2
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.
13
14 ;;; clos.impure.lisp was getting too big and confusing
15
16 (load "assertoid.lisp")
17
18 (defpackage "CLOS-1"
19   (:use "CL" "ASSERTOID" "TEST-UTIL"))
20
21 ;;; tests that various optimization paths for slot-valuish things
22 ;;; respect class redefinitions.
23 (defclass foo ()
24   ((a :initarg :a)))
25
26 (defvar *foo* (make-instance 'foo :a 1))
27
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))
34
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*)))))
42
43 (defclass foo ()
44   ((b :initarg :b :initform 3) (a :initarg :a)))
45
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*)))))
53
54 (defclass foo ()
55   ((c :initarg :c :initform t :allocation :class)
56    (b :initarg :b :initform 3)
57    (a :initarg :a)))
58
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*)))))
66
67 (defclass foo ()
68   ((a :initarg :a)
69    (b :initarg :b :initform 3)
70    (c :initarg :c :initform t)))
71
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*)))))
79
80 (defclass foo ()
81   ((b :initarg :b :initform 3)))
82
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*)))))
90
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")))
97
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")))
104 \f
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   (assert (eql method *method-with-no-next-method*))
113   (incf *nnm-count*))
114 (with-test (:name (no-next-method :unknown-specializer))
115   (nnm-tester 1)
116   (assert (= *nnm-count* 1)))
117 (let ((gf #'nnm-tester))
118   (reinitialize-instance gf :name 'new-nnm-tester)
119   (setf (fdefinition 'new-nnm-tester) gf))
120 (with-test (:name (no-next-method :gf-name-changed))
121   (new-nnm-tester 1)
122   (assert (= *nnm-count* 2)))
123 \f
124 ;;; Tests the compiler's incremental rejiggering of GF types.
125 (fmakunbound 'foo)
126 (with-test (:name :keywords-supplied-in-methods-ok-1)
127   (assert
128    (null
129     (nth-value
130      1
131      (progn
132        (defgeneric foo (x &key))
133        (defmethod foo ((x integer) &key bar) (list x bar))
134        (compile nil '(lambda () (foo (read) :bar 10))))))))
135
136 (fmakunbound 'foo)
137 (with-test (:name :keywords-supplied-in-methods-ok-2)
138   (assert
139    (nth-value
140     1
141     (progn
142       (defgeneric foo (x &key))
143       (defmethod foo ((x integer) &key bar) (list x bar))
144       ;; On second thought...
145       (remove-method #'foo (find-method #'foo () '(integer)))
146       (compile nil '(lambda () (foo (read) :bar 10)))))))
147
148 ;; If the GF has &REST with no &KEY, not all methods are required to
149 ;; parse the tail of the arglist as keywords, so we don't treat the
150 ;; function type as having &KEY in it.
151 (fmakunbound 'foo)
152 (with-test (:name :gf-rest-method-key)
153   (defgeneric foo (x &rest y))
154   (defmethod foo ((i integer) &key w) (list i w))
155   ;; 1.0.20.30 failed here.
156   (assert
157    (null (nth-value 1 (compile nil '(lambda () (foo 5 :w 10 :foo 15))))))
158   (assert
159    (not (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo)))))
160
161 ;; If the GF has &KEY and &ALLOW-OTHER-KEYS, the methods' keys can be
162 ;; anything, and we don't warn about unrecognized keys.
163 (fmakunbound 'foo)
164 (with-test (:name :gf-allow-other-keys)
165   (defgeneric foo (x &key &allow-other-keys))
166   (defmethod foo ((i integer) &key y z) (list i y z))
167   (assert
168    (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :y 15))))))
169   (assert
170    (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :foo 15))))))
171   (assert
172    (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo)))
173   (assert
174    (sb-kernel::args-type-allowp (sb-c::info :function :type 'foo))))
175
176 ;; If any method has &ALLOW-OTHER-KEYS, 7.6.4 point 5 seems to say the
177 ;; GF should be construed to have &ALLOW-OTHER-KEYS.
178 (fmakunbound 'foo)
179 (with-test (:name :method-allow-other-keys)
180   (defgeneric foo (x &key))
181   (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y))
182   (assert (null (nth-value 1 (compile nil '(lambda () (foo 10 :foo 20))))))
183   (assert (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo)))
184   (assert (sb-kernel::args-type-allowp (sb-c::info :function :type 'foo))))
185
186