source: trunk/tests/ansi-tests/ccl.lsp @ 9766

Last change on this file since 9766 was 9766, checked in by gz, 12 years ago

regression tests for bug #289 and the bogus too-many-arguments error

File size: 8.6 KB
Line 
1;;;-*-Mode: LISP; Package: CL-TEST -*-
2;;;
3;;;   Copyright (C) 2008 Clozure Associates
4
5(in-package :cl-test)
6
7(defun test-source-file (format-string &rest format-args)
8  (let ((file "temp.dat"))
9    (with-open-file (s file :direction :output :if-exists :supersede)
10      (apply #'format s format-string format-args)
11      (terpri s)
12      (truename s))))
13
14(defun test-compile (lambda-or-file &key suppress-warnings (safety 1) load)
15  ;; Compile in a more-or-less standard environment
16  (let ((ccl::*suppress-compiler-warnings* suppress-warnings)
17        (ccl::*nx-speed* 1)
18        (ccl::*nx-space* 1)
19        (ccl::*nx-safety* safety)
20        (ccl::*nx-cspeed* 1)
21        (ccl::*nx-debug* 1))
22    (if (consp lambda-or-file)
23      (compile nil lambda-or-file)
24      (compile-file lambda-or-file :load load))))
25
26;;; CCL-specific regression tests, for CCL-specific behavior.
27
28(deftest ccl.40199  ;; fixed in r9116 and r9121
29    (when (equalp (let ((*print-pretty* t))
30                    (format nil "~a" (make-array nil :initial-element 0)))
31                  "#0A0")
32      :good)
33  :good)
34
35(deftest ccl.40492 ;; fixed in r9134 and r9131
36    (let (obj (slot (gensym)))
37      (eval `(defclass ccl.40492 ()
38               ((,slot :accessor ,slot :initform :good))))
39      (setq obj (make-instance 'ccl.40492))
40      (ccl::%snap-reader-method (symbol-function slot))
41      (unwind-protect
42           (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output
43             (ccl:trace-function slot)
44             (funcall slot obj))
45        (eval `(untrace ,slot))))
46  :good)
47
48(deftest ccl.40207  ;; fixed in r9163 and r9165
49    ;; Check that these compile-time errors don't abort compilation.
50    (and (typep (lambda (x) (setq x)) 'function)
51         (typep (lambda (x) (setf x)) 'function)
52         (typep (lambda (((foo))) foo) 'function)
53         :good)
54  :good)
55
56(deftest ccl.40927  ;; fixed in r9183 and r9184
57    (let ((s (make-string-output-stream))
58          (line1 "Line1
59")
60          (line2 "Line2"))
61      (count #\Newline (format nil "~a~&~a" line1 line2)))
62  1)
63
64(defstruct ccl.40055 (a 0 :type integer))
65
66(deftest ccl.40055 ;; fixed in r9237 and r9240
67    (locally
68        (declare (optimize (safety 3)))
69      (and (signals-error (make-ccl.40055 :a nil) type-error)
70           (signals-error (setf (ccl.40055-a (make-ccl.40055)) nil) type-error)))
71  t)
72
73(deftest ccl.bug#235
74    (handler-case
75        (test-compile '(lambda (x)
76                        (make-array x :element-type 'ccl.bug#235-unknown-type)))
77      (warning (c) (when (typep c 'ccl::compiler-warning)
78                     (ccl::compiler-warning-warning-type c))))
79  :unknown-type-declaration)
80
81
82(defclass ccl.bug#285 () ())
83
84(defmethod initialize-instance ((c ccl.bug#285) &rest args)
85  (declare (optimize (safety 3)))
86  (apply #'call-next-method c args))
87
88(deftest ccl.bug#285
89    (typep (make-instance 'ccl.bug#285) 'ccl.bug#285)
90  t)
91
92(deftest ccl.bug#286
93    (and (test-compile '(lambda ()
94                         (typep nil '(or ccl.bug#286-unknown-type-1 null)))
95                       :suppress-warnings t)
96         (test-compile '(lambda ()
97                         (ccl:require-type nil '(or ccl.bug#286-unknown-type-2 null)))
98                       :suppress-warnings t)
99         :no-crash)
100  :no-crash)
101
102
103(deftest ccl.bug#287
104    (progn
105      (defmethod ccl.bug#287 (x) x)
106      (trace ccl.bug#287)
107      (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output
108        (prog1
109            (ccl.bug#287 :no-crash)
110          (untrace))))
111  :no-crash)
112
113
114(deftest ccl.41226
115    (let ((file (test-source-file "(defmacro ccl.41226 (x) (eq (caar x)))")))
116      (test-compile file :suppress-warnings t)
117      :no-crash)
118  :no-crash)
119
120(deftest ccl.bug#288
121    (let ((file (test-source-file "(prog1 (declare (ignore foo)))")))
122      (test-compile file :suppress-warnings t)
123      :no-crash)
124  :no-crash)
125
126(deftest ccl.bug#288-1 ;; follow-on bug, not really the same
127    (let ((file (test-source-file "(defun cl-test::ccl.bug#288-1-fn ((x integer)) x)")))
128      (test-compile file :suppress-warnings t :load t)
129      (handler-case
130          (progn (ccl.bug#288-1-fn 17) :no-warnings)
131        (program-error (c) (if (search "(X INTEGER)" (princ-to-string c)) :lambda-list-error c))))
132  :lambda-list-error)
133
134(deftest ccl.40055-1
135    (let ((file (test-source-file "
136
137 (defclass ccl.40055-1-class () ())
138 (eval-when (eval compile load)
139  (defstruct ccl.40055-1-struct (slot nil :type (or ccl.40055-1-class null))))
140 (defun ccl.40055-1-fn ()
141   (make-array 0 :element-type 'ccl.40055-1-struct))
142 ")))
143      (handler-case
144          (progn (test-compile file) :no-warnings)
145        (warning (c) (format nil "~a" c))))
146  :no-warnings)
147
148(deftest ccl.40055-2
149    (let ((file (test-source-file "
150
151 (defclass ccl.40055-2-class () ())
152 (defstruct ccl.40055-2-struct (slot nil :type (or ccl.40055-2-class null)))
153 (defun ccl.40055-2-class-arr ()
154   (make-array 0 :element-type 'ccl.40055-2-class))
155 (defun ccl.40055-2-struct-arr ()
156   (make-array 0 :element-type 'ccl.40055-2-struct))
157 (defun ccl.40055-2-struct-arr-2 ()
158   (make-array 0 :element-type '(or (member 17 32) ccl.40055-2-struct)))
159 (defun ccl.40055-2-fn (x) (setf (ccl.40055-2-struct-slot x) nil))
160 ")))
161      (handler-case
162          (progn (test-compile file) :no-warnings)
163        (warning (c) c)))
164  :no-warnings)
165
166
167(deftest ccl.40055-3
168    (let ((file (test-source-file "
169 (defclass ccl.40055-3-class () ())
170 (defun ccl.40055-3-cfn () (require-type nil '(or ccl.40055-3-class null)))
171 (defstruct ccl.40055-3-struct () ())
172 (defun ccl.40055-3-rfn () (require-type nil '(or ccl.40055-3-struct null)))")))
173      (handler-case
174          (progn (test-compile file) :no-warnings)
175        (warning (c) c)))
176  :no-warnings)
177
178(deftest ccl.bug#289
179    (let ((file (test-source-file "
180 (defclass ccl.bug#289-meta (standard-class) ())
181 (defclass ccl.bug#289-class () () (:metaclass ccl.bug#289-meta))")))
182      (test-compile file)
183      :no-crash)
184  :no-crash)
185
186(deftest ccl.bug#295
187    (let ((file (test-source-file "
188  (defun outer-fun ()
189     (defun inner-fun () nil)
190     (inner-fun))")))
191      (handler-case (progn (test-compile file :safety 3) :no-warnings)
192        (warning (c) c)))
193  :no-warnings)
194
195
196(deftest ccl.41836  ;; fixed in r9391
197    (let ((file (test-source-file "
198  (defvar *a* 1)
199  (defvar *b* (load-time-value *a*))")))
200      (handler-case (progn (test-compile file) :no-warnings)
201        (warning (c) c)))
202  :no-warnings)
203
204
205(deftest ccl.42698  ;; fixed in r9589/r9590
206    (handler-case (schar "abc" -1) ;; used to crash hard
207      (error () :error))
208  :error)
209
210(deftest ccl.42232-1
211    (let ((file (test-source-file "
212  (defun ccl.42232-1 (foo)
213    (declare (ignore foo))
214    foo)")))
215      (handler-case (progn (test-compile file) :no-warnings)
216        (warning (c) :warning)))
217  :warning)
218
219(deftest ccl.42232-2
220    (let ((file (test-source-file "
221  (defun ccl.42232-2 ()
222    (declare (ignore bar)))")))
223      (handler-case (progn (test-compile file) :no-warnings)
224        (warning (c) :warning)))
225  :warning)
226
227(deftest ccl.42830
228    (let ((*standard-output* (make-broadcast-stream)))
229      (defun cl-user::ccl.42830 (stream int colon-p at-sign-p)
230        (declare (ignore at-sign-p colon-p))
231        (check-type int integer)
232        (write int :stream stream))
233      (defun test-ccl.42830 (a b stream)
234        (format stream "~A ~/ccl.42830/" a b))
235      (and (eq (test-ccl.42830 "a" 1 t) nil)
236           (string-equal (test-ccl.42830 "a" 1 nil) "a 1")
237           :no-errors))
238  :no-errors)
239
240
241(deftest ccl.bug#305
242    (let* ((file (test-source-file "
243  (in-package :cl-test)
244  (defclass ccl.bug#305-inner () ((ccl.bug#305-inner-slot :accessor ccl.bug#305-inner-slot)))
245  (macrolet ((generator ()
246               `(defclass ccl.bug#305 (ccl.bug#305-inner)
247                  ,(loop for i from 0 to 600
248                         for slot = (intern (format nil \"CCL.BUG#305-SLOT-~~A\" i) :cl-user)
249                         collect `(,slot :initform ,i)))))
250    (generator))
251  (defmethod initialize-instance :after ((x ccl.bug#305-inner) &key)
252    (setf (ccl.bug#305-inner-slot x) 42))
253  (defun ccl.bug#305-test () (make-instance 'ccl.bug#305))"))
254           (fasl (test-compile file)))
255      (load fasl :verbose nil)
256      (ccl.bug#305-inner-slot (ccl.bug#305-test)))
257  42)
258
259(deftest ccl.42923
260    (progn
261      (fmakunbound 'ccl.42923)
262      (defmethod ccl.42923 ((x (eql 'x)) &key y &allow-other-keys)
263        (list x y) 'x)
264      (defmethod ccl.42923 ((x (eql 'foo)) &key y &allow-other-keys)
265        (list x y) 'foo)
266      (defmethod ccl.42923 ((x (eql 'bar)) &key y z a b c)
267        (list x y z (list a b c)) 'bar)
268      (ccl::maybe-hack-eql-methods #'ccl.42923)
269      (ccl:advise ccl.42923 'advise)
270      (ccl.42923 'foo :y 1 :z 2 :a 1 :b 2 :c 3))
271  foo)
272
Note: See TracBrowser for help on using the repository browser.