Commit e3674151 authored by pfdietz's avatar pfdietz

More typep, subtypep tests. Added tests of handler-bind, invoke-debugger.

parent d01951ec
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Feb 28 22:07:25 2003
;;;; Contains: Tests of HANDLER-BIND
(in-package :cl-test)
(deftest handler-bind.1
(handler-bind ())
nil)
(deftest handler-bind.2
(handler-bind () (values)))
(deftest handler-bind.3
(handler-bind () (values 1 2 3))
1 2 3)
(deftest handler-bind.4
(let ((x 0))
(values
(handler-bind () (incf x) (+ x 10))
x))
11 1)
(deftest handler-bind.5
(block foo
(handler-bind ((error #'(lambda (c) (return-from foo 'good))))
(error "an error")))
good)
(deftest handler-bind.6
(block foo
(handler-bind
((error #'(lambda (c) (return-from foo 'good))))
(handler-bind ((error #'(lambda (c) (error c)))
(error #'(lambda (c) (return-from foo 'bad))))
(error "an error"))))
good)
(defun handler-bind.7-handler-fn (c)
(declare (ignore c))
(throw 'foo 'good))
(deftest handler-bind.7
(catch 'foo
(handler-bind ((simple-error #'handler-bind.7-handler-fn))
(error "simple error")))
good)
(deftest handler-bind.8
(catch 'foo
(handler-bind ((simple-error 'handler-bind.7-handler-fn))
(error "simple error")))
good)
(deftest handler-bind.9
(catch 'foo
(handler-bind ((simple-error #.(symbol-function
'handler-bind.7-handler-fn)))
(error "simple error")))
good)
(deftest handler-bind.10
(block done
(flet ((%foo () (signal "A simple condition"))
(%succeed (c) (declare (ignore c)) (return-from done 'good))
(%fail (c) (declare (ignore c)) (return-from done 'bad)))
(handler-bind
((error #'%fail)
(simple-condition #'%succeed))
(%foo))))
good)
(deftest handler-bind.11
(block done
(handler-bind
((error #'(lambda (c) c))
(error #'(lambda (c) (declare (ignore c)) (return-from done 'good))))
(error "an error")))
good)
(deftest handler-bind.12
(block done
(handler-bind
((error #'(lambda (c) (declare (ignore c)) (return-from done 'good))))
(handler-bind
((error #'(lambda (c) c)))
(error "an error"))))
good)
;;; More handler-bind tests elsewhere
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Feb 28 21:59:57 2003
;;;; Contains: Tests of INVOKE-DEBUGGER
(in-package :cl-test)
;;; We can't test actual entry into the debugger, but we can test
;;; that the function in *debugger-hook* is properly called.
(deftest invoke-debugger.1
(block done
(let (fn (cnd (make-condition 'simple-error)))
(setq fn #'(lambda (c hook)
(return-from done
(and (null *debugger-hook*)
(eqt hook fn)
(eqt cnd c)
'good))))
(let ((*debugger-hook* fn))
(invoke-debugger cnd)))
'bad)
good)
......@@ -6,4 +6,5 @@
(load "cerror.lsp")
(load "check-type.lsp")
(load "warn.lsp")
(load "invoke-debugger.lsp")
(load "handler-bind.lsp")
......@@ -119,3 +119,84 @@
'(or (cons integer symbol)
(cons symbol integer)))
nil)
(deftest subtypep.cons.13
(check-all-not-subtypep '(not list) 'cons)
nil)
;;; a -> b, a ==> b
(deftest subtypep.cons.14
(check-all-subtypep
'(and (or (cons (not symbol)) (cons * integer))
(cons symbol))
'(cons * integer))
nil)
;;; a -> b, not b ==> not a
(deftest subtypep.cons.15
(check-all-subtypep
'(and (or (cons (not symbol)) (cons * integer))
(cons * (not integer)))
'(cons (not symbol)))
nil)
;;; (and (or a b) (or (not b) c)) ==> (or a c)
(deftest subtypep.cons.16
(check-all-subtypep
'(and (or (cons symbol (cons * *))
(cons * (cons integer *)))
(or (cons * (cons (not integer) *))
(cons * (cons * float))))
'(or (cons symbol (cons * *))
(cons * (cons * float))))
nil)
(deftest subtypep.cons.17
(check-all-subtypep
'(and (or (cons symbol (cons * *))
(cons * (cons integer *)))
(or (cons * (cons (not integer)))
(cons * (cons * float)))
(or (cons * (cons * (not float)))
(cons symbol (cons * *))))
'(cons symbol))
nil)
(deftest subtypep.cons.18
(check-all-subtypep
'(cons symbol)
'(or (cons symbol (not integer))
(cons * integer)))
nil)
(deftest subtypep.cons.19
(check-equivalence
'(or
(cons (eql a) (eql x))
(cons (eql b) (eql y))
(cons (eql c) (eql z))
(cons (eql a) (eql y))
(cons (eql b) (eql z))
(cons (eql c) (eql x))
(cons (eql a) (eql z))
(cons (eql b) (eql x))
(cons (eql c) (eql y)))
'(cons (member a b c) (member x y z)))
nil)
(deftest subtypep.cons.20
(check-equivalence
'(or
(cons (eql a) (eql x))
(cons (eql b) (eql y))
(cons (eql a) (eql y))
(cons (eql b) (eql z))
(cons (eql c) (eql x))
(cons (eql a) (eql z))
(cons (eql b) (eql x))
(cons (eql c) (eql y)))
'(and (cons (member a b c) (member x y z))
(not (cons (eql c) (eql z)))))
nil)
......@@ -177,3 +177,53 @@
(deftest subtypep.member.36
(check-disjointness '(eql a) '(or (member b c d) (eql e)))
nil)
(deftest subtypep.member.37
(check-equivalence
'(and (member a b c d) (not (eql c)))
'(member a b d))
nil)
(deftest subtypep.member.38
(check-equivalence
'(and (member a b c d e f g)
(not (member b f)))
'(member a c d e g))
nil)
(deftest subtypep.member.39
(check-equivalence
'(and (not (member b d e f g))
(not (member x y b z d)))
'(not (member b d e f g x y z)))
nil)
(deftest subtypep.member.40
(check-equivalence
'(and (not (eql a)) (not (eql b)))
'(not (member a b)))
nil)
(deftest subtypep.member.41
(check-equivalence
'(and (not (eql a)) (not (eql b)) (not (eql c)))
'(not (member c b a)))
nil)
(deftest subtypep.member.42
(check-equivalence
'(and (not (member a b)) (not (member b c)))
'(not (member c b a)))
nil)
(deftest subtypep.member.43
(check-equivalence
'(and (not (member a g b k e)) (not (member b h k c f)))
'(not (member c b k a e f g h)))
nil)
(deftest subtypep.member.44
(check-equivalence
'(and (integer 0 30) (not (member 3 4 5 9 10 11 17 18 19)))
'(or (integer 0 2) (integer 6 8) (integer 12 16) (integer 20 30)))
nil)
......@@ -368,3 +368,55 @@
(deftest typep.6
(typep 'a '(or (eql b)))
nil)
(deftest typep.7
(notnot-mv (typep 'a '(satisfies symbolp)))
t)
(deftest typep.8
(typep 10 '(satisfies symbolp))
nil)
(deftest typep.9
(let ((class (find-class 'symbol)))
(notnot-mv (typep 'a class)))
t)
(deftest typep.10
(let ((class (find-class 'symbol)))
(notnot-mv (typep 'a `(and ,class))))
t)
(deftest typep.11
(let ((class (find-class 'symbol)))
(typep 10 class))
nil)
(deftest typep.12
(let ((class (find-class 'symbol)))
(typep 10 `(and ,class)))
nil)
(deftest typep.13
(typep 'a '(and symbol integer))
nil)
(deftest typep.14
(notnot-mv (typep 'a '(or symbol integer)))
t)
(deftest typep.15
(notnot-mv (typep 'a '(or integer symbol)))
t)
(deftest typep.16
(let ((c1 (find-class 'number))
(c2 (find-class 'symbol)))
(notnot-mv (typep 'a `(or ,c1 ,c2))))
t)
(deftest typep.17
(let ((c1 (find-class 'number))
(c2 (find-class 'symbol)))
(notnot-mv (typep 'a `(or ,c2 ,c1))))
t)
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