Skip to content
Snippets Groups Projects
Commit 069ace59 authored by pfdietz's avatar pfdietz
Browse files

Refactor with two new test macros. Add more tests. Add makefile w. a clean entry.

parent 145916f6
No related branches found
No related tags found
No related merge requests found
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon May 30 06:45:08 2005
;;;; Contains: Aux. files for beyond-ansi tests
(in-package :ba-test)
(defun function-name-p (x)
(or (symbolp x)
(and (consp x)
(eql (car x) 'setf)
(consp (cdr x))
(symbolp (cadr x))
(null (cddr x)))))
(defun symbol-or-function-p (x)
(or (symbolp x)
(and (consp x)
(eql (car x) 'function)
(consp (cdr x))
(null (cddr x))
(function-name-p (cadr x)))))
(defun function-designator-p (x)
(or (functionp x)
(and (symbolp x) (not (macro-function x)) (not (special-operator-p x)))))
(defun type-specifier-p (x)
(typep x '(or symbol list class)))
(defun causes-error-p (pred formf &key (vals *mini-universe*) (var 'x))
(when (symbolp pred)
(assert (fboundp pred))
(setf pred (symbol-function pred)))
(loop for x in vals
for inner-form = (if (functionp formf)
(funcall formf x)
(subst `',x var formf))
for form = `(signals-error ,inner-form error)
unless (or (funcall pred x) (eval form))
collect x))
(defmacro def-all-error-test (name pred form &rest other-args)
`(deftest ,name
(causes-error-p ,pred ,form ,@other-args)
nil))
(defmacro def-error-test (name form)
`(deftest ,name
(signals-error ,form error)
t))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon May 30 15:38:09 2005
;;;; Contains: Tests of non-ANSI exceptional situations from CLHS section 5, part 1
(in-package :ba-test)
(compile-and-load "ba-aux.lsp")
;;; APPLY
(def-all-error-test apply.1 'function-designator-p '(apply x nil))
(def-all-error-test apply.2 'function-designator-p '(apply x '(1 2 3)))
(def-error-test apply.3 (apply 'cons . 1))
(def-all-error-test apply.4 'listp '(apply 'cons '1 x))
;;; DEFUN
(def-error-test defun.1 (defun))
(def-error-test defun.2 (defun #.(gensym)))
(def-error-test defun.3 (defun . foo))
(def-error-test defun.4 (defun #.(gensym) #.(gensym)))
(def-error-test defun.5 (defun #.(gensym) () . foo))
;;; FLET
(def-error-test flet.1 (flet . foo))
(def-error-test flet.2 (flet foo))
(def-error-test flet.3 (flet (foo)))
(def-error-test flet.4 (flet ((foo))))
(def-error-test flet.5 (flet ((foo . bar))))
(def-error-test flet.6 (flet () . foo))
(def-error-test flet.7 (flet ((foo () . bar))))
(def-error-test flet.8 (flet ((foo z))))
(def-error-test flet.9 (flet ((foo ((x y))))))
(def-all-error-test flet.10 'symbolp
#'(lambda (x) (subst x 'x '(flet ((foo (&rest x)))))))
(def-all-error-test flet.11 (typef '(or symbol cons))
#'(lambda (x) (subst x 'x '(flet ((foo (&optional x)))))))
(def-all-error-test flet.12 (typef '(or symbol cons))
#'(lambda (x) (subst x 'x '(flet ((foo (&key x)))))))
(def-error-test flet.13 (flet ((foo (&optional (x . bar)) nil))))
(def-error-test flet.14 (flet ((foo (&optional (x nil . bar)) nil))))
(def-error-test flet.15 (flet ((foo (&optional (x nil x-p . bar)) nil))))
(def-error-test flet.16 (flet ((foo (&optional (x nil x-p nil)) nil))))
(def-error-test flet.17 (flet ((foo (&key (x . bar)) nil))))
(def-error-test flet.18 (flet ((foo (&key (x nil . bar)) nil))))
(def-error-test flet.19 (flet ((foo (&key (x nil x-p . bar)) nil))))
(def-error-test flet.20 (flet ((foo (&key (x nil x-p nil)) nil))))
(def-error-test flet.21 (flet ((foo (&key ((x . bar))) nil))))
(def-error-test flet.22 (flet ((foo (&key ((x y . z))) nil))))
(def-error-test flet.23 (flet ((foo (&key ((x y z))) nil))))
(def-all-error-test flet.24 'symbolp
#'(lambda (x) `(flet ((foo (&key ((,x y))) nil)))))
(def-all-error-test flet.25 'symbolp
#'(lambda (x) `(flet ((foo (&key ((y ,x))) nil)))))
(def-error-test flet.26 (flet ((foo (&aux . bar)))))
(def-error-test flet.27 (flet ((foo (&aux (x . bar))))))
(def-error-test flet.28 (flet ((foo (&aux (x nil . bar))))))
(def-error-test flet.29 (flet ((foo (&aux (x nil nil))))))
;;; LABELS
(def-error-test labels.1 (labels . foo))
(def-error-test labels.2 (labels foo))
(def-error-test labels.3 (labels (foo)))
(def-error-test labels.4 (labels ((foo))))
(def-error-test labels.5 (labels ((foo . bar))))
(def-error-test labels.6 (labels () . foo))
(def-error-test labels.7 (labels ((foo () . bar))))
(def-error-test labels.8 (labels ((foo z))))
(def-error-test labels.9 (labels ((foo ((x y))))))
(def-all-error-test labels.10 'symbolp
#'(lambda (x) (subst x 'x '(labels ((foo (&rest x)))))))
(def-all-error-test labels.11 (typef '(or symbol cons))
#'(lambda (x) (subst x 'x '(labels ((foo (&optional x)))))))
(def-all-error-test labels.12 (typef '(or symbol cons))
#'(lambda (x) (subst x 'x '(labels ((foo (&key x)))))))
(def-error-test labels.13 (labels ((foo (&optional (x . bar)) nil))))
(def-error-test labels.14 (labels ((foo (&optional (x nil . bar)) nil))))
(def-error-test labels.15 (labels ((foo (&optional (x nil x-p . bar)) nil))))
(def-error-test labels.16 (labels ((foo (&optional (x nil x-p nil)) nil))))
(def-error-test labels.17 (labels ((foo (&key (x . bar)) nil))))
(def-error-test labels.18 (labels ((foo (&key (x nil . bar)) nil))))
(def-error-test labels.19 (labels ((foo (&key (x nil x-p . bar)) nil))))
(def-error-test labels.20 (labels ((foo (&key (x nil x-p nil)) nil))))
(def-error-test labels.21 (labels ((foo (&key ((x . bar))) nil))))
(def-error-test labels.22 (labels ((foo (&key ((x y . z))) nil))))
(def-error-test labels.23 (labels ((foo (&key ((x y z))) nil))))
(def-all-error-test labels.24 'symbolp
#'(lambda (x) `(labels ((foo (&key ((,x y))) nil)))))
(def-all-error-test labels.25 'symbolp
#'(lambda (x) `(labels ((foo (&key ((y ,x))) nil)))))
(def-error-test labels.26 (labels ((foo (&aux . bar)))))
(def-error-test labels.27 (labels ((foo (&aux (x . bar))))))
(def-error-test labels.28 (labels ((foo (&aux (x nil . bar))))))
(def-error-test labels.29 (labels ((foo (&aux (x nil nil))))))
;;; MACROLET
;;; FIXME: add these
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue May 31 08:08:49 2005
;;;; Contains: Tests of non-ANSI exceptional situations from CLHS section 5, part 2
(in-package :ba-test)
(compile-and-load "ba-aux.lsp")
;;; FUNCALL
(def-all-error-test funcall.1 'function-designator-p '(funcall x))
(def-error-test funcall.2 (funcall cons 1 . 2))
;;; FUNCTION
(def-error-test function.1 (function))
(def-error-test function.2 (function . cons))
(def-error-test function.3 (function cons . foo))
(def-error-test function.4 (function cons nil))
(def-all-error-test function.5 'function-name-p '(function x))
(def-all-error-test function.6
(constantly nil) #'(lambda (x) `(function ,x))
:vals cl-test::*cl-macro-symbols*)
(def-all-error-test function.7
(constantly nil) #'(lambda (x) `(function ,x))
:vals cl-test::*cl-special-operator-symbols*)
(def-error-test function.8 (macrolet ((%m () nil)) #'%m))
;;; FUNCTION-LAMBDA-EXPRESSION
(def-all-error-test function-lambda-expression.1
'functionp '(function-lambda-expression x))
......@@ -7,6 +7,8 @@
(declaim (notinline compile-fails?))
(compile-and-load "ba-aux.lsp")
;;; Utility functions
(defun compile-fails? (&rest args)
......@@ -19,22 +21,6 @@
(apply #'values nil vals)))
(error () t)))
(defun function-name-p (x)
(or (symbolp x)
(and (consp x)
(eql (car x) 'setf)
(consp (cdr x))
(symbolp (cadr x))
(null (cddr x)))))
(defun symbol-or-function-p (x)
(or (symbolp x)
(and (consp x)
(eql (car x) 'function)
(consp (cdr x))
(null (cddr x))
(function-name-p (cadr x)))))
;;; Tests of COMPILE
(deftest compile.1
......@@ -67,73 +53,39 @@
;;; EVAL-WHEN tests
(deftest eval-when.1
(loop for x in *mini-universe*
unless (or (listp x)
(eval `(signals-error (eval-when ,x nil) error)))
collect x)
nil)
(def-all-error-test eval-when.1 'listp '(eval-when x nil))
;;; LOAD-TIME-VALUE
(deftest load-time-value.1
(signals-error (load-time-value) error)
t)
(deftest load-time-value.2
(signals-error (load-time-value nil nil nil) error)
t)
(def-error-test load-time-value.1 (load-time-value))
(def-error-test load-time-value.2 (load-time-value nil nil nil))
;;; QUOTE
(deftest quote.1
(signals-error (quote) error)
t)
(deftest quote.2
(signals-error (quote . x) error)
t)
(deftest quote.3
(signals-error (quote t . x) error)
t)
(deftest quote.4
(signals-error (quote t x) error)
t)
(def-error-test quote.1 (quote))
(def-error-test quote.2 (quote . x))
(def-error-test quote.3 (quote t . x))
(def-error-test quote.4 (quote t x))
;;; COMPILER-MACRO-FUNCTION
(deftest compiler-macro-function.1
(loop for x in *mini-universe*
unless (or (function-name-p x)
(eval `(signals-error (compiler-macro-function ',x) error)))
collect x)
nil)
(def-all-error-test compiler-macro-function.1
'function-name-p '(compiler-macro-function x))
(deftest compiler-macro-function.2
(loop for x in *mini-universe*
unless (or (function-name-p x)
(eval `(signals-error
(setf (compiler-macro-function ',x) #'rplacd)
error)))
collect x)
nil)
(def-all-error-test compiler-macro-function.2
'function-name-p
'(setf (compiler-macro-function x) #'rplacd))
;;; DEFINE-COMPILER-MACRO
(deftest define-compiler-macro.1
(signals-error (define-compiler-macro) error)
t)
(def-error-test define-compiler-macro.1 (define-compiler-macro))
(deftest define-compiler-macro.2
(let ((sym (gensym)))
(eval `(signals-error (define-compiler-macro ,sym) error)))
t)
(deftest define-compiler-macro.3
(signals-error (define-compiler-macro . foo) error)
t)
(def-error-test define-compiler-macro.3 (define-compiler-macro . foo))
(deftest define-compiler-macro.4
(let ((sym (gensym)))
......@@ -142,19 +94,13 @@
;;; DEFMACRO
(deftest defmacro.1
(signals-error (defmacro) error)
t)
(def-error-test defmacro.1 (defmacro))
(deftest defmacro.2
(let ((sym (gensym)))
(eval `(signals-error (defmacro ,sym) error)))
t)
(deftest defmacro.3
(signals-error (defmacro . foo) error)
t)
(def-error-test defmacro.3 (defmacro . foo))
(deftest defmacro.4
(let ((sym (gensym)))
(eval `(signals-error (defmacro ,sym () . foo) error)))
......@@ -162,22 +108,10 @@
;;; MACRO-FUNCTION
(deftest macro-funtion.1
(loop for x in *mini-universe*
unless (or (symbolp x)
(eval `(signals-error (macro-function ',x) error)))
collect x)
nil)
(deftest macro-funtion.2
(loop for x in *mini-universe*
unless (or (symbolp x)
(eval `(signals-error (setf (macro-function ',x)
(macro-function 'car))
error)))
collect x)
nil)
(def-all-error-test macro-funtion.1 'symbolp '(macro-function x))
(def-all-error-test macro-funtion.2
'symbolp '(setf (macro-function x) (macro-function 'pop)))
;;; DEFINE-SYMBOL-MACRO
......@@ -191,62 +125,35 @@
(eval `(signals-error (define-symbol-macro ,sym t nil) error)))
t)
(deftest define-symbol-macro.3
(loop for x in *mini-universe*
unless (or (symbolp x)
(eval `(signals-error (define-symbol-macro ',x) error)))
collect x)
nil)
(def-all-error-test define-symbol-macro.3 'symbolp '(define-symbol-macro x))
;;; IGNORE
(deftest ignore.1
(loop for x in *mini-universe*
unless (or (symbol-or-function-p x)
(eval `(signals-error (locally (declare (ignore ,x)) nil)
error)))
collect x)
nil)
(def-all-error-test ignore.1
'symbol-or-function-p '(locally (declare (ignore x)) nil))
(deftest ignore.2
(signals-error (locally (declare (ignore . foo)) nil) error)
t)
(def-error-test ignore.2 (locally (declare (ignore . foo)) nil))
;;; IGNORABLE
(deftest ignorable.1
(loop for x in *mini-universe*
unless (or (symbol-or-function-p x)
(eval `(signals-error
(locally (declare (ignorable ,x)) nil)
error)))
collect x)
nil)
(def-all-error-test ignorable.1
'symbol-or-function-p '(locally (declare (ignorable x)) nil))
(deftest ignorable.2
(signals-error (locally (declare (ignorable . foo)) nil) error)
t)
(def-error-test ignorable.2 (locally (declare (ignorable . foo)) nil))
;;; DYNAMIC-EXTENT
(deftest dynamic-extent.1
(loop for x in *mini-universe*
unless (or (symbol-or-function-p x)
(eval `(signals-error
(locally (declare (dynamic-extent ,x)) nil)
error)))
collect x)
nil)
(def-all-error-test dynamic-extent.1
'symbol-or-function-p '(locally (declare (dynamic-extent x)) nil))
(deftest dynamic-extent.2
(signals-error (locally (declare (dynamic-extent . foo)) nil) error)
t)
(def-error-test dynamic-extent.2
(locally (declare (dynamic-extent . foo)) nil))
;;; TYPE declarations
;;; Test that violation of the type declarations is detected, and
;;; leads to an error in safe code.
#-sbcl
(deftest type.1
(loop for x in *mini-universe*
for tp = (type-of x)
......@@ -257,3 +164,168 @@
unless (eval `(signals-error (funcall ',fn ',x) error))
collect x)
nil)
(deftest type.2
(let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector))
(n (length utypes)))
(flet ((%rtype () (elt utypes (random n))))
(loop for x in *mini-universe*
for tp = (loop for tp = (%rtype)
while (typep x tp)
finally (return tp))
for lambda-form = `(lambda (y) (declare (optimize safety)
(type ,tp y)) y)
for fn = (progn ;; (print lambda-form)
(eval `(function ,lambda-form)))
unless (eval `(signals-error (funcall ',fn ',x) error))
collect x)))
nil)
(deftest type.2c
(let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector))
(n (length utypes)))
(flet ((%rtype () (elt utypes (random n))))
(loop for x in *mini-universe*
for tp = (loop for tp = (%rtype)
while (typep x tp)
finally (return tp))
for lambda-form = `(lambda (y) (declare (optimize safety)
(type ,tp y)) y)
for fn = (progn ;; (print lambda-form)
(compile nil lambda-form))
unless (eval `(signals-error (funcall ',fn ',x) error))
collect x)))
nil)
(deftest type.3
(loop for x in *mini-universe*
for tp = (type-of x)
for lambda-form = `(lambda (z) (declare (optimize safety))
(let ((y z))
(declare (type ,tp y))
y))
for fn = (progn ;; (print lambda-form)
(eval `(function ,lambda-form)))
unless (or (typep nil tp)
(eval `(signals-error (funcall ',fn nil) error)))
collect x)
nil)
(deftest type.3c
(loop for x in *mini-universe*
for tp = (type-of x)
for lambda-form = `(lambda (z) (declare (optimize safety))
(let ((y z))
(declare (type ,tp y))
y))
for fn = (progn ;; (print lambda-form)
(compile nil lambda-form))
unless (or (typep nil tp)
(eval `(signals-error (funcall ',fn nil) error)))
collect x)
nil)
(deftest type.4
(loop for x in *mini-universe*
for tp = (type-of x)
for lambda-form = `(lambda (z) (declare (optimize safety))
(the ,tp z))
for fn = (progn ;; (print lambda-form)
(eval `(function ,lambda-form)))
unless (or (typep nil tp)
(eval `(signals-error (funcall ',fn nil) error)))
collect x)
nil)
(deftest type.5
(signals-error (let () (declare (type . foo)) nil) error)
t)
(deftest type.6
(signals-error (let () (declare (type integer . foo)) nil) error)
t)
(deftest type.7
(signals-error (let () (declare (integer . foo)) nil) error)
t)
(deftest type.8
(signals-error (let ((x (make-array 3 :initial-element 0
:element-type '(integer 0 2))))
(declare (optimize safety)
(type (array (integer 0 2) (3)) x))
(setf (aref x 0) 3)
(aref x 0))
error)
t)
;; Move the type tests off to another file, eventually.
;;; INLINE
(def-all-error-test inline.1
'function-name-p '(locally (declare (inline x)) nil))
(def-error-test inline.2 (locally (declare (inline . x)) nil))
;;; NOTINLINE
(def-all-error-test notinline.1
'function-name-p '(locally (declare (notinline x)) nil))
(def-error-test notinline.2 (locally (declare (notinline . x)) nil))
;;; FTYPE
(def-error-test ftype.1
(macrolet ((%m () :foo))
(declare (ftype (function (&rest t) t) %m))
(%m)))
(def-error-test ftype.2
(flet ((%f () :foo))
(declare (ftype (function () (eql :bar)) %f))
(%f)))
(def-error-test ftype.3 (locally (declare (ftype)) nil))
(def-error-test ftype.4 (locally (declare (ftype symbol)) nil))
(def-error-test ftype.5 (locally (declare (ftype (function () t) . foo)) nil))
(def-all-error-test ftype.6
'function-name-p '(locally (declare (ftype (function () t) x)) nil))
;;; DECLARATIONS
(def-error-test declaration.1 (proclaim '(declaration . foo)))
(def-all-error-test declaration.2 'symbolp '(proclaim (declaration x)))
;;; OPTIMIZE
(def-error-test optimize.1 (locally (declare (optimize .foo)) nil))
(def-all-error-test optimize.2
'symbolp '(locally (declare (optimize (x 0))) nil))
(def-all-error-test optimize.3
(typef '(mod 4)) '(locally (declare (optimize (speed x)))))
;;; SPECIAL
(def-error-test special.1 (locally (declare (special . x)) nil))
(def-all-error-test special.2 'symbolp '(locally (declare (special x)) nil))
;;; LOCALLY
(def-error-test locally.1 (locally . x))
;;; THE
(def-error-test the.1 (the))
(def-error-test the.2 (the t))
(def-error-test the.3 (the t :a :b))
(def-error-test the.4 (setf (the) nil))
(def-error-test the.5 (setf (the t) nil))
(def-error-test the.6 (let (x y) (setf (the t x y) nil)))
;;;
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon May 30 07:49:10 2005
;;;; Contains: Tests for non-ansi exceptional situations in Section 4 of CLHS
(in-package :ba-test)
(compile-and-load "ba-aux.lsp")
;;; COERCE
(def-all-error-test coerce.1 'listp '(coerce t x))
;;; DEFTYPE
(def-error-test deftype.1 (deftype))
(def-error-test deftype.2 (deftype #.(gensym)))
(def-error-test deftype.3 (deftype . foo))
(def-all-error-test deftype.4 'symbolp '(deftype x () t))
;;; SUBTYPEP
(def-all-error-test subtypep.1 'type-specifier-p '(subtypep x t))
(def-all-error-test subtypep.2 'type-specifier-p '(subtypep nil x))
;;; TYPEP
(def-all-error-test typep.1 'type-specifier-p '(typep nil x))
;;; SATISFIES
(def-error-test satisfies.1 (typep nil '(satifies)))
(def-error-test satisfies.2 (typep nil '(satifies null nil)))
(def-all-error-test satisfies.3 'symbolp '(typep nil (satisfies x)))
;;; MEMBER (type specifier)
(def-error-test member.type.1 (typep nil 'member))
(def-error-test member.type.2 (typep nil '(member . foo)))
(def-error-test member.type.3 (typep nil '(member bar . foo)))
;;; NOT (type specifier)
(def-error-test not.type.1 (typep nil 'not))
(def-error-test not.type.2 (typep nil '(not)))
(def-error-test not.type.3 (typep nil '(not *)))
(def-error-test not.type.4 (typep nil '(not nil nil)))
(def-all-error-test not.type.5 'type-specifier-p '(typep nil '(not x)))
(def-error-test not.type.6 (typep nil '(not . foo)))
;;; AND (type specifier)
(def-error-test and.type.1 (typep nil 'and))
(def-error-test and.type.2 (typep nil '(and *)))
(def-error-test and.type.3 (typep nil '(and t * t)))
(def-error-test and.type.4 (typep nil '(and . foo)))
(def-all-error-test and.type.5 'type-specifier-p '(typep t '(and t t x t)))
;;; OR (type specifier)
(def-error-test or.type.1 (typep nil 'or))
(def-error-test or.type.2 (typep nil '(or *)))
(def-error-test or.type.3 (typep nil '(or nil * nil)))
(def-error-test or.type.4 (typep nil '(or . foo)))
(def-all-error-test or.type.5 'type-specifier-p '(typep t '(or nil x nil)))
;;; VALUES (type specifier)
(def-error-test values.type.1 (typep nil 'values))
(def-error-test values.type.2 (the values (values)))
(def-error-test values.type.3 (the (values . foo) (values)))
(def-error-test values.type.4 (the (values *) t))
(def-all-error-test values.type.5 'type-specifier-p '(the (values x) t))
;;; EQL (type specifier)
(def-error-test eql.type.1 (typep nil 'eql))
(def-error-test eql.type.2 (typep nil '(eql)))
(def-error-test eql.type.3 (typep nil '(eql nil nil)))
(def-error-test eql.type.4 (typep nil '(eql . foo)))
;;; TYPE-ERROR-DATUM
(def-all-error-test type-error-datum.1
(typef 'type-error) '(type-error-datum x))
;;; TYPE-ERROR-EXPECTED-TYPE
(def-all-error-test type-error-expected-type.1
(typef 'type-error) '(type-error-expected-type x))
;;; FUNCTION (type specifier)
(def-error-test function.type.1
(locally (declare (type (function . foo) f)) nil))
(def-error-test function.type.2
(locally (declare (type (function () . foo) f)) nil))
(def-error-test function.type.3
(locally (declare (type (function (t . t) t) f)) nil))
(def-error-test function.type.4
(locally (declare (type (function (&optional . foo) t) f)) nil))
(def-error-test function.type.5
(locally (declare (type (function (&rest . foo) t) f)) nil))
(def-error-test function.type.6
(locally (declare (type (function (&key . foo) t) f)) nil))
(def-error-test function.type.7
(locally (declare (type (function (&key :foo) t) f)) nil))
(def-error-test function.type.8
(locally (declare (type (function (&key (:foo . bar)) t) f)) nil))
(def-error-test function.type.9
(locally (declare (type (function (&key (:foo t . bar)) t) f)) nil))
(def-error-test function.type.10
(locally (declare (type (function (&key (:foo t nil)) t) f)) nil))
clean:
@rm -f test.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\#
@rm -f gazonk* out.class
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment