GOOPS cosmetics

[bpt/guile.git] / test-suite / tests / srfi-27.test

;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2002 Sebastian Egner
;;;
;;; This code is based on the file conftest.scm in the reference
;;; implementation of SRFI-27, provided under the following license:
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(define-module (test-srfi-27)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-27))

(with-test-prefix "large integers"
  (pass-if "in range"
    (let loop ((k 0) (n 1))
      (cond ((> k 1024)
             #t)
            ((<= 0 (random-integer n) (- n 1))
             (loop (+ k 1) (* n 2)))
            (else
             #f)))))

(with-test-prefix "reals"
  (pass-if "in range"
    (let loop ((k 0) (n 1))
      (if (> k 1000)
          #t
          (let ((x (random-real)))
            (if (< 0 x 1)
                (loop (+ k 1) (* n 2))
                #f))))))

(with-test-prefix "get/set state"
  (let* ((state1 (random-source-state-ref default-random-source))
         (x1 (random-integer (expt 2 32)))
         (state2 (random-source-state-ref default-random-source))
         (x2 (random-integer (expt 2 32))))
    (random-source-state-set! default-random-source state1)
    (pass-if "state1"
      (= x1 (random-integer (expt 2 32))))
    (random-source-state-set! default-random-source state2)
    (pass-if "state2"
      (= x2 (random-integer (expt 2 32))))))

;; These tests throw 'unresolved instead of failing since it /could/
;; happen that `random-source-randomize!' (or
;; `random-source-pseudo-randomize!')  puts the RNG into a state where
;; it generates the same number as before. They should have a very high
;; chance of passing, though.

(with-test-prefix "randomize!"
  (let* ((state1 (random-source-state-ref default-random-source))
         (x1 (random-integer (expt 2 32))))
    (random-source-state-set! default-random-source state1)
    (random-source-randomize! default-random-source)
    (if (= x1 (random-integer (expt 2 32)))
        (throw 'unresolved))))

(with-test-prefix "pseudo-randomize!"
  (let* ((state1 (random-source-state-ref default-random-source))
         (x1 (random-integer (expt 2 32))))
    (random-source-state-set! default-random-source state1)
    (random-source-pseudo-randomize! default-random-source 0 1)
    (let ((y1 (random-integer (expt 2 32))))
      (if (= x1 y1)
          (throw 'unresolved)))
    (random-source-state-set! default-random-source state1)
    (random-source-pseudo-randomize! default-random-source 1 0)
    (let ((y1 (random-integer (expt 2 32))))
      (if (= x1 y1)
          (throw 'unresolved)))))