/[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.47 by pfdietz, Sat Aug 7 23:02:26 2004 UTC revision 1.48 by pfdietz, Wed Sep 15 13:00:10 2004 UTC
# Line 151  Line 151 
151                               :index (+ index i)                               :index (+ index i)
152                               :file-prefix file-prefix)))                               :file-prefix file-prefix)))
153                  (when result                  (when result
154                    (let ((*print-readably* t))                    (let ((*print-readably* nil))
155                      (format t "~%~A~%" (format nil "~S" (car result)))                      (format t "~%~A~%" (format nil "~S" (car result)))
156                      (finish-output *standard-output*)))                      (finish-output *standard-output*)))
157                  result)))                  result)))
# Line 206  Line 206 
206      (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2)))      (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2)))
207    
208  (defun make-random-optimize-settings ()  (defun make-random-optimize-settings ()
209    (loop for settings = (cons    (loop for settings = (list*
210                          (list 'speed (1+ (random 3)))                          (list 'speed (random 4))
211                            #+sbcl '(sb-c:insert-step-conditions 0)
212                          (loop for s in '(space safety debug compilation-speed)                          (loop for s in '(space safety debug compilation-speed)
213                                for n = (random 4)                                for n = (random 4)
214                                collect (list s n)))                                collect (list s n)))
215          while          while
216          #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal)          #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal)
217          #-allegro nil          #-allegro nil
218          finally (return settings)))          finally (return (random-permute settings))))
219    
220  (defun fn-symbols-in-form (form)  (defun fn-symbols-in-form (form)
221    "Return a list of the distinct standardized lisp function    "Return a list of the distinct standardized lisp function
# Line 259  Line 260 
260    (let ((r (ash 1 (1+ (random 32)))))    (let ((r (ash 1 (1+ (random 32)))))
261      (- (random r) (floor (/ r 2)))))      (- (random r) (floor (/ r 2)))))
262    
263    (defun make-random-rational ()
264      (let* ((r (ash 1 (1+ (random 32))))
265             (n (random r))
266             (d (loop for x = (random r) unless (zerop x) do (return x))))
267        (if (coin) (/ n d) (- (/ n d)))))
268    
269    (defun make-random-float ()
270      (rcase
271       (1 (random most-positive-short-float))
272       (1 (random most-positive-single-float))
273       (1 (random most-positive-double-float))
274       (1 (random most-positive-long-float))))
275    
276  (defun random-var-desc ()  (defun random-var-desc ()
277    (loop    (loop
278     (let* ((pos (random (length *vars*)))     (let* ((pos (random (length *vars*)))
# Line 401  Line 415 
415       (2 (make-random-integer-eval-form size))       (2 (make-random-integer-eval-form size))
416                
417       #-(or cmu allegro)       #-(or cmu allegro)
418       (2       (20
419        (destructuring-bind (s1 s2)        (destructuring-bind (s1 s2)
420            (random-partition (- size 2) 2)            (random-partition (- size 2) 2)
421          `(ash ,(make-random-integer-form s1)          `(ash ,(make-random-integer-form s1)
# Line 512  Line 526 
526               (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))               (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
527          `(block ,name ,(make-random-integer-form (1- size)))))          `(block ,name ,(make-random-integer-form (1- size)))))
528    
529         #-armedbear
530       (20       (20
531        (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8))))        (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8))))
532               (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))               (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
# Line 549  Line 564 
564          ;; No blocks -- try again          ;; No blocks -- try again
565          (make-random-integer-form size)))          (make-random-integer-form size)))
566    
567       ; #-(or armedbear)       #-(or armedbear)
568       (20       (20
569        (make-random-flet-form size))        (make-random-flet-form size))
570    
# Line 917  Line 932 
932                   (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p)                   (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p)
933                                                    *flet-names*)))                                                    *flet-names*)))
934                            (make-random-integer-form s2)))                            (make-random-integer-form s2)))
935                   (opt-forms (mapcar #'make-random-integer-form opt-sizes)))                   (opt-forms (mapcar #'make-random-integer-form opt-sizes)
936                                ))
937              (if opt-forms              (if opt-forms
938                  `(,op ((,fname (,@(subseq arg-names 0 minargs)                  `(,op ((,fname (,@(subseq arg-names 0 minargs)
939                                    &optional                                    &optional
# Line 1490  Line 1506 
1506           ((coerce)           ((coerce)
1507            (try 0)            (try 0)
1508            (try (car args))            (try (car args))
1509            (prune #'(lambda (form) (try `(coerce ,form ,(cadr args))))            (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr args))))))
                  (car args)))  
1510                        
1511    
1512           ((multiple-value-call)           ((multiple-value-call)

Legend:
Removed from v.1.47  
changed lines
  Added in v.1.48

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