From 6571fe757dd44e29d80dd6a7564db5f9af7fbee9 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Fri, 31 Jan 2003 02:13:02 +0000
Subject: [PATCH] Added more disjointness tests; tweaked check-disjointness.

---
 ansi-tests/ansi-aux.lsp         | 22 ++++++++--------------
 ansi-tests/cl-test-package.lsp  |  2 +-
 ansi-tests/compile-and-load.lsp |  2 ++
 ansi-tests/types-and-class.lsp  | 17 +++++++++++++++++
 4 files changed, 28 insertions(+), 15 deletions(-)

diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp
index f8ac1525..ac2cc4ee 100644
--- a/ansi-tests/ansi-aux.lsp
+++ b/ansi-tests/ansi-aux.lsp
@@ -153,20 +153,14 @@ Results: ~A~%" expected-number form n results))))
 (defun check-subtypep (type1 type2 is-sub &optional should-be-valid)
   (multiple-value-bind
       (sub valid)
-      (subtypep* type1 type2)
-    (cond
-     (valid
-      (cond
-       ((and sub (not is-sub))
-	`((SUBTYPEP ',type1 ',type2)
-	  "==> <true>, <true>, expected NIL."))
-       ((and (not sub) is-sub)
-	`((SUBTYPEP ',type1 ',type2)
-	  "==> <false>, <true>, expected <true>."))
-       (t nil)))
-     (should-be-valid
-      `((SUBTYPEP ',type1 ',type2) "did not succeed but should have."))
-     (t nil))))	 
+      (subtypep type1 type2)
+    (unless (constantp type1) (setq type1 (list 'quote type1)))
+    (unless (constantp type2) (setq type2 (list 'quote type2)))
+    (if (or (and valid sub (not is-sub))
+	    (and valid (not sub) is-sub)
+	    (and (not valid) should-be-valid))
+	`((SUBTYPEP ,type1 ,type2) cl-user::==> ,sub ,valid)
+      nil)))
 
 (defun check-type-predicate (P TYPE)
   "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
diff --git a/ansi-tests/cl-test-package.lsp b/ansi-tests/cl-test-package.lsp
index 7b736946..54aa2eb8 100644
--- a/ansi-tests/cl-test-package.lsp
+++ b/ansi-tests/cl-test-package.lsp
@@ -7,7 +7,7 @@
   (:use :cl :rt)
   #+gcl (:use defpackage)
   (:nicknames)
-  (:import-from "COMMON-LISP-USER" "COMPILE-AND-LOAD")
+  (:import-from "COMMON-LISP-USER" "COMPILE-AND-LOAD" "==>")
   (:export))
 
 #+cmu (import 'cl::quit :cl-test)
diff --git a/ansi-tests/compile-and-load.lsp b/ansi-tests/compile-and-load.lsp
index fc4dfa9a..522842c1 100644
--- a/ansi-tests/compile-and-load.lsp
+++ b/ansi-tests/compile-and-load.lsp
@@ -1,6 +1,8 @@
 (in-package "COMMON-LISP-USER")
 
+
 (eval-when (load eval compile)
+  (intern "==>" "CL-USER")
   (unless (fboundp 'compile-file-pathname)
     (defun compile-file-pathname (pathname)
       (make-pathname :defaults pathname :type "o"))))
diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp
index 60e6732c..fdf67ad0 100644
--- a/ansi-tests/types-and-class.lsp
+++ b/ansi-tests/types-and-class.lsp
@@ -185,6 +185,18 @@
   (check-disjointness 'integer 'ratio)
   nil)
 
+(deftest fixnum-and-ratio-are-disjoint
+  (check-disjointness 'fixnum 'ratio)
+  nil)
+
+(deftest byte8-and-ratio-are-disjoint
+  (check-disjointness '(unsigned-byte 8) 'ratio)
+  nil)
+
+(deftest bit-and-ratio-are-disjoint
+  (check-disjointness 'bit 'ratio)
+  nil)
+
 (deftest integer-and-float-are-disjoint
   (check-disjointness 'integer 'float)
   nil)
@@ -197,6 +209,11 @@
   (check-disjointness 'complex 'float)
   nil)
 
+(deftest integer-subranges-are-disjoint
+  (check-disjointness '(integer 0 (10)) '(integer 10 (20)))
+  nil)
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; deftype
 
-- 
GitLab