diff --git a/ansi-tests/random-types.lsp b/ansi-tests/random-types.lsp index a1223d009e91ca10fe38a9fe51b59e1f0c43475a..1da6899b595589888a7f746dfc320581b3f26711 100644 --- a/ansi-tests/random-types.lsp +++ b/ansi-tests/random-types.lsp @@ -29,11 +29,11 @@ `(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))))) + (2 (let* ((op (random-from-seq #(cons cons and or))) + (nargs (if (eq op 'cons) 2 + (1+ (random (min size 4))))) + (sizes (random-partition (1- size) nargs))) + `(,op ,@(mapcar #'make-random-type sizes)))) (1 `(not ,(make-random-type (1- size)))) ))) @@ -78,10 +78,31 @@ (prune-list args #'prune-type #'(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)) + ((or and) (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-type #'(lambda (args) (try (cons op args))))) @@ -92,19 +113,35 @@ (eq (car arg) 'not)) (try (second arg))) (prune-type arg #'(lambda (arg) (try `(not ,arg)))))) + ((member) (dolist (arg (cdr tp)) (try `(eql ,arg))) (when (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)) -(defun prune-type-pair (t1 t2) - (let (changed) +(defun prune-type-pair (pair &optional (fn #'test-types)) + (declare (type function fn)) + (let ((t1 (first pair)) + (t2 (second pair)) + changed) (loop do (flet ((%try2 (new-tp) - (when (test-types t1 new-tp) + (when (funcall fn t1 new-tp) (print "Success in first loop") (print new-tp) (setq t2 new-tp @@ -113,7 +150,7 @@ (catch 'success (prune-type t2 #'%try2))) do (flet ((%try1 (new-tp) - (when (test-types new-tp t2) + (when (funcall fn new-tp t2) (print "Success in second loop") (print new-tp) (setq t1 new-tp @@ -122,14 +159,71 @@ (catch 'success (prune-type t1 #'%try1))) while changed - do (setq changed nil))) - (values t1 t2)) + do (setq changed nil)) + (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