Commit bee3f982 authored by pfdietz's avatar pfdietz

Added more subtypep tests.

parent 2c81c5a0
......@@ -136,6 +136,38 @@ Results: ~A~%" expected-number form n results))))
(loop for e in *universe*
always (or (not (typep e type1)) (typep e type2))))))
;;; Check that the subtype relationships implied
;;; by disjointness are not contradicted. Return NIL
;;; if ok, or a list of error messages if not.
(defun check-disjointness (type1 type2)
(remove 'nil
(list
(check-subtypep type1 type2 nil)
(check-subtypep type2 type1 nil)
(check-subtypep type1 `(not ,type2) t)
(check-subtypep type2 `(not ,type1) t)
(check-subtypep `(and ,type1 ,type2) nil t)
(check-subtypep `(and ,type2 ,type1) nil t)
)))
(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))))
(defun check-type-predicate (P TYPE)
"Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
by applying both to all elements of *UNIVERSE*. Print message
......@@ -442,6 +474,128 @@ the condition to go uncaught if it cannot be classified."
;;; From types-and-class.lsp
(defparameter +float-types+
'(long-float double-float short-float single-float))
(defparameter *subtype-table*
(let ((table
'(
(null symbol)
(symbol t)
#-(and cmu (not sparc)) (boolean symbol)
(standard-object t)
(function t)
(compiled-function function)
(generic-function function)
(standard-generic-function generic-function)
(class standard-object)
(built-in-class class)
(structure-class class)
(standard-class class)
(method standard-object)
(standard-method method)
(structure-object t)
(method-combination t)
(condition t)
(serious-condition condition)
(error serious-condition)
(type-error error)
(simple-type-error type-error)
(simple-condition condition)
(simple-type-error simple-condition)
(parse-error error)
(hash-table t)
(cell-error error)
(unbound-slot cell-error)
(warning condition)
(style-warning warning)
(storage-condition serious-condition)
(simple-warning warning)
(simple-warning simple-condition)
(keyword symbol)
(unbound-variable cell-error)
(control-error error)
(program-error error)
(undefined-function cell-error)
(package t)
(package-error error)
(random-state t)
(number t)
(real number)
(complex number)
(float real)
(short-float float)
(single-float float)
(double-float float)
(long-float float)
(rational real)
(integer rational)
(ratio rational)
(signed-byte integer)
(integer signed-byte)
(unsigned-byte signed-byte)
(bit unsigned-byte)
(fixnum integer)
(bignum integer)
(bit fixnum)
(arithmetic-error error)
(division-by-zero arithmetic-error)
(floating-point-invalid-operation arithmetic-error)
(floating-point-inexact arithmetic-error)
(floating-point-overflow arithmetic-error)
(floating-point-underflow arithmetic-error)
(character t)
(base-char character)
(standard-char base-char)
(extended-char character)
(sequence t)
(list sequence)
(null list)
#-(and cmu (not sparc)) (null boolean)
(cons list)
(array t)
(simple-array array)
(vector sequence)
(vector array)
(string vector)
(bit-vector vector)
(simple-vector vector)
(simple-vector simple-array)
(simple-bit-vector bit-vector)
(simple-bit-vector simple-array)
(base-string string)
(simple-string string)
(simple-string simple-array)
(simple-base-string base-string)
(simple-base-string simple-string)
(pathname t)
(logical-pathname pathname)
(file-error error)
(stream t)
(broadcast-stream stream)
(concatenated-stream stream)
(echo-stream stream)
(file-stream stream)
(string-stream stream)
(synonym-stream stream)
(two-way-stream stream)
(stream-error error)
(end-of-file stream-error)
(print-not-readable error)
(readtable t)
(reader-error parse-error)
(reader-error stream-error)
)))
(when (subtypep* 'character 'base-char)
(setq table
(append
'((character base-char)
(string base-string)
(simple-string simple-base-string))
table)))
table))
(defvar *disjoint-types-list*
'(cons symbol array
number character hash-table function readtable package
......
......@@ -28,124 +28,7 @@
;; These should get removed when I get a more up to date
;; image for that platform -- pfd
(defparameter *subtype-table*
(let ((table
'(
(null symbol)
(symbol t)
#-(and cmu (not sparc)) (boolean symbol)
(standard-object t)
(function t)
(compiled-function function)
(generic-function function)
(standard-generic-function generic-function)
(class standard-object)
(built-in-class class)
(structure-class class)
(standard-class class)
(method standard-object)
(standard-method method)
(structure-object t)
(method-combination t)
(condition t)
(serious-condition condition)
(error serious-condition)
(type-error error)
(simple-type-error type-error)
(simple-condition condition)
(simple-type-error simple-condition)
(parse-error error)
(hash-table t)
(cell-error error)
(unbound-slot cell-error)
(warning condition)
(style-warning warning)
(storage-condition serious-condition)
(simple-warning warning)
(simple-warning simple-condition)
(keyword symbol)
(unbound-variable cell-error)
(control-error error)
(program-error error)
(undefined-function cell-error)
(package t)
(package-error error)
(random-state t)
(number t)
(real number)
(complex number)
(float real)
(short-float float)
(single-float float)
(double-float float)
(long-float float)
(rational real)
(integer rational)
(ratio rational)
(signed-byte integer)
(integer signed-byte)
(unsigned-byte signed-byte)
(bit unsigned-byte)
(fixnum integer)
(bignum integer)
(bit fixnum)
(arithmetic-error error)
(division-by-zero arithmetic-error)
(floating-point-invalid-operation arithmetic-error)
(floating-point-inexact arithmetic-error)
(floating-point-overflow arithmetic-error)
(floating-point-underflow arithmetic-error)
(character t)
(base-char character)
(standard-char base-char)
(extended-char character)
(sequence t)
(list sequence)
(null list)
#-(and cmu (not sparc)) (null boolean)
(cons list)
(array t)
(simple-array array)
(vector sequence)
(vector array)
(string vector)
(bit-vector vector)
(simple-vector vector)
(simple-vector simple-array)
(simple-bit-vector bit-vector)
(simple-bit-vector simple-array)
(base-string string)
(simple-string string)
(simple-string simple-array)
(simple-base-string base-string)
(simple-base-string simple-string)
(pathname t)
(logical-pathname pathname)
(file-error error)
(stream t)
(broadcast-stream stream)
(concatenated-stream stream)
(echo-stream stream)
(file-stream stream)
(string-stream stream)
(synonym-stream stream)
(two-way-stream stream)
(stream-error error)
(end-of-file stream-error)
(print-not-readable error)
(readtable t)
(reader-error parse-error)
(reader-error stream-error)
)))
(when (subtypep* 'character 'base-char)
(setq table
(append
'((character base-char)
(string base-string)
(simple-string simple-base-string))
table)))
table))
(deftest types-3
(count-if
......@@ -160,9 +43,7 @@
*subtype-table*)
0)
(defparameter +float-types+
'(long-float double-float short-float single-float))
(declaim (special +float-types+ *subtype-table*))
;;; This next test is all screwed up. Basically, it assumes
;;; incorrectly that certain subtype relationships that are
......@@ -218,22 +99,44 @@
(declaim (special *disjoint-types-list*))
;;; Check that the disjoint types really are disjoint
(deftest types-7
(loop
for tp in *disjoint-types-list* sum
(loop for tp2 in *disjoint-types-list* count
(and (not (eqt tp tp2))
(subtypep* tp tp2))))
(loop
for tp in *disjoint-types-list* sum
(loop for tp2 in *disjoint-types-list* count
(and (not (eqt tp tp2))
(subtypep* tp tp2))))
0)
(deftest types-7a
(loop
for tp in *disjoint-types-list* sum
(loop for tp2 in *disjoint-types-list* count
(and (not (eqt tp tp2))
(multiple-value-bind (sub valid)
(subtypep `(not ,tp) `(not ,tp2))
(and sub valid)))))
0)
(deftest types-7b
(loop for e on *disjoint-types-list*
for tp1 = (first e)
append
(loop for tp2 in (rest e)
for result = (check-disjointness tp1 tp2)
append result))
nil)
(deftest types-8
(loop
for tp in *disjoint-types-list* count
(cond
((and (not (eqt tp 'cons))
(not (subtypep* tp 'atom)))
(format t "~%Should be atomic, but isn't: ~S" tp)
t)))
(loop
for tp in *disjoint-types-list* count
(cond
((and (not (eqt tp 'cons))
(not (subtypep* tp 'atom)))
(format t "~%Should be atomic, but isn't: ~S" tp)
t)))
0)
(declaim (special *type-list*
......@@ -247,7 +150,7 @@
;;;
(deftest types-9
(types-9-body)
(types-9-body)
nil)
;;;
......@@ -263,7 +166,7 @@
;;;
(deftest types-9a
(types-9a-body)
(types-9a-body)
0)
;;;
......@@ -278,6 +181,22 @@
collect (list e types))
nil)
(deftest integer-and-ratio-are-disjoint
(check-disjointness 'integer 'ratio)
nil)
(deftest integer-and-float-are-disjoint
(check-disjointness 'integer 'float)
nil)
(deftest ratio-and-float-are-disjoint
(check-disjointness 'ratio 'float)
nil)
(deftest complex-and-float-are-disjoint
(check-disjointness 'complex 'float)
nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; deftype
......
......@@ -36,6 +36,7 @@
(integer -10000000000000000000000000000000000
10000000000000000000000000000000000)
float
short-float
single-float
double-float
complex
......@@ -72,6 +73,20 @@
(%foo))
t)
(deftest upgraded-array-element-type.7
(let ((upgraded-types (mapcar #'upgraded-array-element-type
*upgraded-array-types-to-check*)))
(loop for type in *upgraded-array-types-to-check*
for upgraded-type in upgraded-types
append
(loop for type2 in *upgraded-array-types-to-check*
for upgraded-type2 in upgraded-types
when (and (subtypep type type2)
(equal (subtypep* upgraded-type upgraded-type)
'(nil t)))
collect (list type type2))))
nil)
;;; Tests of upgrading NIL (it should be type equivalent to NIL)
(deftest upgraded-array-element-type.nil.1
......
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