/[gcl]/gcl/ansi-tests/random-types.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-types.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by pfdietz, Fri Aug 12 03:45:02 2005 UTC revision 1.8 by pfdietz, Mon Oct 10 13:20:11 2005 UTC
# Line 21  Line 21 
21         (1 (random-from-seq #(integer unsigned-byte ratio rational real float         (1 (random-from-seq #(integer unsigned-byte ratio rational real float
22                               short-float single-float double-float                               short-float single-float double-float
23                               long-float complex symbol cons function)))                               long-float complex symbol cons function)))
        #|  
24         (1         (1
25          (let* ((len (random *maximum-random-int-bits*))          (let* ((len (random *maximum-random-int-bits*))
26                 (r1 (ash 1 len))                 (r1 (ash 1 len))
# Line 31  Line 30 
30                 (lo (min x y))                 (lo (min x y))
31                 (hi (max x y)))                 (hi (max x y)))
32            `(integer ,lo ,hi)))            `(integer ,lo ,hi)))
        |#  
33         (1 (make-random-real-type))         (1 (make-random-real-type))
34         (1 (make-random-complex-type))         ;; (1 (make-random-complex-type))
35         )         )
36      (rcase      (rcase
37       (2 (let* ((op (random-from-seq #(cons cons and or)))       (2 (let* ((op (random-from-seq #(cons cons and or)))
# Line 70  Line 68 
68           (types (mapcar #'make-random-type sizes)))           (types (mapcar #'make-random-type sizes)))
69      `(function (,(car types)) ,(cadr types))))      `(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)  (defun test-random-types (n size)
166    (loop for t1 = (make-random-type size)    (loop for t1 = (make-random-type size)
167          for t2 = (make-random-type size)          for t2 = (make-random-type size)
# Line 81  Line 173 
173          when (test-types t1 t2)          when (test-types t1 t2)
174          collect (list t1 t2)          collect (list t1 t2)
175          finally (terpri)))          finally (terpri)))
176      
177    (defun test-random-mutated-types (n size)
178      (loop for t1 = (make-random-type size)
179            for t2 = (mutate-type t1)
180            for i from 0 below n
181            ;; do (print (list t1 t2))
182            do (setf *random-types* (list t1 t2))
183            do (when (and (= (mod i 100) 0) (> i 0))
184                 (format t "~A " i) (finish-output *standard-output*))
185            when (test-types t1 t2)
186            collect (list t1 t2)
187            finally (terpri)))  
188    
189  (defun test-types (t1 t2)  (defun test-types (t1 t2)
190    (multiple-value-bind (sub success)    (multiple-value-bind (sub success)

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26