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