From e500481b08f78fe701bbb8b6cd753f5d131d1d17 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sat, 14 Dec 2002 04:54:00 +0000 Subject: [PATCH] Added tests that structure types are disjoint from classes in *disjoint-type-list*. Added tests for COERCE. --- ansi-tests/ansi-aux.lsp | 5 ++ ansi-tests/coerce.lsp | 157 +++++++++++++++++++++++++++++++++ ansi-tests/gclload2.lsp | 1 + ansi-tests/structure-00.lsp | 24 +++++ ansi-tests/types-and-class.lsp | 5 +- 5 files changed, 188 insertions(+), 4 deletions(-) create mode 100644 ansi-tests/coerce.lsp diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 67777821..8b8cbdc1 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -353,6 +353,11 @@ the condition to go uncaught if it cannot be classified." ;;; From types-and-class.lsp +(defvar *disjoint-types-list* + '(cons symbol array + number character hash-table function readtable package + pathname stream random-state condition restart)) + (defun is-t-or-nil (e) (or (eqt e t) (eqt e nil))) diff --git a/ansi-tests/coerce.lsp b/ansi-tests/coerce.lsp new file mode 100644 index 00000000..2ee820a8 --- /dev/null +++ b/ansi-tests/coerce.lsp @@ -0,0 +1,157 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Dec 13 20:48:04 2002 +;;;; Contains: Tests for COERCE + +(in-package :cl-test) + +(deftest coerce.1 + (loop for x in *universe* + count (not (eq (coerce x (type-of x)) x))) + 0) + +(deftest coerce.2 + (loop for x in *universe* + count (not (eq (coerce x t) x))) + 0) + +(deftest coerce.3 + (loop for x in *universe* + for class = (class-of x) + count (and class (not (eq (coerce x class) x)))) + 0) + +(deftest coerce.4 + (loop for x in '(() #() #*) + never (coerce x 'list)) + t) + +(deftest coerce.5 + (loop for x in '((1 0) #(1 0) #*10) + always (equal (coerce x 'list) '(1 0))) + t) + +(deftest coerce.6 + (loop for x in '(() #() #*) + always (equalp (coerce x 'vector) #())) + t) + +(deftest coerce.7 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x 'vector) + always (and (equalp y #(1 0)) + (vectorp y))) + t) + +(deftest coerce.8 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x '(vector *)) + always (and (equalp y #(1 0)) + (vectorp y))) + t) + +(deftest coerce.9 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x '(vector * 2)) + always (and (equalp y #(1 0)) + (vectorp y))) + t) + +(deftest coerce.10 + (values (coerce #\A 'character) + (coerce '|A| 'character) + (coerce "A" 'character)) + #\A #\A #\A) + +(deftest coerce.11 + (loop with class = (find-class 'vector) + for x in '((1 0) #(1 0) #*10) + for y = (coerce x class) + always (and (equalp y #(1 0)) + (vectorp y))) + t) + +(deftest coerce.12 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x 'bit-vector) + always (and (equalp y #*10) + (bit-vector-p y))) + t) + +(deftest coerce.13 + (loop for x in '((#\a #\b #\c) "abc") + for y = (coerce x 'string) + always (and (stringp y) + (string= y "abc"))) + t) + +(deftest coerce.14 + (loop for x in '((#\a #\b #\c) "abc") + for y = (coerce x 'simple-string) + always (and (typep y 'simple-string) + (string= y "abc"))) + t) + +(deftest coerce.15 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x 'simple-vector) + always (and (equalp y #(1 0)) + (simple-vector-p y))) + t) + +(deftest coerce.16 + (coerce 0 'integer) + 0) + +(deftest coerce.17 + (coerce 0 'complex) + 0) + +(deftest coerce.18 + (coerce 3 'complex) + 3) + +(deftest coerce.19 + (coerce 5/3 'complex) + 5/3) + +(deftest coerce.20 + (coerce 1.0 'complex) + #c(1.0 0.0)) + +(deftest coerce.21 + (eqt (symbol-function 'car) + (coerce 'car 'function)) + t) + +(deftest coerce.22 + (funcall (coerce '(lambda () 10) 'function)) + 10) + +;;; Error tests + +(deftest coerce.error.1 + (classify-error (coerce -1 '(integer 0 100))) + type-error) + +(deftest coerce.error.2 + (classify-error (coerce '(a b c) '(vector * 2))) + type-error) + +(deftest coerce.error.3 + (classify-error (coerce '(a b c) '(vector * 4))) + type-error) + +(deftest coerce.error.4 + (classify-error (coerce nil 'cons)) + type-error) + +(deftest coerce.error.5 + (handler-case (eval '(coerce 'not-a-bound-function 'function)) + (error () :caught)) + :caught) + + + + + \ No newline at end of file diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp index 553eaa60..abd0c770 100644 --- a/ansi-tests/gclload2.lsp +++ b/ansi-tests/gclload2.lsp @@ -178,6 +178,7 @@ ;;; Tests of types and classes (load "types-and-class.lsp") +(load "coerce.lsp") ;;; Tests of the reader diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp index 968c6ae6..89546655 100644 --- a/ansi-tests/structure-00.lsp +++ b/ansi-tests/structure-00.lsp @@ -390,6 +390,30 @@ do the defstruct." (deftest ,(make-struct-test-name name 15) (notnot (typep (,make-fn) 'structure-object)) t) + (deftest ,(make-struct-test-name name 16) + (loop for type in *disjoint-types-list* + unless (and + (equalt (multiple-value-list + (subtypep* type (quote ,name))) + '(nil t)) + (equalt (multiple-value-list + (subtypep* (quote ,name) type)) + '(nil t))) + collect type) + nil) + (deftest ,(make-struct-test-name name 17) + (let ((class (find-class (quote ,name)))) + (loop for type in *disjoint-types-list* + unless (and + (equalt (multiple-value-list + (subtypep* type class)) + '(nil t)) + (equalt (multiple-value-list + (subtypep* class type)) + '(nil t))) + collect type)) + nil) )) nil ))) + diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp index ac14d82b..e2f9db72 100644 --- a/ansi-tests/types-and-class.lsp +++ b/ansi-tests/types-and-class.lsp @@ -221,10 +221,7 @@ (types-6-body) 0) -(defvar *disjoint-types-list* - '(cons symbol array - number character hash-table function readtable package - pathname stream random-state condition restart)) +(declaim (special *disjoint-types-list*)) (deftest types-7 (loop -- GitLab