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

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

regression test for bug#295

File size: 5.5 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))
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))))
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.40055-1
127    (let ((file (test-source-file "
128
129 (defclass ccl.40055-1-class () ())
130 (eval-when (eval compile load)
131  (defstruct ccl.40055-1-struct (slot nil :type (or ccl.40055-1-class null))))
132 (defun ccl.40055-1-fn ()
133   (make-array 0 :element-type 'ccl.40055-1-struct))
134 ")))
135      (handler-case
136          (progn (test-compile file) :no-warnings)
137        (warning (c) (format nil "~a" c))))
138  :no-warnings)
139
140(deftest ccl.40055-2
141    (let ((file (test-source-file "
142
143 (defclass ccl.40055-2-class () ())
144 (defstruct ccl.40055-2-struct (slot nil :type (or ccl.40055-2-class null)))
145 (defun ccl.40055-2-class-arr ()
146   (make-array 0 :element-type 'ccl.40055-2-class))
147 (defun ccl.40055-2-struct-arr ()
148   (make-array 0 :element-type 'ccl.40055-2-struct))
149 (defun ccl.40055-2-struct-arr ()
150   (make-array 0 :element-type '(or (member 17 32) ccl.40055-2-struct)))
151 (defun ccl.40055-2-fn (x) (setf (ccl.40055-2-struct-slot x) nil))
152 ")))
153      (handler-case
154          (progn (test-compile file) :no-warnings)
155        (warning (c) c)))
156  :no-warnings)
157
158
159(deftest ccl.40055-3
160    (let ((file (test-source-file "
161 (defclass ccl.40055-3-class () ())
162 (defun ccl.40055-3-cfn () (require-type nil '(or ccl.40055-3-class null)))
163 (defstruct ccl.40055-3-struct () ())
164 (defun ccl.40055-3-rfn () (require-type nil '(or ccl.40055-3-struct null)))")))
165      (test-compile file)
166      :no-crash)
167  :no-crash)
168
169
170(deftest ccl.bug#295
171    (let ((file (test-source-file "
172  (defun outer-fun ()
173     (defun inner-fun () nil)
174     (inner-fun))")))
175      (handler-case (progn (test-compile file :safety 3) :no-warnings)
176        (warning (c) (format t "~a" c)
177          c)))
178  :no-warnings)
179
Note: See TracBrowser for help on using the repository browser.