/[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.59 by pfdietz, Sat Apr 23 14:07:35 2005 UTC revision 1.60 by pfdietz, Fri Jul 1 12:34:36 2005 UTC
# Line 108  Line 108 
108  (defvar *random-int-form-catch-tags* nil)  (defvar *random-int-form-catch-tags* nil)
109  (defvar *go-tags* nil)  (defvar *go-tags* nil)
110    
 (defvar *maximum-random-int-bits* 36)  
   
111  (defvar *random-vals-list-bound* 10)  (defvar *random-vals-list-bound* 10)
112    
113  (defvar *max-compile-time* 0)  (defvar *max-compile-time* 0)
# Line 241  Line 239 
239          (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form)))          (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form)))
240        (mapcan #'fn-symbols-in-form* form))))        (mapcan #'fn-symbols-in-form* form))))
241    
 (defun make-random-integer-range (&optional var)  
   "Generate a list (LO HI) of integers, LO <= HI.  This is used  
    for generating integer types."  
   (declare (ignore var))  
   (rcase  
    (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))  
                       (- (random r) (floor (/ r 2))))))  
         (let ((x (%r))  
               (y (%r)))  
           (list (min x y) (max x y)))))  
    (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*))))  
              (b2 (floor (/ b 2))))  
         (let ((x (- (random b) b2))  
               (y (- (random b) b2)))  
           (list (min x y) (max x y)))))))  
   
242  (defun fn-arg-name (fn-name arg-index)  (defun fn-arg-name (fn-name arg-index)
243    (intern (concatenate 'string    (intern (concatenate 'string
244                         (subseq (symbol-name fn-name) 1)                         (subseq (symbol-name fn-name) 1)
# Line 266  Line 248 
248  (declaim (special *flet-names*))  (declaim (special *flet-names*))
249  (defparameter *flet-names* nil)  (defparameter *flet-names* nil)
250    
251  (defun make-random-integer ()  
   (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))  
     (rcase  
      (6 (- (random r) (floor (/ r 2))))  
      (1 (- r (random (min 10 r))))  
      (1 (+ (floor (/ r 2)) (random (min 10 r)))))))  
   
 (defun make-random-rational ()  
   (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))  
          (n (random r)))  
     (assert (>= r 2))  
     (let ((d (loop for x = (random r) unless (zerop x) do (return x))))  
       (if (coin) (/ n d) (- (/ n d))))))  
   
 (defun make-random-nonnegative-rational ()  
   (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))  
          (n (random r)))  
     (assert (>= r 2))  
     (let ((d (loop for x = (random r) unless (zerop x) do (return x))))  
       (/ n d))))  
   
 (defun make-random-positive-rational ()  
   (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))  
          (n (1+ (random r))))  
     (assert (>= r 2))  
     (let ((d (loop for x = (random r) unless (zerop x) do (return x))))  
       (/ n d))))  
   
 (defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive)  
   (assert (rationalp upper-limit))  
   (assert (not (minusp upper-limit)))  
   (cond  
    ((= upper-limit 0) 0)  
    ((<= upper-limit 1/1000000)  
     (/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive)  
        1000000))  
    ((>= upper-limit 1000000)  
     (* (random 1000000)  
        (make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive)))  
    (t  
     (assert (< 1/1000000 upper-limit 1000000))  
     (let ((x 0))  
       (loop do (setq x (* upper-limit (rational (random 1.0))))  
             while (or (and (not lower-inclusive) (zerop x))  
                       (and (not upper-inclusive) (= x upper-limit)))  
             finally (return x))))))    
   
 (defun make-random-float ()  
   (rcase  
    (1 (random most-positive-short-float))  
    (1 (random most-positive-single-float))  
    (1 (random most-positive-double-float))  
    (1 (random most-positive-long-float))))  
   
 (defun make-random-symbol ()  
   (rcase  
    (3 (random-from-seq #(a b c d e f g h i j k l m n o p q r s t u v w x y z)))  
    (2 (random-from-seq *cl-symbols-vector*))  
    (1 (gensym))))  
252    
253  (defun random-var-desc ()  (defun random-var-desc ()
254    (loop    (loop
# Line 426  Line 350 
350            
351       (2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))       (2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))
352    
      ;; #-armedbear  
353       (10 `(the integer ,(make-random-integer-form (1- size))))       (10 `(the integer ,(make-random-integer-form (1- size))))
354                
355       (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size))))       (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size))))
# Line 549  Line 472 
472       (5 (make-random-tagbody-and-progn size))       (5 (make-random-tagbody-and-progn size))
473    
474       ;; conditionals       ;; conditionals
475       (30       (60
476        (let* ((cond-size (random (max 1 (floor size 2))))        (let* ((cond-size (random (max 1 (floor size 2))))
477               (then-size (random (- size cond-size)))               (then-size (random (- size cond-size)))
478               (else-size (- size 1 cond-size then-size))               (else-size (- size 1 cond-size then-size))
# Line 575  Line 498 
498       (50 (make-random-integer-binding-form size))       (50 (make-random-integer-binding-form size))
499    
500       ;; progv       ;; progv
501       #-(or armedbear ecl)       #-(or ecl)
502       (4 (make-random-integer-progv-form size))       (4 (make-random-integer-progv-form size))
503            
504       (4 `(let () ,(make-random-integer-form (1- size))))       (4 `(let () ,(make-random-integer-form (1- size))))
# Line 1068  Line 991 
991      (rcase      (rcase
992        (1 (if (coin) t nil))        (1 (if (coin) t nil))
993        (3 `(not ,(make-random-pred-form (1- size))))        (3 `(not ,(make-random-pred-form (1- size))))
994        (6 (destructuring-bind (leftsize rightsize)        (12 (destructuring-bind (leftsize rightsize)
995               (random-partition (1- size) 2)               (random-partition (1- size) 2)
996             `(,(random-from-seq '(and or))             `(,(random-from-seq '(and or))
997               ,(make-random-pred-form leftsize)               ,(make-random-pred-form leftsize)

Legend:
Removed from v.1.59  
changed lines
  Added in v.1.60

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