From c5827567172f20ba46318cd87b3f4b167e1baad2 Mon Sep 17 00:00:00 2001 From: pfdietz Date: Sun, 2 Mar 2003 14:25:07 +0000 Subject: [PATCH] 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. --- ansi-tests/ansi-aux.lsp | 7 +++ ansi-tests/ctypecase.lsp | 8 +++ ansi-tests/etypecase.lsp | 7 +++ ansi-tests/handler-bind.lsp | 44 +++++++++++++ ansi-tests/handler-case.lsp | 9 +++ ansi-tests/load-types-and-class.lsp | 2 + ansi-tests/subtypep-array.lsp | 98 +++++++++++++++++++++++++++++ ansi-tests/typecase.lsp | 6 ++ 8 files changed, 181 insertions(+) create mode 100644 ansi-tests/handler-case.lsp create mode 100644 ansi-tests/subtypep-array.lsp diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 0237b82..3bf447c 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -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)) diff --git a/ansi-tests/ctypecase.lsp b/ansi-tests/ctypecase.lsp index c49a441..7e7ea50 100644 --- a/ansi-tests/ctypecase.lsp +++ b/ansi-tests/ctypecase.lsp @@ -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) + diff --git a/ansi-tests/etypecase.lsp b/ansi-tests/etypecase.lsp index 3942946..06d46ec 100644 --- a/ansi-tests/etypecase.lsp +++ b/ansi-tests/etypecase.lsp @@ -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) + diff --git a/ansi-tests/handler-bind.lsp b/ansi-tests/handler-bind.lsp index 106059f..2bbef0c 100644 --- a/ansi-tests/handler-bind.lsp +++ b/ansi-tests/handler-bind.lsp @@ -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 diff --git a/ansi-tests/handler-case.lsp b/ansi-tests/handler-case.lsp new file mode 100644 index 0000000..373bad4 --- /dev/null +++ b/ansi-tests/handler-case.lsp @@ -0,0 +1,9 @@ +;-*- 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 (( diff --git a/ansi-tests/load-types-and-class.lsp b/ansi-tests/load-types-and-class.lsp index 05023d1..3ad82e4 100644 --- a/ansi-tests/load-types-and-class.lsp +++ b/ansi-tests/load-types-and-class.lsp @@ -11,3 +11,5 @@ #-lispworks (load "subtypep-cons.lsp") (load "subtypep-member.lsp") (load "subtypep-eql.lsp") +(load "subtypep-array.lsp") + diff --git a/ansi-tests/subtypep-array.lsp b/ansi-tests/subtypep-array.lsp new file mode 100644 index 0000000..fde2604 --- /dev/null +++ b/ansi-tests/subtypep-array.lsp @@ -0,0 +1,98 @@ +;-*- 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 diff --git a/ansi-tests/typecase.lsp b/ansi-tests/typecase.lsp index f318531..2c83a42 100644 --- a/ansi-tests/typecase.lsp +++ b/ansi-tests/typecase.lsp @@ -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) -- GitLab