source: trunk/source/tests/ansi-tests/beyond-ansi/errors-eval-compile.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 8.2 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May 28 06:37:41 2005
4;;;; Contains: Tests for nonstandard exceptional conditions in section 3
5
6(in-package :ba-test)
7
8(declaim (notinline compile-fails?))
9
10(compile-and-load "ba-aux.lsp")
11
12;;; Utility functions
13
14(defun compile-fails? (&rest args)
15  (cl:handler-case
16   (let ((vals (multiple-value-list (apply #'compile args))))
17     (if (and (= (length vals) 3)
18              (cadr vals)
19              (caadr vals))
20         t
21       (apply #'values nil vals)))
22   (error () t)))
23
24;;; Tests of COMPILE
25
26(deftest compile.1
27  (loop for x in *mini-universe*
28        unless (or (function-name-p x)
29                   (compile-fails? x))
30        collect x)
31  nil)
32
33(deftest compile.2
34  (compile-fails? nil)
35  t)
36
37(deftest compile.3
38  (let ((sym (gensym)))
39    (eval `(defun ,sym () nil))
40    (loop for x in *mini-universe*
41          unless (or (functionp x) (and (consp x) (eql (car x) 'lambda))
42                     (compile-fails? sym x))
43          collect x))
44  nil)
45
46(deftest compile.4
47  (compile-fails? nil '(lambda))
48  t)
49
50(deftest compile.5
51  (compile-fails? nil '(lambda x))
52  t)
53
54;;; EVAL-WHEN tests
55
56(def-all-error-test eval-when.1 'listp '(eval-when x nil))
57
58;;; LOAD-TIME-VALUE
59
60(def-error-test load-time-value.1 (load-time-value))
61(def-error-test load-time-value.2 (load-time-value nil nil nil))
62
63;;; QUOTE
64
65(def-error-test quote.1 (quote))
66(def-error-test quote.2 (quote . x))
67(def-error-test quote.3 (quote t . x))
68(def-error-test quote.4 (quote t x))
69
70;;; COMPILER-MACRO-FUNCTION
71
72(def-all-error-test compiler-macro-function.1
73  'function-name-p '(compiler-macro-function x))
74
75(def-all-error-test compiler-macro-function.2
76  'function-name-p
77  '(setf (compiler-macro-function x) #'rplacd))
78
79;;; DEFINE-COMPILER-MACRO
80
81(def-error-test define-compiler-macro.1 (define-compiler-macro))
82
83(deftest define-compiler-macro.2
84  (let ((sym (gensym)))
85    (eval `(signals-error (define-compiler-macro ,sym) error)))
86  t)
87
88(def-error-test define-compiler-macro.3 (define-compiler-macro . foo))
89
90(deftest define-compiler-macro.4
91  (let ((sym (gensym)))
92    (eval `(signals-error (define-compiler-macro ,sym () . foo) error)))
93  t)
94
95;;; DEFMACRO
96
97(def-error-test defmacro.1 (defmacro))
98(deftest defmacro.2
99  (let ((sym (gensym)))
100    (eval `(signals-error (defmacro ,sym) error)))
101  t)
102
103(def-error-test defmacro.3 (defmacro . foo))
104(deftest defmacro.4
105  (let ((sym (gensym)))
106    (eval `(signals-error (defmacro ,sym () . foo) error)))
107  t)
108
109;;; MACRO-FUNCTION
110
111(def-all-error-test macro-funtion.1 'symbolp '(macro-function x))
112
113(def-all-error-test macro-funtion.2
114  'symbolp '(setf (macro-function x) (macro-function 'pop)))
115
116;;; DEFINE-SYMBOL-MACRO
117
118(deftest define-symbol-macro.1
119  (let ((sym (gensym)))
120    (eval `(signals-error (define-symbol-macro ,sym) error)))
121  t)
122
123(deftest define-symbol-macro.2
124  (let ((sym (gensym)))
125    (eval `(signals-error (define-symbol-macro ,sym t nil) error)))
126  t)
127
128(def-all-error-test define-symbol-macro.3 'symbolp '(define-symbol-macro x))
129
130;;; IGNORE
131
132(def-all-error-test ignore.1
133  'symbol-or-function-p '(locally (declare (ignore x)) nil))
134
135(def-error-test ignore.2 (locally (declare (ignore . foo)) nil))
136
137;;; IGNORABLE
138
139(def-all-error-test ignorable.1
140  'symbol-or-function-p '(locally (declare (ignorable x)) nil))
141
142(def-error-test ignorable.2 (locally (declare (ignorable . foo)) nil))
143
144;;; DYNAMIC-EXTENT
145
146(def-all-error-test dynamic-extent.1
147  'symbol-or-function-p '(locally (declare (dynamic-extent x)) nil))
148
149(def-error-test dynamic-extent.2
150  (locally (declare (dynamic-extent . foo)) nil))
151
152;;; TYPE declarations
153;;; Test that violation of the type declarations is detected, and
154;;; leads to an error in safe code.
155
156#-sbcl
157(deftest type.1
158  (loop for x in *mini-universe*
159        for tp = (type-of x)
160        for lambda-form = `(lambda (y) (declare (optimize safety)
161                                                (type (not ,tp) y)) y)
162        for fn = (progn (print lambda-form)
163                        (eval `(function ,lambda-form)))
164        unless (eval `(signals-error (funcall ',fn ',x) error))
165        collect x)
166  nil)
167
168(deftest type.2
169  (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector))
170         (n (length utypes)))
171    (flet ((%rtype () (elt utypes (random n))))
172      (loop for x in *mini-universe*
173            for tp = (loop for tp = (%rtype)
174                           while (typep x tp)
175                           finally (return tp))
176            for lambda-form = `(lambda (y) (declare (optimize safety)
177                                                (type ,tp y)) y)
178            for fn = (progn ;; (print lambda-form)
179                            (eval `(function ,lambda-form)))
180            unless (eval `(signals-error (funcall ',fn ',x) error))
181            collect x)))
182  nil)
183
184(deftest type.2c
185  (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector))
186         (n (length utypes)))
187    (flet ((%rtype () (elt utypes (random n))))
188      (loop for x in *mini-universe*
189            for tp = (loop for tp = (%rtype)
190                           while (typep x tp)
191                           finally (return tp))
192            for lambda-form = `(lambda (y) (declare (optimize safety)
193                                                (type ,tp y)) y)
194            for fn = (progn ;; (print lambda-form)
195                            (compile nil lambda-form))
196            unless (eval `(signals-error (funcall ',fn ',x) error))
197            collect x)))
198  nil)
199
200(deftest type.3
201  (loop for x in *mini-universe*
202        for tp = (type-of x)
203        for lambda-form = `(lambda (z) (declare (optimize safety))
204                             (let ((y z))
205                               (declare (type ,tp y))
206                               y))
207        for fn = (progn ;; (print lambda-form)
208                   (eval `(function ,lambda-form)))
209        unless (or (typep nil tp)
210                   (eval `(signals-error (funcall ',fn nil) error)))
211        collect x)
212  nil)
213
214(deftest type.3c
215  (loop for x in *mini-universe*
216        for tp = (type-of x)
217        for lambda-form = `(lambda (z) (declare (optimize safety))
218                             (let ((y z))
219                               (declare (type ,tp y))
220                               y))
221        for fn = (progn ;; (print lambda-form)
222                   (compile nil lambda-form))
223        unless (or (typep nil tp)
224                   (eval `(signals-error (funcall ',fn nil) error)))
225        collect x)
226  nil)
227
228(deftest type.4
229  (loop for x in *mini-universe*
230        for tp = (type-of x)
231        for lambda-form = `(lambda (z) (declare (optimize safety))
232                             (the ,tp z))
233        for fn = (progn ;; (print lambda-form)
234                   (eval `(function ,lambda-form)))
235        unless (or (typep nil tp)
236                   (eval `(signals-error (funcall ',fn nil) error)))
237        collect x)
238  nil)
239
240(deftest type.5
241  (signals-error (let () (declare (type . foo)) nil) error)
242  t)
243
244(deftest type.6
245  (signals-error (let () (declare (type integer . foo)) nil) error)
246  t)
247
248(deftest type.7
249  (signals-error (let () (declare (integer . foo)) nil) error)
250  t)
251
252(deftest type.8
253  (signals-error (let ((x (make-array 3 :initial-element 0
254                                      :element-type '(integer 0 2))))
255                   (declare (optimize safety)
256                            (type (array (integer 0 2) (3)) x))
257                   (setf (aref x 0) 3)
258                   (aref x 0))
259                 error)
260  t)
261
262;; Move the type tests off to another file, eventually.
263
264;;; INLINE
265
266(def-all-error-test inline.1
267  'function-name-p '(locally (declare (inline x)) nil))
268
269(def-error-test inline.2 (locally (declare (inline . x)) nil))
270
271;;; NOTINLINE
272
273(def-all-error-test notinline.1
274  'function-name-p '(locally (declare (notinline x)) nil))
275
276(def-error-test notinline.2 (locally (declare (notinline . x)) nil))
277
278;;; FTYPE
279
280(def-error-test ftype.1
281  (macrolet ((%m () :foo))
282    (declare (ftype (function (&rest t) t) %m))
283    (%m)))
284
285(def-error-test ftype.2
286  (flet ((%f () :foo))
287    (declare (ftype (function () (eql :bar)) %f))
288    (%f)))
289
290(def-error-test ftype.3 (locally (declare (ftype)) nil))
291(def-error-test ftype.4 (locally (declare (ftype symbol)) nil))
292(def-error-test ftype.5 (locally (declare (ftype (function () t) . foo)) nil))
293
294(def-all-error-test ftype.6
295  'function-name-p '(locally (declare (ftype (function () t) x)) nil))
296
297;;; DECLARATIONS
298
299(def-error-test declaration.1 (proclaim '(declaration . foo)))
300
301(def-all-error-test declaration.2 'symbolp '(proclaim (declaration x)))
302
303;;; OPTIMIZE
304
305(def-error-test optimize.1 (locally (declare (optimize .foo)) nil))
306
307(def-all-error-test optimize.2
308  'symbolp '(locally (declare (optimize (x 0))) nil))
309
310(def-all-error-test optimize.3
311  (typef '(mod 4)) '(locally (declare (optimize (speed x)))))
312
313;;; SPECIAL
314
315(def-error-test special.1 (locally (declare (special . x)) nil))
316(def-all-error-test special.2 'symbolp '(locally (declare (special x)) nil))
317
318;;; LOCALLY
319
320(def-error-test locally.1 (locally . x))
321
322;;; THE
323
324(def-error-test the.1 (the))
325(def-error-test the.2 (the t))
326(def-error-test the.3 (the t :a :b))
327(def-error-test the.4 (setf (the) nil))
328(def-error-test the.5 (setf (the t) nil))
329(def-error-test the.6 (let (x y) (setf (the t x y) nil)))
330
331;;;
Note: See TracBrowser for help on using the repository browser.