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