Commit 800cefe6 authored by pfdietz's avatar pfdietz

Added more subtype, disjointness tests. Move some off to a new file, type-and-class-2.lsp

parent 4747ed76
......@@ -333,10 +333,22 @@ the condition to go uncaught if it cannot be classified."
;;; This auxiliary function returns booleans instead
;;; (which makes it easier to write tests).
;;;
(defun subtypep* (obj type)
(defun subtypep* (type1 type2)
(apply #'values
(mapcar #'notnot
(multiple-value-list (subtypep obj type)))))
(multiple-value-list (subtypep type1 type2)))))
(defun subtypep*-or-fail (type1 type2)
(let ((results (multiple-value-list (subtypep type1 type2))))
(and (= (length results) 2)
(or (not (second results))
(notnot (first results))))))
(defun subtypep*-not-or-fail (type1 type2)
(let ((results (multiple-value-list (subtypep type1 type2))))
(and (= (length results) 2)
(or (not (second results))
(not (first results))))))
;;; (eval-when (load eval compile)
;;; (unless (fboundp 'complement)
......
......@@ -246,6 +246,7 @@
;;; Tests of types and classes
(load "types-and-class.lsp")
(load "types-and-class-2.lsp")
(load "coerce.lsp")
(load "subtypep.lsp")
......
......@@ -130,6 +130,8 @@
'bignum)
nil)
;;;;;;;
(deftest subtypep.integer.1
(subtypep* '(integer 0 10) '(integer 0 20))
t t)
......@@ -138,6 +140,96 @@
(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.float.1
(loop for tp in +float-types+
append (check-subtypep tp 'float t t))
......@@ -256,3 +348,73 @@
collect t1)
nil)
;;; 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)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Feb 5 21:20:05 2003
;;;; Contains: More tests of types and classes
(in-package :cl-test)
;;; Union of a type with its complement is universal
(deftest type-or-not-type-is-everything
(loop for l in *disjoint-types-list2*
append
(loop
for type in l
append (check-subtypep t `(or ,type (not ,type)) t)
append (check-subtypep t `(or (not ,type) ,type) t)))
nil)
(defclass tac-1-class () (a b c))
(defclass tac-1a-class (tac-1-class) (d e))
(defclass tac-1b-class (tac-1-class) (f g))
(deftest user-class-disjointness
(loop for l in *disjoint-types-list2*
append
(loop
for type in l
append (classes-are-disjoint type 'tac-1-class)))
nil)
(deftest user-class-disjointness-2
(check-disjointness 'tac-1a-class 'tac-1b-class)
nil)
(defstruct tac-2-struct a b c)
(defstruct (tac-2a-struct (:include tac-2-struct)) d e)
(defstruct (tac-2b-struct (:include tac-2-struct)) f g)
(deftest user-struct-disjointness
(loop for l in *disjoint-types-list2*
append
(loop
for type in l
append (check-disjointness type 'tac-2-struct)))
nil)
(deftest user-struct-disjointness-2
(check-disjointness 'tac-2a-struct 'tac-2b-struct)
nil)
(defclass tac-3-a () (x))
(defclass tac-3-b () (y))
(defclass tac-3-c () (z))
(defclass tac-3-ab (tac-3-a tac-3-b) ())
(defclass tac-3-ac (tac-3-a tac-3-c) ())
(defclass tac-3-bc (tac-3-b tac-3-c) ())
(defclass tac-3-abc (tac-3-ab tac-3-ac tac-3-bc) ())
(deftest tac-3.1
(subtypep* 'tac-3-ab 'tac-3-a)
t t)
(deftest tac-3.2
(subtypep* 'tac-3-ab 'tac-3-b)
t t)
(deftest tac-3.3
(subtypep* 'tac-3-ab 'tac-3-c)
nil t)
(deftest tac-3.4
(subtypep* 'tac-3-a 'tac-3-ab)
nil t)
(deftest tac-3.5
(subtypep* 'tac-3-b 'tac-3-ab)
nil t)
(deftest tac-3.6
(subtypep* 'tac-3-c 'tac-3-ab)
nil t)
(deftest tac-3.7
(subtypep* 'tac-3-abc 'tac-3-a)
t t)
(deftest tac-3.8
(subtypep* 'tac-3-abc 'tac-3-b)
t t)
(deftest tac-3.9
(subtypep* 'tac-3-abc 'tac-3-c)
t t)
(deftest tac-3.10
(subtypep* 'tac-3-abc 'tac-3-ab)
t t)
(deftest tac-3.11
(subtypep* 'tac-3-abc 'tac-3-ac)
t t)
(deftest tac-3.12
(subtypep* 'tac-3-abc 'tac-3-bc)
t t)
(deftest tac-3.13
(subtypep* 'tac-3-ab 'tac-3-abc)
nil t)
(deftest tac-3.14
(subtypep* 'tac-3-ac 'tac-3-abc)
nil t)
(deftest tac-3.15
(subtypep* 'tac-3-bc 'tac-3-abc)
nil t)
(deftest tac-3.16
(check-equivalence '(and tac-3-a tac-3-b) 'tac-3-ab)
nil)
(deftest tac-3.17
(check-equivalence '(and (or tac-3-a tac-3-b)
(or (not tac-3-a) (not tac-3-b))
(or tac-3-a tac-3-c)
(or (not tac-3-a) (not tac-3-c))
(or tac-3-b tac-3-c)
(or (not tac-3-b) (not tac-3-c)))
nil)
nil)
;;;
;;; Check that disjointness of types in *disjoint-types-list*
;;; is respected by all the elements of *universe*
;;;
(deftest universe-elements-in-at-most-one-disjoint-type
(loop for e in *universe*
for types = (remove-if-not #'(lambda (x) (typep e x))
*disjoint-types-list*)
when (> (length types) 1)
collect (list e types))
nil)
;;;;;
(deftest integer-and-ratio-are-disjoint
(classes-are-disjoint 'integer 'ratio)
nil)
(deftest bignum-and-ratio-are-disjoint
(classes-are-disjoint 'bignum 'ratio)
nil)
(deftest bignum-and-fixnum-are-disjoint
(classes-are-disjoint 'bignum 'fixnum)
nil)
(deftest fixnum-and-ratio-are-disjoint
(classes-are-disjoint 'fixnum 'ratio)
nil)
(deftest byte8-and-ratio-are-disjoint
(classes-are-disjoint '(unsigned-byte 8) 'ratio)
nil)
(deftest bit-and-ratio-are-disjoint
(classes-are-disjoint 'bit 'ratio)
nil)
(deftest integer-and-float-are-disjoint
(classes-are-disjoint 'integer 'float)
nil)
(deftest ratio-and-float-are-disjoint
(classes-are-disjoint 'ratio 'float)
nil)
(deftest complex-and-float-are-disjoint
(classes-are-disjoint 'complex 'float)
nil)
(deftest integer-subranges-are-disjoint
(classes-are-disjoint '(integer 0 (10)) '(integer 10 (20)))
nil)
(deftest keyword-and-null-are-disjoint
(classes-are-disjoint 'keyword 'null)
nil)
(deftest keyword-and-boolean-are-disjoint
(classes-are-disjoint 'keyword 'boolean)
nil)
......@@ -161,108 +161,7 @@
(types-9a-body)
0)
;;;
;;; Check that disjointness of types in *disjoint-types-list*
;;; is respected by all the elements of *universe*
;;;
(deftest universe-elements-in-at-most-one-disjoint-type
(loop for e in *universe*
for types = (remove-if-not #'(lambda (x) (typep e x))
*disjoint-types-list*)
when (> (length types) 1)
collect (list e types))
nil)
;;; Union of a type with its complement is universal
(deftest type-or-not-type-is-everything
(loop for l in *disjoint-types-list2*
append
(loop
for type in l
append (check-subtypep t `(or ,type (not ,type)) t)
append (check-subtypep t `(or (not ,type) ,type) t)))
nil)
(defclass tac-1-class () (a b c))
(defclass tac-1a-class (tac-1-class) (d e))
(defclass tac-1b-class (tac-1-class) (f g))
(deftest user-class-disjointness
(loop for l in *disjoint-types-list2*
append
(loop
for type in l
append (classes-are-disjoint type 'tac-1-class)))
nil)
(deftest user-class-disjointness-2
(check-disjointness 'tac-1a-class 'tac-1b-class)
nil)
(defstruct tac-2-struct a b c)
(defstruct (tac-2a-struct (:include tac-2-struct)) d e)
(defstruct (tac-2b-struct (:include tac-2-struct)) f g)
(deftest user-struct-disjointness
(loop for l in *disjoint-types-list2*
append
(loop
for type in l
append (check-disjointness type 'tac-2-struct)))
nil)
(deftest user-struct-disjointness-2
(check-disjointness 'tac-2a-struct 'tac-2b-struct)
nil)
(deftest integer-and-ratio-are-disjoint
(classes-are-disjoint 'integer 'ratio)
nil)
(deftest bignum-and-ratio-are-disjoint
(classes-are-disjoint 'bignum 'ratio)
nil)
(deftest bignum-and-fixnum-are-disjoint
(classes-are-disjoint 'bignum 'fixnum)
nil)
(deftest fixnum-and-ratio-are-disjoint
(classes-are-disjoint 'fixnum 'ratio)
nil)
(deftest byte8-and-ratio-are-disjoint
(classes-are-disjoint '(unsigned-byte 8) 'ratio)
nil)
(deftest bit-and-ratio-are-disjoint
(classes-are-disjoint 'bit 'ratio)
nil)
(deftest integer-and-float-are-disjoint
(classes-are-disjoint 'integer 'float)
nil)
(deftest ratio-and-float-are-disjoint
(classes-are-disjoint 'ratio 'float)
nil)
(deftest complex-and-float-are-disjoint
(classes-are-disjoint 'complex 'float)
nil)
(deftest integer-subranges-are-disjoint
(classes-are-disjoint '(integer 0 (10)) '(integer 10 (20)))
nil)
(deftest keyword-and-null-are-disjoint
(classes-are-disjoint 'keyword 'null)
nil)
(deftest keyword-and-boolean-are-disjoint
(classes-are-disjoint 'keyword 'boolean)
nil)
;;; Check that all class names in CL that name standard-classes or
......@@ -437,4 +336,3 @@
(notnot-mv (typep env (type-of env)))))
(%foo))
t)
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