Commit 069ace59 authored by pfdietz's avatar pfdietz

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

parent 145916f6
;-*- 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))
;-*- 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
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment