Commit 7150913a authored by pfdietz's avatar pfdietz

Simple test harness for subtypep on randomly generated types.

parent c90ca843
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon Oct 6 05:04:45 2003
;;;; Contains: Generating random types and testing relationships on them
(in-package :cl-test)
(compile-and-load "random-aux.lsp")
(compile-and-load "random-int-form.lsp")
(defun make-random-type (size)
(if (<= size 1)
(rcase
(1 nil)
(1 t)
(1 `(eql ,(let ((r (ash 1 (random 45))))
(random-from-interval r (- r)))))
(1 (random-from-seq #(integer unsigned-byte ratio rational real float
short-float single-float double-float
long-float complex symbol cons)))
(1
(let* ((len (random *maximum-random-int-bits*))
(r1 (ash 1 len))
(r2 (+ r1 r1))
(x (- (random r2) r1))
(y (- (random r2) r1))
(lo (min x y))
(hi (max x y)))
`(integer ,lo ,hi)))
)
(rcase
(2 (destructuring-bind (s1 s2)
(random-partition (1- size) 2)
(let ((op (random-from-seq #(cons cons and or))))
`(,op ,(make-random-type s1)
,(make-random-type s2)))))
(1 `(not ,(make-random-type (1- size))))
)))
(defun test-random-types (n size)
(loop for t1 = (make-random-type size)
for t2 = (make-random-type size)
for i from 0 below n
;; do (print (list t1 t2))
do (when (and (= (mod i 100) 0) (> i 0))
(format t "~A " i) (finish-output *standard-output*))
when (test-types t1 t2)
collect (list t1 t2)
finally (terpri)))
(defun test-types (t1 t2)
(multiple-value-bind (sub success)
(subtypep t1 t2)
(when success
(if sub
(check-all-subtypep t1 t2)
(let ((nt1 `(not ,t1))
(nt2 `(not ,t2)))
(subtypep nt2 nt1))))))
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