/[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.58 by pfdietz, Mon Mar 14 03:46:46 2005 UTC revision 1.59 by pfdietz, Sat Apr 23 14:07:35 2005 UTC
# Line 280  Line 280 
280      (let ((d (loop for x = (random r) unless (zerop x) do (return x))))      (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
281        (if (coin) (/ n d) (- (/ n d))))))        (if (coin) (/ n d) (- (/ n d))))))
282    
283    (defun make-random-nonnegative-rational ()
284      (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
285             (n (random r)))
286        (assert (>= r 2))
287        (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
288          (/ n d))))
289    
290    (defun make-random-positive-rational ()
291      (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
292             (n (1+ (random r))))
293        (assert (>= r 2))
294        (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
295          (/ n d))))
296    
297    (defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive)
298      (assert (rationalp upper-limit))
299      (assert (not (minusp upper-limit)))
300      (cond
301       ((= upper-limit 0) 0)
302       ((<= upper-limit 1/1000000)
303        (/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive)
304           1000000))
305       ((>= upper-limit 1000000)
306        (* (random 1000000)
307           (make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive)))
308       (t
309        (assert (< 1/1000000 upper-limit 1000000))
310        (let ((x 0))
311          (loop do (setq x (* upper-limit (rational (random 1.0))))
312                while (or (and (not lower-inclusive) (zerop x))
313                          (and (not upper-inclusive) (= x upper-limit)))
314                finally (return x))))))  
315    
316  (defun make-random-float ()  (defun make-random-float ()
317    (rcase    (rcase
318     (1 (random most-positive-short-float))     (1 (random most-positive-short-float))
# Line 490  Line 523 
523              `(boole ,op ,e1 ,e2)))))                      `(boole ,op ,e1 ,e2)))))        
524    
525       ;; n-ary ops       ;; n-ary ops
526       (40       (20
527        (let* ((op (random-from-seq #(+ - * logand min max        (let* ((op (random-from-seq #(+ - * logand min max
528                                        logior values lcm gcd logxor)))                                        logior values lcm gcd logxor)))
529               (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40)))))               (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40)))))
# Line 1164  Line 1197 
1197               ;; powers of 2...)               ;; powers of 2...)
1198               (random-from-interval (1+ hi) lo)))))               (random-from-interval (1+ hi) lo)))))
1199    
1200            (rational
1201             (or
1202              (let ((r (make-random-element-of-type 'rational)))
1203                (and (typep r type) r))
1204              (let ((lo (cadr type))
1205                    (hi (caddr type))
1206                    lo= hi=)
1207                (cond
1208                 ((consp lo) nil)
1209                 ((member lo '(* nil))
1210                  (setq lo nil)
1211                  (setq lo= nil))
1212                 (t
1213                  (assert (typep lo 'rational))
1214                  (setq lo= t)))
1215                (cond
1216                 ((consp hi) nil)
1217                 ((member hi '(* nil))
1218                  (setq hi nil)
1219                  (setq hi= nil))
1220                 (t
1221                  (assert (typep hi 'rational))
1222                  (setq hi= t)))
1223                (assert (or (null lo) (null hi) (<= lo hi)))
1224                (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=)))
1225                (cond
1226                 ((null lo)
1227                  (cond
1228                   ((null hi) (make-random-rational))
1229                   (hi= (- hi (make-random-nonnegative-rational)))
1230                   (t (- hi (make-random-positive-rational)))))
1231                 ((null hi)
1232                  (cond
1233                   (lo= (+ lo (make-random-nonnegative-rational)))
1234                   (t (+ lo (make-random-positive-rational)))))
1235                 (t
1236                  (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))
1237            
1238          ((single-float double-float long-float short-float)          ((single-float double-float long-float short-float)
1239           (let ((lo (cadr type))           (let ((lo (cadr type))
1240                 (hi (caddr type))                 (hi (caddr type))
# Line 1265  Line 1336 
1336                     when (typep c type)                     when (typep c type)
1337                     return c)))))                     return c)))))
1338          )))          )))
1339       ((typep type 'class)
1340        (make-random-element-of-type (class-name type)))
1341     (t     (t
1342      (ecase type      (ecase type
1343        (bit (random 2))        (bit (random 2))
1344        (boolean (random-from-seq #(nil t)))        (boolean (random-from-seq #(nil t)))
1345        (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))        (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
1346          (keyword (random-from-seq #(:a :b :c :d :e :f :g :h :i :j)))
1347        (unsigned-byte (random-from-interval        (unsigned-byte (random-from-interval
1348                        (1+ (ash 1 (random *maximum-random-int-bits*))) 0))                        (1+ (ash 1 (random *maximum-random-int-bits*))) 0))
1349        (signed-byte (random-from-interval        (signed-byte (random-from-interval
# Line 1283  Line 1357 
1357        ((float)        ((float)
1358         (make-random-element-of-type (random-from-seq #(short-float single-float double-float long-float))))         (make-random-element-of-type (random-from-seq #(short-float single-float double-float long-float))))
1359        ((real) (make-random-element-of-type (random-from-seq #(integer rational float))))        ((real) (make-random-element-of-type (random-from-seq #(integer rational float))))
1360        ((number) (make-random-element-of-type (random-from-seq #(integer rational float complex))))        ((number) (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex))))
1361        ((bit-vector) (make-random-vector 'bit '*))        ((bit-vector) (make-random-vector 'bit '*))
1362        ((simple-bit-vector) (make-random-vector 'bit '* :simple t))        ((simple-bit-vector) (make-random-vector 'bit '* :simple t))
1363        ((vector) (make-random-vector '* '*))        ((vector) (make-random-vector '* '*))
# Line 1298  Line 1372 
1372        ((base-char standard-char)        ((base-char standard-char)
1373         (random-from-seq +standard-chars+))         (random-from-seq +standard-chars+))
1374        ((character) (make-random-character))        ((character) (make-random-character))
1375          ((extended-char) (loop for x = (make-random-character) when (typep x 'extended-char) return x))
1376        ;; Default        ;; Default
1377        ((atom t *) (make-random-element-of-type        ((atom t *) (make-random-element-of-type
1378                (random-from-seq #(real symbol boolean integer unsigned-byte complex character                     (random-from-seq #(real symbol boolean integer unsigned-byte
1379                                        (string 1) (bit-vector 1) complex))))                                             #-ecl complex character
1380                                               (string 1) (bit-vector 1)))))
1381        ((null) nil)        ((null) nil)
1382        ((fixnum)        ((fixnum)
1383         (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum))         (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum))

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

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