Commit ba030367 authored by pfdietz's avatar pfdietz

Moved various subtypep tests off into their own files; subtypep.lsp was getting too big.

parent 1f72a9d8
......@@ -250,6 +250,12 @@
(load "types-and-class-2.lsp")
(load "coerce.lsp")
(load "subtypep.lsp")
(load "subtypep-integer.lsp")
(load "subtypep-float.lsp")
(load "subtypep-rational.lsp")
(load "subtypep-cons.lsp")
(load "subtypep-member.lsp")
(load "subtypep-eql.lsp")
;;; Tests of the reader
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Feb 15 11:57:03 2003
;;;; Contains: Tests for subtype relationships on cons types
(in-package :cl-test)
;;; SUBTYPEP on CONS types
(defvar *cons-types*
'(cons (cons) (cons *) (cons * *) (cons t) (cons t t)
(cons t *) (cons * t)))
(deftest subtypep.cons.1
(loop for t1 in *cons-types*
append (loop for t2 in *cons-types*
unless (equal (mapcar #'notnot
(multiple-value-list
(subtypep t1 t2)))
'(t t))
collect (list t1 t2)))
nil)
(deftest subtypep.cons.2
(loop for t1 in '((cons nil) (cons nil *) (cons nil t)
(cons * nil) (cons t nil) (cons nil nil))
unless (subtypep t1 nil)
collect t1)
nil)
(deftest subtypep.cons.3
(check-equivalence '(and (cons symbol *) (cons * symbol))
'(cons symbol symbol))
nil)
(deftest subtypep.cons.4
(check-equivalence '(and (cons (integer 0 10) *)
(cons (integer 5 15) (integer 10 20))
(cons * (integer 15 25)))
'(cons (integer 5 10) (integer 15 20)))
nil)
(deftest subtypep.cons.5
(check-equivalence
'(and cons (not (cons symbol symbol)))
'(or (cons (not symbol) *)
(cons * (not symbol))))
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Feb 15 11:58:43 2003
;;;; Contains: Tests for subtype relationships on EQL types
(in-package :cl-test)
(deftest subtypep.eql.1
(let ((s1 (copy-seq "abc"))
(s2 (copy-seq "abc")))
(let ((t1 `(eql ,s1))
(t2 `(eql ,s2)))
(cond
((subtypep t1 t2) "T1 is subtype of T2")
((subtypep t2 t1) "T2 is subtype of T1")
(t (check-disjointness t1 t2)))))
nil)
(deftest subtypep.eql.2
(let ((s1 (copy-seq '(a b c)))
(s2 (copy-seq '(a b c))))
(let ((t1 `(eql ,s1))
(t2 `(eql ,s2)))
(cond
((subtypep t1 t2) "T1 is subtype of T2")
((subtypep t2 t1) "T2 is subtype of T1")
(t (check-disjointness t1 t2)))))
nil)
(deftest subtypep.eql.3
(let ((i1 (1+ most-positive-fixnum))
(i2 (1+ most-positive-fixnum)))
(check-equivalence `(eql ,i1) `(eql ,i2)))
nil)
(deftest subtypep.eql.4
(check-equivalence '(and (eql a) (eql b)) nil)
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Feb 15 11:55:37 2003
;;;; Contains: Tests for subtype relationships on float types
(in-package :cl-test)
;;;;;;;
(deftest subtypep.float.1
(loop for tp in +float-types+
append (check-subtypep tp 'float t t))
nil)
(deftest subtypep.float.2
(if (subtypep 'short-float 'long-float)
(loop for tp in +float-types+
append
(loop for tp2 in +float-types+
append (check-subtypep tp tp2 t t)))
nil)
nil)
(deftest subtypep.float.3
(if (and (not (subtypep 'short-float 'single-float))
(subtypep 'single-float 'long-float))
(append
(check-equivalence 'single-float 'double-float)
(check-equivalence 'single-float 'long-float)
(check-equivalence 'double-float 'long-float)
(classes-are-disjoint 'short-float 'single-float)
(classes-are-disjoint 'short-float 'double-float)
(classes-are-disjoint 'short-float 'long-float))
nil)
nil)
(deftest subtypep.float.4
(if (and (subtypep 'single-float 'short-float)
(subtypep 'double-float 'long-float)
(not (subtypep 'short-float 'double-float)))
(append
(check-equivalence 'short-float 'single-float)
(check-equivalence 'double-float 'long-float)
(loop for tp in '(short-float single-float)
append
(loop for tp2 in '(double-float long-float)
append (classes-are-disjoint tp tp2))))
nil)
nil)
(deftest subtypep.float.5
(if (and (not (subtypep 'single-float 'short-float))
(not (subtypep 'single-float 'double-float))
(subtypep 'double-float 'long-float))
(append
(classes-are-disjoint 'short-float 'single-float)
(classes-are-disjoint 'short-float 'double-float)
(classes-are-disjoint 'short-float 'long-float)
(classes-are-disjoint 'single-float 'double-float)
(classes-are-disjoint 'single-float 'long-float)
(check-equivalence 'double-float 'long-float))
nil)
nil)
(deftest subtypep.float.6
(if (and (subtypep 'single-float 'short-float)
(not (subtypep 'single-float 'double-float))
(not (subtypep 'double-float 'long-float)))
(append
(check-equivalence 'short-float 'single-float)
(classes-are-disjoint 'single-float 'double-float)
(classes-are-disjoint 'single-float 'long-float)
(classes-are-disjoint 'double-float 'long-float))
nil)
nil)
(deftest subtypep.float.7
(if (and (not (subtypep 'single-float 'short-float))
(not (subtypep 'single-float 'double-float))
(not (subtypep 'double-float 'long-float)))
(loop for tp in +float-types+
append
(loop for tp2 in +float-types+
unless (eq tp tp2)
append (classes-are-disjoint tp tp2)))
nil)
nil)
(deftest subtypep.float.8
(subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 11.0s0))
t t)
(deftest subtypep.float.9
(subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 11.0f0))
t t)
(deftest subtypep.float.10
(subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 11.0d0))
t t)
(deftest subtypep.float.11
(subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 11.0l0))
t t)
(deftest subtypep.float.12
(subtypep* '(short-float 0.0s0 11.0s0) '(short-float 0.0s0 10.0s0))
nil t)
(deftest subtypep.float.13
(subtypep* '(single-float 0.0f0 11.0f0) '(single-float 0.0f0 10.0f0))
nil t)
(deftest subtypep.float.14
(subtypep* '(double-float 0.0d0 11.0d0) '(double-float 0.0d0 10.0d0))
nil t)
(deftest subtypep.float.15
(subtypep* '(long-float 0.0l0 11.0l0) '(long-float 0.0l0 10.0l0))
nil t)
(deftest subtypep.float.16
(subtypep* '(short-float 0.0s0 (10.0s0)) '(short-float 0.0s0 10.0s0))
t t)
(deftest subtypep.float.17
(subtypep* '(single-float 0.0f0 (10.0f0)) '(single-float 0.0f0 10.0f0))
t t)
(deftest subtypep.float.18
(subtypep* '(double-float 0.0d0 (10.0d0)) '(double-float 0.0d0 10.0d0))
t t)
(deftest subtypep.float.19
(subtypep* '(long-float 0.0l0 (10.0l0)) '(long-float 0.0l0 10.0l0))
t t)
(deftest subtypep.float.20
(subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 (10.0s0)))
nil t)
(deftest subtypep.float.21
(subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 (10.0f0)))
nil t)
(deftest subtypep.float.22
(subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 (10.0d0)))
nil t)
(deftest subtypep.float.23
(subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 (10.0l0)))
nil t)
(deftest subtypep.float.24
(check-equivalence '(and (short-float 0.0s0 2.0s0)
(short-float 1.0s0 3.0s0))
'(short-float 1.0s0 2.0s0))
nil)
(deftest subtypep.float.25
(check-equivalence '(and (single-float 0.0f0 2.0f0)
(single-float 1.0f0 3.0f0))
'(single-float 1.0f0 2.0f0))
nil)
(deftest subtypep.float.26
(check-equivalence '(and (double-float 0.0d0 2.0d0)
(double-float 1.0d0 3.0d0))
'(double-float 1.0d0 2.0d0))
nil)
(deftest subtypep.float.27
(check-equivalence '(and (long-float 0.0l0 2.0l0)
(long-float 1.0l0 3.0l0))
'(long-float 1.0l0 2.0l0))
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Feb 15 11:54:05 2003
;;;; Contains: Tests for subtype relationships on integer types
(in-package :cl-test)
(deftest subtypep.fixnum-or-bignum
(check-equivalence '(or fixnum bignum) 'integer)
nil)
(deftest subtypep.fixnum.integer
(check-equivalence `(integer ,most-negative-fixnum ,most-positive-fixnum)
'fixnum)
nil)
(deftest subtypep.bignum.integer
(check-equivalence
`(or (integer * (,most-negative-fixnum))
(integer (,most-positive-fixnum) *))
'bignum)
nil)
;;;;;;;
(deftest subtypep.integer.1
(subtypep* '(integer 0 10) '(integer 0 20))
t t)
(deftest subtypep.integer.2
(subtypep* '(integer 0 10) '(integer 0 (10)))
nil t)
(deftest subtypep.integer.3
(subtypep* '(integer 10 100) 'integer)
t t)
(deftest subtypep.integer.4
(subtypep* 'integer '(integer 10 100))
nil t)
(deftest subtypep.integer.5
(subtypep* '(integer 10 *) 'integer)
t t)
(deftest subtypep.integer.6
(subtypep* 'integer '(integer 10 *))
nil t)
(deftest subtypep.integer.7
(subtypep* '(integer 10) 'integer)
t t)
(deftest subtypep.integer.8
(subtypep* 'integer '(integer 10))
nil t)
(deftest subtypep.integer.9
(subtypep* '(integer * 10) 'integer)
t t)
(deftest subtypep.integer.10
(subtypep* 'integer '(integer * 10))
nil t)
(deftest subtypep.integer.11
(subtypep* '(integer 10) '(integer 5))
t t)
(deftest subtypep.integer.12
(subtypep* '(integer 5) '(integer 10))
nil t)
(deftest subtypep.integer.13
(subtypep* '(integer 10 *) '(integer 5))
t t)
(deftest subtypep.integer.14
(subtypep* '(integer 5) '(integer 10 *))
nil t)
(deftest subtypep.integer.15
(subtypep* '(integer 10) '(integer 5 *))
t t)
(deftest subtypep.integer.16
(subtypep* '(integer 5 *) '(integer 10))
nil t)
(deftest subtypep.integer.17
(subtypep* '(integer 10 *) '(integer 5 *))
t t)
(deftest subtypep.integer.18
(subtypep* '(integer 5 *) '(integer 10 *))
nil t)
(deftest subtypep.integer.19
(subtypep* '(integer * 5) '(integer * 10))
t t)
(deftest subtypep.integer.20
(subtypep* '(integer * 10) '(integer * 5))
nil t)
(deftest subtypep.integer.21
(subtypep* '(integer 10 *) '(integer * 10))
nil t)
(deftest subtypep.integer.22
(subtypep* '(integer * 10) '(integer 10 *))
nil t)
(deftest subtypep.integer.23
(check-equivalence '(integer (9)) '(integer 10))
nil)
(deftest subtypep.integer.24
(check-equivalence '(integer * (11)) '(integer * 10))
nil)
(deftest subtypep.integer.25
(check-equivalence
'(and (or (integer 0 10) (integer 20 30))
(or (integer 5 15) (integer 25 35)))
'(or (integer 5 10) (integer 25 30)))
nil)
(deftest subtypep.integer.26
(check-equivalence
'(and (integer 0 10) (integer 5 15))
'(integer 5 10))
nil)
(deftest subtypep.integer.27
(check-equivalence
'(or (integer 0 10) (integer 5 15))
'(integer 0 15))
nil)
(deftest subtypep.integer.28
(check-equivalence
'(and integer (not (eql 10)))
'(or (integer * 9) (integer 11 *)))
nil)
(deftest subtypep.integer.29
(check-equivalence
'(and integer (not (integer 1 10)))
'(or (integer * 0) (integer 11 *)))
nil)
(deftest subtypep.integer.30
(check-equivalence
'(and (integer -100 100) (not (integer 1 10)))
'(or (integer -100 0) (integer 11 100)))
nil)
(deftest subtypep.integer.31
(check-equivalence
'(and integer (real 4 10))
'(integer 4 10))
nil)
(deftest subtypep.integer.32
(check-equivalence
'(and (integer 4 *) (real * 10))
'(integer 4 10))
nil)
(deftest subtypep.integer.33
(check-equivalence
'(and (integer * 10) (real 4))
'(integer 4 10))
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Feb 15 11:58:06 2003
;;;; Contains: Tests for subtype relationships on member types
(in-package :cl-test)
;;; SUBTYPEP on MEMBER types
(deftest subtypep.member.1
(subtypep*-or-fail '(member a b c) '(member a b c d))
t)
(deftest subtypep.member.2
(subtypep*-not-or-fail '(member a b c) '(member a b))
t)
(deftest subtypep.member.3
(check-equivalence '(member) nil)
nil)
(deftest subtypep.member.4
(subtypep*-or-fail '(eql b) '(member a b c))
t)
(deftest subtypep.member.5
(subtypep*-or-fail '(member a b c d e) 'symbol)
t)
(deftest subtypep.member.6
(subtypep*-not-or-fail '(member a b 10 d e) 'symbol)
t)
(deftest subtypep.member.7
(subtypep*-or-fail 'null '(member a b nil c d e))
t)
(deftest subtypep.member.8
(subtypep*-not-or-fail 'null '(member a b c d e))
t)
(deftest subtypep.member.9
(let ((b1 (1+ most-positive-fixnum))
(b2 (1+ most-positive-fixnum)))
(subtypep*-or-fail `(member 10 ,b1 20) `(member 10 20 ,b2)))
t)
(deftest subtypep.member.10
(subtypep*-or-fail '(member :a :b :c) 'keyword)
t)
(deftest subtypep.member.11
(let ((b1 (copy-list '(a)))
(b2 (copy-list '(a))))
(subtypep*-not-or-fail `(member 10 ,b1 20) `(member 10 20 ,b2)))
t)
(deftest subtypep.member.12
(let ((b1 '(a)))
(subtypep*-or-fail `(member 10 ,b1 20) `(member 10 20 ,b1)))
t)
(deftest subtypep.member.13
(subtypep*-or-fail '(member 10 20 30) '(integer 0 100))
t)
(deftest subtypep.member.14
(subtypep*-or-fail '(integer 3 6) '(member 0 1 2 3 4 5 6 7 8 100))
t)
(deftest subtypep.member.15
(subtypep*-not-or-fail '(integer 3 6) '(member 0 1 2 3 5 6 7 8))
t)
(deftest subtypep.member.16
(check-equivalence '(integer 2 5) '(member 2 5 4 3))
nil)
(deftest subtypep.member.17
(let ((s1 (copy-seq "abc"))
(s2 (copy-seq "abc")))
(let ((t1 `(member ,s1))
(t2 `(member ,s2)))
(cond
((subtypep t1 t2) "T1 is subtype of T2")
((subtypep t2 t1) "T2 is subtype of T1")
(t (check-disjointness t1 t2)))))
nil)
(deftest subtypep.member.18
(let ((s1 (copy-seq '(a b c)))
(s2 (copy-seq '(a b c))))
(let ((t1 `(member ,s1))
(t2 `(member ,s2)))
(cond
((subtypep t1 t2) "T1 is subtype of T2")
((subtypep t2 t1) "T2 is subtype of T1")
(t (check-disjointness t1 t2)))))
nil)
(deftest subtypep.member.19
(let ((i1 (1+ most-positive-fixnum))
(i2 (1+ most-positive-fixnum)))
(check-equivalence `(member 0 ,i1) `(member 0 ,i2)))
nil)
(deftest subtypep.member.20
(check-equivalence '(and (member a b c d) (member e d b f g))
'(member b d))
nil)
(deftest subtypep.member.21
(check-equivalence '(and (member a b c d) (member e d f g))
'(eql d))
nil)
(deftest subtypep.member.22
(check-equivalence '(and (member a b c d) (member e f g))
nil)
nil)
(deftest subtypep.member.23
(check-equivalence '(or (member a b c) (member z b w))
'(member z a b w c))
nil)
(deftest subtypep.member.24
(check-equivalence '(or (member a b c) (eql d))
'(member d c b a))
nil)
(deftest subtypep.member.25
(check-equivalence 'boolean '(member nil t))
nil)
(deftest subtypep.member.26
(check-equivalence '(or (eql a) (eql b))
'(member a b))
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Feb 15 11:56:19 2003
;;;; Contains: Tests for subtype relationships on rational types
(in-package :cl-test)
;;; SUBTYPEP on rational types
(deftest subtypep.rational.1
(subtypep* '(rational 10 *) 'rational)
t t)
(deftest subtypep.rational.2
(subtypep* '(rational 10) 'rational)
t t)
(deftest subtypep.rational.3
(subtypep* '(rational * 10) 'rational)
t t)
(deftest subtypep.rational.4
(subtypep '(rational 10 20) 'rational)
t t)
(deftest subtypep.rational.5
(subtypep '(rational (10) 20) 'rational)
t t)
(deftest subtypep.rational.6
(subtypep '(rational 10 (20)) 'rational)
t t)
(deftest subtypep.rational.7
(subtypep '(rational (10) (20)) 'rational)
t t)
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment