source: trunk/source/tests/ansi-tests/random-types.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 10.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Oct  6 05:04:45 2003
4;;;; Contains: Generating random types and testing relationships on them
5
6(in-package :cl-test)
7
8(compile-and-load "types-aux.lsp")
9(compile-and-load "random-aux.lsp")
10(compile-and-load "random-int-form.lsp")
11
12(defparameter *random-types* nil)
13
14(defun make-random-type (size)
15  (if (<= size 1)
16      (rcase
17       (1 nil)
18       (1 t)
19       (1 `(eql ,(let ((r (ash 1 (random 45))))
20                   (random-from-interval r (- r)))))
21       (1 (random-from-seq #(integer unsigned-byte ratio rational real float
22                             short-float single-float double-float
23                             long-float complex symbol cons function)))
24       (1
25        (let* ((len (random *maximum-random-int-bits*))
26               (r1 (ash 1 len))
27               (r2 (+ r1 r1))
28               (x (- (random r2) r1))
29               (y (- (random r2) r1))
30               (lo (min x y))
31               (hi (max x y)))
32          `(integer ,lo ,hi)))
33       (1 (make-random-real-type))
34       ;; (1 (make-random-complex-type))
35       )
36    (rcase
37     (2 (let* ((op (random-from-seq #(cons cons and or)))
38               (nargs (if (eq op 'cons) 2
39                        (1+ (random (min size 4)))))
40               (sizes (random-partition (1- size) nargs)))
41          `(,op ,@(mapcar #'make-random-type sizes))))
42     (1 `(not ,(make-random-type (1- size))))
43     ; (1 (make-random-function-type size))
44     )))
45
46(defun make-random-real-type ()
47  (rcase
48   (1 (random-from-seq '(integer unsigned-byte short-float single-float
49                                 double-float long-float rational real)))
50   (1 (destructuring-bind (lo hi)
51          (make-random-integer-range)
52        (rcase
53         (4 `(integer ,lo ,hi))
54         (1 `(integer ,lo))
55         (1 `(integer ,lo *))
56         (2 `(integer * ,hi)))))
57   (1 (let ((r1 (random-real))
58            (r2 (random-real)))
59        `(real ,(min r1 r2) ,(max r2 r2))))
60   ;;; Add more cases here
61   ))
62
63(defun make-random-complex-type ()
64  `(complex ,(make-random-real-type)))
65
66(defun make-random-function-type (size)
67  (let* ((sizes (random-partition (1- size) 2))
68         (types (mapcar #'make-random-type sizes)))
69    `(function (,(car types)) ,(cadr types))))
70
71(defun size-of-type (type)
72  (if (consp type)
73      (case (car type)
74        (complex (1+ (size-of-type (cadr type))))
75        ((array simple-array) (1+ (size-of-type (cadr type))))
76        (vector (1+ (size-of-type (cadr type))))
77        (complex (1+ (size-of-type (cadr type))))
78        ((cons or and not) (reduce #'+ (cdr type) :initial-value 1
79                                   :key #'size-of-type))
80        (t 1))
81      1))
82
83(defun mutate-type (type)
84  (let* ((size (size-of-type type))
85         (r (random size)))
86    (flet ((%f ()
87             (rcase
88              (6 (make-random-type (random (1+ size))))
89              (2 `(not ,type))
90              (1 `(and ,(make-random-type 1) ,type))
91              (1 `(and ,type ,(make-random-type 1)))
92              (1 `(or ,(make-random-type 1) ,type))
93              (1 `(or ,type ,(make-random-type 1)))))
94           (%random-int ()
95             (let ((bits (1+ (min (random 20) (random 20)))))
96               (- (ash 1 bits) (random (ash 1 (1+ bits)))))))
97      (if (or (and (= r 0) (coin)) (not (consp type)))
98          (%f)
99          (case (car type)
100            ((and or not cons complex)
101             (let ((sizes (mapcar #'size-of-type (cdr type))))
102               (loop with sum = 0
103                  for e on sizes
104                  for ctype in (cdr type)
105                  for i from 0
106                  do (setf sum (incf (car e) sum))
107                  when (>= sum r)
108                  return (rcase
109                          (1 ctype) ;; replace with component type
110                          (1 (cons (car type)
111                                   (append (subseq (cdr type) 0 i)
112                                           (list (mutate-type ctype))
113                                           (subseq (cdr type) (1+ i)))))))))
114            ((array simple-array vector)
115             (let ((ctype (if (cdr type) (cadr type) t)))
116               (rcase
117                (1 (if (eql ctype *) t ctype))
118                (1 (cons (car type)
119                         (cons (mutate-type ctype)
120                               (cddr type)))))))
121            ((unsigned-byte)
122             (if (integerp (cadr type))
123                 (rcase
124                  (1 'unsigned-byte)
125                  (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20))))))
126                 (%f)))
127
128            ((integer)
129             (let ((lo-delta (%random-int))
130                   (hi-delta (%random-int))
131                   (old-lo (or (cadr type) '*))
132                   (old-hi (or (caddr type) '*)))
133               (flet ((%inc (old delta)
134                        (if (or (coin) (not (integerp old)))
135                            delta
136                            (+ old delta))))
137                 (rcase
138                  (1 `(integer ,old-lo *))
139                  (1 `(integer * ,old-hi))
140                  (1 (let ((new-lo (%inc old-lo lo-delta)))
141                       (if (or (null (cdr type))
142                               (null (cddr type))
143                               (not (integerp old-hi)))
144                           `(integer ,new-lo ,@(cddr type))
145                           ;; caddr is integer
146                           (if (<= new-lo old-hi)
147                               `(integer ,new-lo ,old-hi)
148                               `(integer ,old-hi ,new-lo)))))
149                  (1 (let ((new-hi (%inc old-hi hi-delta)))
150                       (if (or (null (cdr type))
151                               (null (cddr type))
152                               (not (integerp old-lo)))
153                           `(integer ,old-lo ,new-hi)
154                           (if (<= old-lo new-hi)
155                               `(integer ,old-lo ,new-hi)
156                               `(integer ,new-hi ,old-lo)))))
157                  (1 (let ((new-lo (%inc old-lo lo-delta))
158                           (new-hi (%inc old-hi hi-delta)))
159                       (if (<= new-lo new-hi)
160                           `(integer ,new-lo ,new-hi)
161                           `(integer ,new-hi ,new-lo))))))))
162                       
163            (t (%f)))))))
164
165(defun test-random-types (n size)
166  (loop for t1 = (make-random-type size)
167        for t2 = (make-random-type size)
168        for i from 0 below n
169        ;; do (print (list t1 t2))
170        do (setf *random-types* (list t1 t2))
171        do (when (and (= (mod i 100) 0) (> i 0))
172             (format t "~A " i) (finish-output *standard-output*))
173        when (test-types t1 t2)
174        collect (list t1 t2)
175        finally (terpri)))
176
177(defun test-random-mutated-types (n size &key (reps 1))
178  (loop for t1 = (make-random-type size)
179        for t2 = (let ((x t1)) (loop repeat reps
180                                     do (setq x (mutate-type x))) x)
181        for i from 0 below n
182        ;; do (print (list t1 t2))
183        do (setf *random-types* (list t1 t2))
184        do (when (and (= (mod i 100) 0) (> i 0))
185             (format t "~A " i) (finish-output *standard-output*))
186        when (test-types t1 t2)
187        collect (list t1 t2)
188        finally (terpri)))
189
190(defun test-types (t1 t2)
191  (multiple-value-bind (sub success)
192      (subtypep t1 t2)
193    (when success
194      (if sub
195          (check-all-subtypep t1 t2)
196        (let ((nt1 `(not ,t1))
197              (nt2 `(not ,t2)))
198          (subtypep nt2 nt1))))))
199
200(defun prune-type (tp try-fn)
201  (declare (type function try-fn))
202  (flet ((try (x) (funcall try-fn x)))
203    (cond
204     ((member tp '(nil t)))
205     ((symbolp tp)
206      (try nil)
207      (try t))
208     ((consp tp)
209      (try nil)
210      (try t)
211      (let ((op (first tp))
212            (args (rest tp)))
213        (case op
214          ((cons)
215           (try 'cons)
216           (prune-list args
217                       #'prune-type
218                       #'(lambda (args) (try `(cons ,@args)))))
219          ((integer)
220           (try op)
221           (try '(eql 0))
222           (when (= (length args) 2)
223             (let ((arg1 (first args))
224                   (arg2 (second args)))
225               (when (and (integerp arg1) (integerp arg2))
226                 (try `(eql ,arg1))
227                 (try `(eql ,arg2))
228                 (when (and (< arg1 0) (<= 0 arg2))
229                   (try `(integer 0 ,arg2)))
230                 (when (and (<= arg1 0) (< 0 arg2))
231                   (try `(integer ,arg1 0)))
232                 (when (> (- arg2 arg1) 1)
233                   (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2))
234                   (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2)))))))))
235           
236          ((real float ratio single-float double-float short-float long-float)
237           (try op))
238           
239          ((or and)
240           (mapc try-fn args)
241           (loop for i from 0 below (length args)
242                 do (try `(,op ,@(subseq args 0 i)
243                               ,@(subseq args (1+ i)))))
244           (prune-list args
245                       #'prune-type
246                       #'(lambda (args) (try (cons op args)))))
247          ((not)
248           (let ((arg (first args)))
249             (try arg)
250             (when (and (consp arg)
251                        (eq (car arg) 'not))
252               (try (second arg)))
253             (prune-type arg #'(lambda (arg) (try `(not ,arg))))))
254         
255          ((member)
256           (dolist (arg (cdr tp))
257             (try `(eql ,arg)))
258           (when (cddr tp)
259           (try `(member ,@(cddr tp)))))
260
261          ((eql)
262           (assert (= (length args) 1))
263           (let ((arg (first args)))
264             (unless (= arg 0)
265               (try `(eql 0))
266               (cond
267                ((< arg -1)
268                 (try `(eql ,(ceiling arg 2))))
269                ((> arg 1)
270                 (try `(eql ,(floor arg 2))))))))               
271         
272          )))))
273  (values))
274
275(defun prune-type-pair (pair &optional (fn #'test-types))
276  (declare (type function fn))
277  (let ((t1 (first pair))
278        (t2 (second pair))
279        changed)
280    (loop
281     do (flet ((%try2 (new-tp)
282                      (when (funcall fn t1 new-tp)
283                        (print "Success in first loop")
284                        (print new-tp)
285                        (setq t2 new-tp
286                              changed t)
287                        (throw 'success nil))))
288          (catch 'success
289            (prune-type t2 #'%try2)))
290     do (flet ((%try1 (new-tp)
291                      (when (funcall fn new-tp t2)
292                        (print "Success in second loop")
293                        (print new-tp)
294                        (setq t1 new-tp
295                              changed t)
296                        (throw 'success nil))))
297          (catch 'success
298            (prune-type t1 #'%try1)))
299     while changed
300     do (setq changed nil))
301    (list t1 t2)))
302
303(defun test-type-triple (t1 t2 t3)
304  ;; Returns non-nil if a problem is found
305  (catch 'problem
306    (multiple-value-bind (sub1 success1)
307        (subtypep t1 t2)
308      (when success1
309        (if sub1
310            (append
311             (check-all-subtypep t1 `(or ,t2 ,t3))
312             (check-all-subtypep `(and ,t1 ,t3) t2))
313            (or (subtypep `(or ,t1 ,t3) t2)
314                (subtypep t1 `(and ,t2 ,t3))))))))
315
316(defun test-random-types3 (n size)
317  (loop for t1 = (make-random-type (1+ (random size)))
318        for t2 = (make-random-type (1+ (random size)))
319        for t3 = (make-random-type (1+ (random size)))
320        for i from 1 to n
321        ;; do (print (list t1 t2))
322        do (setf *random-types* (list t1 t2 t3))
323        do (when (and (= (mod i 100) 0) (> i 0))
324             (format t "~A " i) (finish-output *standard-output*))
325        when (test-type-triple t1 t2 t3)
326        collect (list t1 t2 t3)
327        finally (terpri)))
328
329(defun prune-type-triple (pair &optional (fn #'test-type-triple))
330  (declare (type function fn))
331  (let ((t1 (first pair))
332        (t2 (second pair))
333        (t3 (third pair))
334        changed)
335    (loop
336     do (flet ((%try2 (new-tp)
337                      (when (funcall fn t1 new-tp t3)
338                        (print "Success in first loop")
339                        (print new-tp)
340                        (setq t2 new-tp
341                              changed t)
342                        (throw 'success nil))))
343          (catch 'success
344            (prune-type t2 #'%try2)))
345     do (flet ((%try1 (new-tp)
346                      (when (funcall fn new-tp t2 t3)
347                        (print "Success in second loop")
348                        (print new-tp)
349                        (setq t1 new-tp
350                              changed t)
351                        (throw 'success nil))))
352          (catch 'success
353            (prune-type t1 #'%try1)))
354     do (flet ((%try3 (new-tp)
355                      (when (funcall fn t1 t2 new-tp)
356                        (print "Success in second loop")
357                        (print new-tp)
358                        (setq t3 new-tp
359                              changed t)
360                        (throw 'success nil))))
361          (catch 'success
362            (prune-type t3 #'%try3)))
363     while changed
364     do (setq changed nil))
365    (list t1 t2 t3)))
366
367
368
369 
Note: See TracBrowser for help on using the repository browser.