Skip to content
Snippets Groups Projects
Commit ef314586 authored by pfdietz's avatar pfdietz
Browse files

Enhance the random type generator, added a new random test involving three types. Added pruning.

parent 23f8b4d0
No related branches found
No related tags found
No related merge requests found
...@@ -29,11 +29,11 @@ ...@@ -29,11 +29,11 @@
`(integer ,lo ,hi))) `(integer ,lo ,hi)))
) )
(rcase (rcase
(2 (destructuring-bind (s1 s2) (2 (let* ((op (random-from-seq #(cons cons and or)))
(random-partition (1- size) 2) (nargs (if (eq op 'cons) 2
(let ((op (random-from-seq #(cons cons and or)))) (1+ (random (min size 4)))))
`(,op ,(make-random-type s1) (sizes (random-partition (1- size) nargs)))
,(make-random-type s2))))) `(,op ,@(mapcar #'make-random-type sizes))))
(1 `(not ,(make-random-type (1- size)))) (1 `(not ,(make-random-type (1- size))))
))) )))
...@@ -78,10 +78,31 @@ ...@@ -78,10 +78,31 @@
(prune-list args (prune-list args
#'prune-type #'prune-type
#'(lambda (args) (try `(cons ,@args))))) #'(lambda (args) (try `(cons ,@args)))))
((integer real float ratio single-float double-float short-float long-float) ((integer)
(try op)
(try '(eql 0))
(when (= (length args) 2)
(let ((arg1 (first args))
(arg2 (second args)))
(when (and (integerp arg1) (integerp arg2))
(try `(eql ,arg1))
(try `(eql ,arg2))
(when (and (< arg1 0) (<= 0 arg2))
(try `(integer 0 ,arg2)))
(when (and (<= arg1 0) (< 0 arg2))
(try `(integer ,arg1 0)))
(when (> (- arg2 arg1) 1)
(try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2))
(try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2)))))))))
((real float ratio single-float double-float short-float long-float)
(try op)) (try op))
((or and) ((or and)
(mapc try-fn args) (mapc try-fn args)
(loop for i from 0 below (length args)
do (try `(,op ,@(subseq args 0 i)
,@(subseq args (1+ i)))))
(prune-list args (prune-list args
#'prune-type #'prune-type
#'(lambda (args) (try (cons op args))))) #'(lambda (args) (try (cons op args)))))
...@@ -92,19 +113,35 @@ ...@@ -92,19 +113,35 @@
(eq (car arg) 'not)) (eq (car arg) 'not))
(try (second arg))) (try (second arg)))
(prune-type arg #'(lambda (arg) (try `(not ,arg)))))) (prune-type arg #'(lambda (arg) (try `(not ,arg))))))
((member) ((member)
(dolist (arg (cdr tp)) (dolist (arg (cdr tp))
(try `(eql ,arg))) (try `(eql ,arg)))
(when (cddr tp) (when (cddr tp)
(try `(member ,@(cddr tp))))) (try `(member ,@(cddr tp)))))
((eql)
(assert (= (length args) 1))
(let ((arg (first args)))
(unless (= arg 0)
(try `(eql 0))
(cond
((< arg -1)
(try `(eql ,(ceiling arg 2))))
((> arg 1)
(try `(eql ,(floor arg 2))))))))
))))) )))))
(values)) (values))
(defun prune-type-pair (t1 t2) (defun prune-type-pair (pair &optional (fn #'test-types))
(let (changed) (declare (type function fn))
(let ((t1 (first pair))
(t2 (second pair))
changed)
(loop (loop
do (flet ((%try2 (new-tp) do (flet ((%try2 (new-tp)
(when (test-types t1 new-tp) (when (funcall fn t1 new-tp)
(print "Success in first loop") (print "Success in first loop")
(print new-tp) (print new-tp)
(setq t2 new-tp (setq t2 new-tp
...@@ -113,7 +150,7 @@ ...@@ -113,7 +150,7 @@
(catch 'success (catch 'success
(prune-type t2 #'%try2))) (prune-type t2 #'%try2)))
do (flet ((%try1 (new-tp) do (flet ((%try1 (new-tp)
(when (test-types new-tp t2) (when (funcall fn new-tp t2)
(print "Success in second loop") (print "Success in second loop")
(print new-tp) (print new-tp)
(setq t1 new-tp (setq t1 new-tp
...@@ -122,14 +159,71 @@ ...@@ -122,14 +159,71 @@
(catch 'success (catch 'success
(prune-type t1 #'%try1))) (prune-type t1 #'%try1)))
while changed while changed
do (setq changed nil))) do (setq changed nil))
(values t1 t2)) (list t1 t2)))
(defun test-type-triple (t1 t2 t3)
;; Returns non-nil if a problem is found
(multiple-value-bind (sub1 success1)
(subtypep t1 t2)
(when success1
(if sub1
(append
(check-all-subtypep t1 `(or ,t2 ,t3))
(check-all-subtypep `(and ,t1 ,t3) t2))
(or (subtypep `(or ,t1 ,t3) t2)
(subtypep t1 `(and ,t2 ,t3)))))))
(defun test-random-types3 (n size)
(loop for t1 = (make-random-type (1+ (random size)))
for t2 = (make-random-type (1+ (random size)))
for t3 = (make-random-type (1+ (random size)))
for i from 1 to 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-type-triple t1 t2 t3)
collect (list t1 t2)
finally (terpri)))
(defun prune-type-triple (pair &optional (fn #'test-type-triple))
(declare (type function fn))
(let ((t1 (first pair))
(t2 (second pair))
(t3 (third pair))
changed)
(loop
do (flet ((%try2 (new-tp)
(when (funcall fn t1 new-tp t3)
(print "Success in first loop")
(print new-tp)
(setq t2 new-tp
changed t)
(throw 'success nil))))
(catch 'success
(prune-type t2 #'%try2)))
do (flet ((%try1 (new-tp)
(when (funcall fn new-tp t2 t3)
(print "Success in second loop")
(print new-tp)
(setq t1 new-tp
changed t)
(throw 'success nil))))
(catch 'success
(prune-type t1 #'%try1)))
do (flet ((%try3 (new-tp)
(when (funcall fn t1 t2 new-tp)
(print "Success in second loop")
(print new-tp)
(setq t3 new-tp
changed t)
(throw 'success nil))))
(catch 'success
(prune-type t3 #'%try3)))
while changed
do (setq changed nil))
(list t1 t2 t3)))
\ No newline at end of file
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment