5 |
|
|
6 |
(in-package :ba-test) |
(in-package :ba-test) |
7 |
|
|
|
;;; Tests of COMPILE |
|
|
|
|
8 |
(declaim (notinline compile-fails?)) |
(declaim (notinline compile-fails?)) |
9 |
|
|
10 |
|
;;; Utility functions |
11 |
|
|
12 |
(defun compile-fails? (&rest args) |
(defun compile-fails? (&rest args) |
13 |
(cl:handler-case |
(cl:handler-case |
14 |
(let ((vals (multiple-value-list (apply #'compile args)))) |
(let ((vals (multiple-value-list (apply #'compile args)))) |
27 |
(symbolp (cadr x)) |
(symbolp (cadr x)) |
28 |
(null (cddr x))))) |
(null (cddr x))))) |
29 |
|
|
30 |
|
(defun symbol-or-function-p (x) |
31 |
|
(or (symbolp x) |
32 |
|
(and (consp x) |
33 |
|
(eql (car x) 'function) |
34 |
|
(consp (cdr x)) |
35 |
|
(null (cddr x)) |
36 |
|
(function-name-p (cadr x))))) |
37 |
|
|
38 |
|
;;; Tests of COMPILE |
39 |
|
|
40 |
(deftest compile.1 |
(deftest compile.1 |
41 |
(loop for x in *mini-universe* |
(loop for x in *mini-universe* |
42 |
unless (or (function-name-p x) |
unless (or (function-name-p x) |
203 |
|
|
204 |
(deftest ignore.1 |
(deftest ignore.1 |
205 |
(loop for x in *mini-universe* |
(loop for x in *mini-universe* |
206 |
unless (or (symbolp x) |
unless (or (symbol-or-function-p x) |
|
(and (consp x) |
|
|
(eql (car x) 'function) |
|
|
(consp (cdr x)) |
|
|
(symbolp (cadr x)) |
|
|
(null (cddr x))) |
|
207 |
(eval `(signals-error (locally (declare (ignore ,x)) nil) |
(eval `(signals-error (locally (declare (ignore ,x)) nil) |
208 |
error))) |
error))) |
209 |
collect x) |
collect x) |
217 |
|
|
218 |
(deftest ignorable.1 |
(deftest ignorable.1 |
219 |
(loop for x in *mini-universe* |
(loop for x in *mini-universe* |
220 |
unless (or (symbolp x) |
unless (or (symbol-or-function-p x) |
221 |
(and (consp x) |
(eval `(signals-error |
222 |
(eql (car x) 'function) |
(locally (declare (ignorable ,x)) nil) |
223 |
(consp (cdr x)) |
error))) |
|
(symbolp (cadr x)) |
|
|
(null (cddr x))) |
|
|
(eval `(signals-error (locally (declare (ignorable ,x)) nil) |
|
|
error))) |
|
224 |
collect x) |
collect x) |
225 |
nil) |
nil) |
226 |
|
|
232 |
|
|
233 |
(deftest dynamic-extent.1 |
(deftest dynamic-extent.1 |
234 |
(loop for x in *mini-universe* |
(loop for x in *mini-universe* |
235 |
unless (or (symbolp x) |
unless (or (symbol-or-function-p x) |
236 |
(and (consp x) |
(eval `(signals-error |
237 |
(eql (car x) 'function) |
(locally (declare (dynamic-extent ,x)) nil) |
238 |
(consp (cdr x)) |
error))) |
|
(symbolp (cadr x)) |
|
|
(null (cddr x))) |
|
|
(eval `(signals-error (locally (declare (dynamic-extent ,x)) nil) |
|
|
error))) |
|
239 |
collect x) |
collect x) |
240 |
nil) |
nil) |
241 |
|
|
242 |
(deftest dynamic-extent.2 |
(deftest dynamic-extent.2 |
243 |
(signals-error (locally (declare (dynamic-extent . foo)) nil) error) |
(signals-error (locally (declare (dynamic-extent . foo)) nil) error) |
|
t) |
|
244 |
|
t) |
245 |
|
|
246 |
|
;;; TYPE declarations |
247 |
|
;;; Test that violation of the type declarations is detected, and |
248 |
|
;;; leads to an error in safe code. |
249 |
|
|
250 |
|
(deftest type.1 |
251 |
|
(loop for x in *mini-universe* |
252 |
|
for tp = (type-of x) |
253 |
|
for lambda-form = `(lambda (y) (declare (optimize safety) |
254 |
|
(type (not ,tp) y)) y) |
255 |
|
for fn = (progn (print lambda-form) |
256 |
|
(eval `(function ,lambda-form))) |
257 |
|
unless (eval `(signals-error (funcall ',fn ',x) error)) |
258 |
|
collect x) |
259 |
|
nil) |