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

Diff of /gcl/ansi-tests/random-int-form.lsp

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

revision 1.10 by pfdietz, Tue Sep 23 01:00:15 2003 UTC revision 1.11 by pfdietz, Thu Sep 25 11:19:57 2003 UTC
# Line 37  Line 37 
37    
38  (defvar *random-int-form-blocks* nil)  (defvar *random-int-form-blocks* nil)
39    
40    (defvar *maximum-random-int-bits* 45)
41    
42    (declaim (special *vars*))
43    
44    (defstruct var-desc
45      (name nil :type symbol)
46      (type t))
47    
48  (defun test-random-integer-forms  (defun test-random-integer-forms
49    (size nvars n &optional (*random-state* (make-random-state t)))    (size nvars n &optional (*random-state* (make-random-state t)))
50    
# Line 63  Line 71 
71  (defun test-random-integer-form  (defun test-random-integer-form
72    (size nvars &aux (vars (subseq '(a b c d e f g h i j k l m    (size nvars &aux (vars (subseq '(a b c d e f g h i j k l m
73                                       n o p q r s t u v w x y z) 0 nvars)))                                       n o p q r s t u v w x y z) 0 nvars)))
74    (let* ((form (make-random-integer-form size vars))    (let* ((var-ranges (mapcar #'make-random-integer-range vars))
          (var-ranges (mapcar #'make-random-integer-range vars))  
75           (var-types (mapcar #'(lambda (range)           (var-types (mapcar #'(lambda (range)
76                                  (let ((lo (car range))                                  (let ((lo (car range))
77                                        (hi (cadr range)))                                        (hi (cadr range)))
78                                    (assert (>= hi lo))                                    (assert (>= hi lo))
79                                    `(integer ,lo ,hi)))                                    `(integer ,lo ,hi)))
80                              var-ranges))                              var-ranges))
81             (form (let ((*vars* (loop for v in vars
82                                       for tp in var-types
83                                       collect (make-var-desc :name v
84                                                              :type tp))))
85                     (make-random-integer-form size)))
86           (vals-list           (vals-list
87            (loop repeat 20            (loop repeat 20
88                  collect                  collect
# Line 99  Line 111 
111    "Generate a list (LO HI) of integers, LO <= HI.  This is used    "Generate a list (LO HI) of integers, LO <= HI.  This is used
112     for generating integer types."     for generating integer types."
113    (declare (ignore var))    (declare (ignore var))
114    (flet ((%r () (let ((r (ash 1 (1+ (random 35)))))    (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
115                    (- (random r) (floor (/ r 2))))))                    (- (random r) (floor (/ r 2))))))
116      (let ((x (%r))      (let ((x (%r))
117            (y (%r)))            (y (%r)))
# Line 107  Line 119 
119    
120  (defparameter *flet-names* nil)  (defparameter *flet-names* nil)
121    
122  (defun make-random-integer-form (size vars)  (defun make-random-integer-form (size)
123    "Generate a random legal lisp form of size SIZE (roughly).  VARS    "Generate a random legal lisp form of size SIZE (roughly)."
124     is a list of variable symbols that contain integers."    
125    (if (<= size 1)    (if (<= size 1)
126        ;; Leaf node -- generate a variable, constant, or flet function call        ;; Leaf node -- generate a variable, constant, or flet function call
127        (rcase        (rcase
128         (10 (let ((r (ash 1 (1+ (random 32)))))         (10 (let ((r (ash 1 (1+ (random 32)))))
129               (- (random r) (floor (/ r 2)))))               (- (random r) (floor (/ r 2)))))
130         (9 (random-from-seq vars))         (9 (var-desc-name (random-from-seq  *vars*)))
131         (1 (if *flet-names* (list (random-from-seq *flet-names*))         (1 (if *flet-names* (list (random-from-seq *flet-names*))
132              (random-from-seq vars))))              (var-desc-name (random-from-seq *vars*)))))
133      ;; (> size 1)      ;; (> size 1)
134      (rcase      (rcase
135       ;; Unary ops       ;; Unary ops
# Line 125  Line 137 
137        (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor        (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor
138                                       ceiling truncate round realpart imagpart                                       ceiling truncate round realpart imagpart
139                                       integer-length logcount values))))                                       integer-length logcount values))))
140          `(,op ,(make-random-integer-form (1- size) vars))))          `(,op ,(make-random-integer-form (1- size)))))
141       (2 `(isqrt (abs ,(make-random-integer-form (- size 2) vars))))       (2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))
142       (3  #|     (3
143        (destructuring-bind (s1 s2)        (destructuring-bind (s1 s2)
144            (random-partition (- size 2) 2)            (random-partition (- size 2) 2)
145          `(ash ,(make-random-integer-form s1 vars)          `(ash ,(make-random-integer-form s1)
146                (min ,(random 100)                (min ,(random 100)
147                     ,(make-random-integer-form s2 vars)))))                     ,(make-random-integer-form s2))))) |#
148            
149       ;; binary floor, ceiling, truncate, round       ;; binary floor, ceiling, truncate, round
150       (4       (4
# Line 140  Line 152 
152              (op2 (random-from-seq #(max min))))              (op2 (random-from-seq #(max min))))
153          (destructuring-bind (s1 s2)          (destructuring-bind (s1 s2)
154            (random-partition (- size 2) 2)            (random-partition (- size 2) 2)
155            `(,op  ,(make-random-integer-form s1 vars)            `(,op  ,(make-random-integer-form s1)
156                   (,op2  ,(if (eq op2 'max)                   (,op2  ,(if (eq op2 'max)
157                               (1+ (random 100))                               (1+ (random 100))
158                             (- (1+ (random 100))))                             (- (1+ (random 100))))
159                          ,(make-random-integer-form s2 vars))))))                          ,(make-random-integer-form s2))))))
160                            
161       ;; Binary op       ;; Binary op
162       (80       (80
# Line 158  Line 170 
170                        logorc2 logxor))))                        logorc2 logxor))))
171          (destructuring-bind (leftsize rightsize)          (destructuring-bind (leftsize rightsize)
172              (random-partition (1- size) 2)              (random-partition (1- size) 2)
173            (let ((e1 (make-random-integer-form leftsize vars))            (let ((e1 (make-random-integer-form leftsize))
174                  (e2 (make-random-integer-form rightsize vars)))                  (e2 (make-random-integer-form rightsize)))
175              `(,op ,e1 ,e2)))))              `(,op ,e1 ,e2)))))
176       ;; conditionals       ;; conditionals
177       (20       (20
178        (let* ((cond-size (random (max 1 (floor size 2))))        (let* ((cond-size (random (max 1 (floor size 2))))
179               (then-size (random (- size cond-size)))               (then-size (random (- size cond-size)))
180               (else-size (- size 1 cond-size then-size))               (else-size (- size 1 cond-size then-size))
181               (pred (make-random-pred-form cond-size vars))               (pred (make-random-pred-form cond-size))
182               (then-part (make-random-integer-form then-size vars))               (then-part (make-random-integer-form then-size))
183               (else-part (make-random-integer-form else-size vars)))               (else-part (make-random-integer-form else-size)))
184          `(if ,pred ,then-part ,else-part)))          `(if ,pred ,then-part ,else-part)))
185       (10       (10
186        (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)        (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
187          `(,(random-from-seq '(deposit-field dpb))          `(,(random-from-seq '(deposit-field dpb))
188            ,(make-random-integer-form s1 vars)            ,(make-random-integer-form s1)
189            ,(make-random-byte-spec-form s2 vars)            ,(make-random-byte-spec-form s2)
190            ,(make-random-integer-form s3 vars))))            ,(make-random-integer-form s3))))
191       ;; #-:allegro       ;; #-:allegro
192       (10       (10
193        (destructuring-bind (s1 s2) (random-partition (1- size) 2)        (destructuring-bind (s1 s2) (random-partition (1- size) 2)
194            `(,(random-from-seq '(ldb mask-field))            `(,(random-from-seq '(ldb mask-field))
195              ,(make-random-byte-spec-form s1 vars)              ,(make-random-byte-spec-form s1)
196              ,(make-random-integer-form s2 vars))))              ,(make-random-integer-form s2))))
197       (20       (20
198        (destructuring-bind (s1 s2) (random-partition (1- size) 2)        (destructuring-bind (s1 s2) (random-partition (1- size) 2)
199          (let* ((var (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))          (let* ((var (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
200                 (e1 (make-random-integer-form s1 vars))                 (e1 (make-random-integer-form s1))
201                 (e2 (make-random-integer-form s2 (cons var vars))))                 (e2 (let ((*vars* (cons (make-var-desc :name var
202                                                          :type '(integer * *))
203                                           *vars*)))
204                         (make-random-integer-form s2))))
205            ;; for now, avoid shadowing            ;; for now, avoid shadowing
206            (if (member var vars)            (if (member var *vars* :key #'var-desc-name)
207                (make-random-integer-form size vars)                (make-random-integer-form size)
208              `(let ((,var ,e1)) ,e2)))))              `(let ((,var ,e1)) ,e2)))))
209       (4 `(let () ,(make-random-integer-form (1- size) vars)))       (4 `(let () ,(make-random-integer-form (1- size))))
210       (10       (10
211        (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8)))        (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8)))
212               (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))               (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
213          `(block ,name ,(make-random-integer-form (1- size) vars))))          `(block ,name ,(make-random-integer-form (1- size)))))
214       (3 (make-random-integer-case-form size vars))       (4 ;; setq
215          (let* ((vdesc (random-from-seq *vars*))
216                 (var (var-desc-name vdesc))
217                 (type (var-desc-type vdesc)))
218            (cond
219             ((equal type '(integer * *))
220              `(setq ,var ,(make-random-integer-form (1- size))))
221             ((and (consp type)
222                   (eq (car type) 'integer)
223                   (integerp (second type))
224                   (integerp (third type)))
225              `(setq ,var ,(random-from-interval (1+ (third type)) (second type))))
226             (t (make-random-integer-form size)))))
227    
228         (3 (make-random-integer-case-form size))
229       (3       (3
230        (if *random-int-form-blocks*        (if *random-int-form-blocks*
231            (let ((name (random-from-seq *random-int-form-blocks*))            (let ((name (random-from-seq *random-int-form-blocks*))
232                  (form (make-random-integer-form (1- size) vars)))                  (form (make-random-integer-form (1- size))))
233              `(return-from ,name ,form))              `(return-from ,name ,form))
234          ;; No blocks -- try again          ;; No blocks -- try again
235          (make-random-integer-form size vars)))          (make-random-integer-form size)))
236    
237       (5       (5
238        (if *random-int-form-blocks*        (if *random-int-form-blocks*
239            (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)            (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
240              (let ((name (random-from-seq *random-int-form-blocks*))              (let ((name (random-from-seq *random-int-form-blocks*))
241                    (pred (make-random-pred-form s1 vars))                    (pred (make-random-pred-form s1))
242                    (then (make-random-integer-form s2 vars))                    (then (make-random-integer-form s2))
243                    (else (make-random-integer-form s3 vars)))                    (else (make-random-integer-form s3)))
244                `(if ,pred (return-from ,name ,then) ,else)))                `(if ,pred (return-from ,name ,then) ,else)))
245          ;; No blocks -- try again          ;; No blocks -- try again
246          (make-random-integer-form size vars)))          (make-random-integer-form size)))
247    
248       (5 (make-random-flet-form size vars))       (5 (make-random-flet-form size))
249                                    
250       )))       )))
251    
252  (defun make-random-integer-case-form (size vars)  (defun make-random-integer-case-form (size)
253    (let ((ncases (1+ (random 10))))    (let ((ncases (1+ (random 10))))
254      (if (< (+ size size) (+ ncases 2))      (if (< (+ size size) (+ ncases 2))
255          ;; Too small, give up          ;; Too small, give up
256          (make-random-integer-form size vars)          (make-random-integer-form size)
257        (let* ((sizes (random-partition (1- size) (+ ncases 2)))        (let* ((sizes (random-partition (1- size) (+ ncases 2)))
258               (bound (ash 1 (+ 2 (random 16))))               (bound (ash 1 (+ 2 (random 16))))
259               (lower-bound (if (coin 3) 0 (- bound)))               (lower-bound (if (coin 3) 0 (- bound)))
# Line 237  Line 266 
266                 for vals = (loop repeat (1+ (min (random 10) (random 10)))                 for vals = (loop repeat (1+ (min (random 10) (random 10)))
267                                  collect (random-from-interval                                  collect (random-from-interval
268                                           upper-bound lower-bound))                                           upper-bound lower-bound))
269                 for result = (make-random-integer-form case-size vars)                 for result = (make-random-integer-form case-size)
270                 repeat ncases                 repeat ncases
271                 collect `(,vals ,result)))                 collect `(,vals ,result)))
272               (expr (make-random-integer-form (first sizes) vars)))               (expr (make-random-integer-form (first sizes))))
273          `(case ,expr          `(case ,expr
274             ,@cases             ,@cases
275             (t ,(make-random-integer-form (second sizes) vars)))))))             (t ,(make-random-integer-form (second sizes))))))))
276    
277  (defun make-random-flet-form (size vars)  (defun make-random-flet-form (size)
278    "Generate random flet, labels forms, for now with no arguments    "Generate random flet, labels forms, for now with no arguments
279     and a single binding per form."     and a single binding per form."
280    (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10    (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10
281                                    %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18))))                                    %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18))))
282      (if (member fname *flet-names* :test #'eq)      (if (member fname *flet-names* :test #'eq)
283          (make-random-integer-form size vars)          (make-random-integer-form size)
284        (destructuring-bind (s1 s2) (random-partition (max 2 (1- size)) 2)        (destructuring-bind (s1 s2) (random-partition (max 2 (1- size)) 2)
285          (let ((op (random-from-seq #(flet labels)))          (let ((op (random-from-seq #(flet labels)))
286                (form1                (form1
287                 ;; Allow return-from of the flet/labels function                 ;; Allow return-from of the flet/labels function
288                 (let ((*random-int-form-blocks*                 (let ((*random-int-form-blocks*
289                        (cons fname *random-int-form-blocks*)))                        (cons fname *random-int-form-blocks*)))
290                   (make-random-integer-form s1 vars)))                   (make-random-integer-form s1)))
291                (form2 (let ((*flet-names* (cons fname *flet-names*)))                (form2 (let ((*flet-names* (cons fname *flet-names*)))
292                         (make-random-integer-form s2 vars))))                         (make-random-integer-form s2))))
293            `(,op ((,fname () ,form1)) ,form2))))))            `(,op ((,fname () ,form1)) ,form2))))))
294    
295  (defun make-random-pred-form (size vars)  (defun make-random-pred-form (size)
296    "Make a random form whose value is to be used as a generalized boolean."    "Make a random form whose value is to be used as a generalized boolean."
297    (if (<= size 1)    (if (<= size 1)
298        (rcase        (rcase
299          (1 (if (coin) t nil))          (1 (if (coin) t nil))
300          (2          (2
301           `(,(random-from-seq '(< <= = > >= /= eql equal))           `(,(random-from-seq '(< <= = > >= /= eql equal))
302             ,(make-random-integer-form size vars)             ,(make-random-integer-form size)
303             ,(make-random-integer-form size vars))))             ,(make-random-integer-form size))))
304      (rcase      (rcase
305        (1 (if (coin) t nil))        (1 (if (coin) t nil))
306        (1 `(not ,(make-random-pred-form (1- size) vars)))        (1 `(not ,(make-random-pred-form (1- size))))
307        (2 (destructuring-bind (leftsize rightsize)        (2 (destructuring-bind (leftsize rightsize)
308               (random-partition (1- size) 2)               (random-partition (1- size) 2)
309             `(,(random-from-seq '(and or))             `(,(random-from-seq '(and or))
310               ,(make-random-pred-form leftsize vars)               ,(make-random-pred-form leftsize)
311               ,(make-random-pred-form rightsize vars))))               ,(make-random-pred-form rightsize))))
312        (1 (destructuring-bind (leftsize rightsize)        (1 (destructuring-bind (leftsize rightsize)
313               (random-partition (1- size) 2)               (random-partition (1- size) 2)
314             `(,(random-from-seq '(< <= > >= = /= eql equal))             `(,(random-from-seq '(< <= > >= = /= eql equal))
315               ,(make-random-integer-form leftsize vars)               ,(make-random-integer-form leftsize)
316               ,(make-random-integer-form rightsize vars))))               ,(make-random-integer-form rightsize))))
317        (1 (let* ((cond-size (random (max 1 (floor size 2))))        (1 (let* ((cond-size (random (max 1 (floor size 2))))
318                  (then-size (random (- size cond-size)))                  (then-size (random (- size cond-size)))
319                  (else-size (- size 1 cond-size then-size))                  (else-size (- size 1 cond-size then-size))
320                  (pred (make-random-pred-form cond-size vars))                  (pred (make-random-pred-form cond-size))
321                  (then-part (make-random-pred-form then-size vars))                  (then-part (make-random-pred-form then-size))
322                  (else-part (make-random-pred-form else-size vars)))                  (else-part (make-random-pred-form else-size)))
323             `(if ,pred ,then-part ,else-part)))             `(if ,pred ,then-part ,else-part)))
324        (1 (destructuring-bind (s1 s2)        (1 (destructuring-bind (s1 s2)
325               (random-partition (1- size) 2)               (random-partition (1- size) 2)
326             `(ldb-test ,(make-random-byte-spec-form s1 vars)             `(ldb-test ,(make-random-byte-spec-form s1)
327                        ,(make-random-integer-form s2 vars))))                        ,(make-random-integer-form s2))))
328        (1 (let ((index (random (1+ (random 35))))        (1 (let ((index (random (1+ (random *maximum-random-int-bits*))))
329                 (form (make-random-integer-form (1- size) vars)))                 (form (make-random-integer-form (1- size))))
330             `(logbitp ,index ,form)))             `(logbitp ,index ,form)))
331        )))        )))
332    
333  (defun make-random-byte-spec-form (size vars)  (defun make-random-byte-spec-form (size)
334    (declare (ignore size vars))    (declare (ignore size))
335    (let* ((pform (random 33))    (let* ((pform (random 33))
336           (sform (1+ (random 33))))           (sform (1+ (random 33))))
337      `(byte ,sform ,pform)))      `(byte ,sform ,pform)))
# Line 326  Line 355 
355                        (t hi)))))                        (t hi)))))
356           (if (eq lo '*)           (if (eq lo '*)
357               (if (eq hi '*)               (if (eq hi '*)
358                   (let ((x (ash 1 (random 35))))                   (let ((x (ash 1 (random *maximum-random-int-bits*))))
359                     (random-from-interval x (- x)))                     (random-from-interval x (- x)))
360                 (random-from-interval (1+ hi)                 (random-from-interval (1+ hi)
361                                       (- hi (random (ash 1 35)))))                                       (- hi (random (ash 1 *maximum-random-int-bits*)))))
362    
363             (if (eq hi '*)             (if (eq hi '*)
364                 (random-from-interval (+ lo (random (ash 1 35)) 1)                 (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
365                                       lo)                                       lo)
366               ;; May generalize the next case to increase odds               ;; May generalize the next case to increase odds
367               ;; of certain integers (near 0, near endpoints, near               ;; of certain integers (near 0, near endpoints, near
# Line 351  Line 380 
380                   (make-random-element-of-type '(integer 0 *))                   (make-random-element-of-type '(integer 0 *))
381                 (progn                 (progn
382                   (assert (and (integerp bits) (>= bits 1)))                   (assert (and (integerp bits) (>= bits 1)))
383                   (make-random-element-of-type `(integer 0 ,(1- (ash 1 bits)))))))))                   (make-random-element-of-type
384                      `(integer 0 ,(1- (ash 1 bits)))))))))
385          )))          )))
386     (t     (t
387      (ecase type      (ecase type
388        (bit (random 2))        (bit (random 2))
389        (boolean (random-from-seq #(nil t)))        (boolean (random-from-seq #(nil t)))
390        (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| cl:car)))        (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| cl:car)))
391        (unsigned-byte (random-from-interval (1+ (ash 1 (random 35))) 0))        (unsigned-byte (random-from-interval
392        (integer (let ((x (ash 1 (random 35))))                        (1+ (ash 1 (random *maximum-random-int-bits*))) 0))
393          (integer (let ((x (ash 1 (random *maximum-random-int-bits*))))
394                   (random-from-interval (1+ x) (- x))))                   (random-from-interval (1+ x) (- x))))
395        ))))        ))))
396                    
# Line 515  Line 546 
546                    realpart imagpart)                    realpart imagpart)
547            (mapc #'try args)            (mapc #'try args)
548            (try 0)            (try 0)
           (try 1)  
549            (try -1)            (try -1)
550            (prune-fn form try-fn))            (prune-fn form try-fn))
551                    
552           ((abs 1+ 1- identity values)           ((abs 1+ 1- identity values progn realpart imagpart)
553            (mapc #'try args)            (mapc #'try args)
554            (prune-fn form try-fn))            (prune-fn form try-fn))
555                    
# Line 536  Line 566 
566                  (else (third args)))                  (else (third args)))
567              (try then)              (try then)
568              (try else)              (try else)
569                (when (every #'constantp args)
570                  (try (eval form)))
571              (prune-fn form try-fn)))              (prune-fn form try-fn)))
572    
573             ((setq)
574              ;; Assumes only one assignment
575              (assert (= (length form) 3))
576              (try (second args))
577              (prune (second args)
578                     #'(lambda (form)
579                         (try `(,op ,(first args) ,form)))))
580    
581           ((byte)           ((byte)
582            (prune-fn form try-fn))            (prune-fn form try-fn))
583    
584           ((deposit-field dpb)           ((deposit-field dpb)
585            (try (first args))            (destructuring-bind (a1 a2 a3)
586            (try (third args))                args
587                (try a1)
588                (try a3)
589                (when (and (integerp a1)
590                           (integerp a3)
591                           (and (consp a2)
592                                (eq (first a2) 'byte)
593                                (integerp (second a2))
594                                (integerp (third a2))))
595                  (try (eval form))))
596            (prune-fn form try-fn))            (prune-fn form try-fn))
597    
598           ((ldb mask-field)           ((ldb mask-field)

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

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