Commit c5827567 authored by pfdietz's avatar pfdietz

Added tests for (e,c)typecase where the type specifier is a class object. ...

Added tests for (e,c)typecase where the type specifier is a class object.  Tests for handler-bind; stub file for tests for handler-case.  More subtypep tests on array types.
parent e3674151
......@@ -1419,3 +1419,10 @@ the condition to go uncaught if it cannot be classified."
(defun frob-simple-warning (c expected-fmt &rest expected-args)
(and (typep c 'simple-warning)
(apply #'frob-simple-condition c expected-fmt expected-args)))
(defparameter *array-element-types*
'(t (integer 0 0)
bit (unsigned-byte 8) (unsigned-byte 16)
(unsigned-byte 32) float short-float
single-float double-float long-float
nil character base-char symbol boolean null))
......@@ -78,3 +78,11 @@
;;; (deftest ctypecase.error.1
;;; (classify-error (ctypecase))
;;; program-error)
(deftest ctypecase.13
(ctypecase 'a
(number 'bad)
(#.(find-class 'symbol nil) 'good))
good)
......@@ -52,3 +52,10 @@
(deftest etypecase.11
(etypecase 1 (integer) (t 'a))
nil)
(deftest etypecase.12
(etypecase 'a
(number 'bad)
(#.(find-class 'symbol nil) 'good))
good)
......@@ -89,6 +89,50 @@
(error "an error"))))
good)
(deftest handler-bind.13
(handler-bind
((error #'(lambda (c) (declare (ignore c))
(throw 'done 'good))))
(catch 'done
(error "an error")))
good)
(deftest handler-bind.14
(catch 'done
(handler-bind
((symbol #'identity) ;; can never succeed
(error #'(lambda (c) (declare (ignore c))
(throw 'done 'good))))
(error "an error")))
good)
(deftest handler-bind.15
(catch 'done
(handler-bind
((t #'(lambda (c) (declare (ignore c))
(throw 'done 'good))))
(error "an error")))
good)
(deftest handler-bind.16
(catch 'done
(handler-bind
(((not error) #'identity)
(error
#'(lambda (c) (declare (ignore c))
(throw 'done 'good))))
(error "an error")))
good)
(deftest handler-bind.17
(catch 'done
(handler-bind
((#.(find-class 'error)
#'(lambda (c) (declare (ignore c))
(throw 'done 'good))))
(error "an error")))
good)
;;; More handler-bind tests elsewhere
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Mar 1 14:08:07 2003
;;;; Contains: Tests of HANDLER-CASE
(in-package :cl-test)
;;; (deftest handler-case.1
;;; (handler-case ((
......@@ -11,3 +11,5 @@
#-lispworks (load "subtypep-cons.lsp")
(load "subtypep-member.lsp")
(load "subtypep-eql.lsp")
(load "subtypep-array.lsp")
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Mar 1 16:23:57 2003
;;;; Contains: Tests of SUBTYPEP on array types
(in-package :cl-test)
;;; *array-element-types* is defined in ansi-aux.lsp
(deftest subtypep.array.1
(let ((array-types (cons (find-class 'array)
'(array (array) (array *) (array * *)))))
(loop for tp1 in array-types append
(loop for tp2 in array-types
unless (subtypep tp1 tp2)
collect (list tp1 tp2))))
nil)
(deftest subtypep.array.2
(and (subtypep* '(array t) '(array t *))
(subtypep* '(array t *) '(array t))
t)
t)
(deftest subtypep.array.3
(loop for i from 0 below (min 16 array-rank-limit)
for type = `(array * ,i)
for type2 = `(array * ,(make-list i :initial-element '*))
unless (and (subtypep type 'array)
(subtypep type '(array))
(subtypep type '(array *))
(subtypep type '(array * *))
(subtypep type type2))
collect type)
nil)
(deftest subtypep.array.4
(loop for i from 0 below (min 16 array-rank-limit)
for type = `(array t ,i)
for type2 = `(array t ,(make-list i :initial-element '*))
unless (and (subtypep type '(array t))
(subtypep type '(array t *))
(subtypep type type2))
collect type)
nil)
(deftest subtypep.array.5
(loop
for element-type in (cons '* *array-element-types*)
nconc
(loop for i from 0 below (min 16 array-rank-limit)
for type = `(array ,element-type ,i)
for type2 = `(array ,element-type ,(make-list i :initial-element '0))
for type3 = `(array ,element-type ,(make-list i :initial-element '1))
unless
(and (subtypep type2 type)
(subtypep type3 type)
(loop for j from 0 to i
always
(and
(subtypep
`(array ,element-type
(,@(make-list j :initial-element '*)
,@(make-list (- i j) :initial-element 2)))
type)
(subtypep
`(array ,element-type
(,@(make-list j :initial-element 2)
,@(make-list (- i j) :initial-element '*)))
type))))
collect type))
nil)
(deftest subtypep.aray.6
(loop
for etype in (cons '* *array-element-types*)
append
(check-equivalence
`(and (array ,etype (* 10 * * *))
(array ,etype (* * * 29 *)))
`(array ,etype (* 10 * 29 *))))
nil)
(deftest subtypep.aray.7
(let ((etypes *array-element-types*))
(loop
for etp1 in etypes
for uaetp1 = (upgraded-array-element-type etp1)
append
(loop for etp2 in etypes
for uaetp2 = (upgraded-array-element-type etp2)
when (equal (multiple-value-list (subtypep* uaetp1 uaetp2))
'(nil t))
append (check-disjointness `(array ,etp1) `(array ,etp2)))))
nil)
\ No newline at end of file
......@@ -64,3 +64,9 @@
(deftest typecase.14
(typecase 1 (symbol 'a) (otherwise))
nil)
(deftest typecase.15
(typecase 'a
(number 'bad)
(#.(find-class 'symbol nil) 'good))
good)
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