test-suite/tests/srfi-27.test

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2 ;;;
   3 ;;; Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;; Copyright (C) 2002 Sebastian Egner
   5 ;;;
   6 ;;; This code is based on the file conftest.scm in the reference
   7 ;;; implementation of SRFI-27, provided under the following license:
   8 ;;;
   9 ;;; Permission is hereby granted, free of charge, to any person obtaining
  10 ;;; a copy of this software and associated documentation files (the
  11 ;;; "Software"), to deal in the Software without restriction, including
  12 ;;; without limitation the rights to use, copy, modify, merge, publish,
  13 ;;; distribute, sublicense, and/or sell copies of the Software, and to
  14 ;;; permit persons to whom the Software is furnished to do so, subject to
  15 ;;; the following conditions:
  16 ;;;
  17 ;;; The above copyright notice and this permission notice shall be
  18 ;;; included in all copies or substantial portions of the Software.
  19 ;;;
  20 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  21 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  22 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  23 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
  24 ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
  25 ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
  26 ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  27 ;;; SOFTWARE.
  28
  29 (define-module (test-srfi-27)
  30   #:use-module (test-suite lib)
  31   #:use-module (srfi srfi-27))
  32
  33 (with-test-prefix "large integers"
  34   (pass-if "in range"
  35     (let loop ((k 0) (n 1))
  36       (cond ((> k 1024)
  37              #t)
  38             ((<= 0 (random-integer n) (- n 1))
  39              (loop (+ k 1) (* n 2)))
  40             (else
  41              #f)))))
  42
  43 (with-test-prefix "reals"
  44   (pass-if "in range"
  45     (let loop ((k 0) (n 1))
  46       (if (> k 1000)
  47           #t
  48           (let ((x (random-real)))
  49             (if (< 0 x 1)
  50                 (loop (+ k 1) (* n 2))
  51                 #f))))))
  52
  53 (with-test-prefix "get/set state"
  54   (let* ((state1 (random-source-state-ref default-random-source))
  55          (x1 (random-integer (expt 2 32)))
  56          (state2 (random-source-state-ref default-random-source))
  57          (x2 (random-integer (expt 2 32))))
  58     (random-source-state-set! default-random-source state1)
  59     (pass-if "state1"
  60       (= x1 (random-integer (expt 2 32))))
  61     (random-source-state-set! default-random-source state2)
  62     (pass-if "state2"
  63       (= x2 (random-integer (expt 2 32))))))
  64
  65 ;; These tests throw 'unresolved instead of failing since it /could/
  66 ;; happen that `random-source-randomize!' (or
  67 ;; `random-source-pseudo-randomize!')  puts the RNG into a state where
  68 ;; it generates the same number as before. They should have a very high
  69 ;; chance of passing, though.
  70
  71 (with-test-prefix "randomize!"
  72   (let* ((state1 (random-source-state-ref default-random-source))
  73          (x1 (random-integer (expt 2 32))))
  74     (random-source-state-set! default-random-source state1)
  75     (random-source-randomize! default-random-source)
  76     (if (= x1 (random-integer (expt 2 32)))
  77         (throw 'unresolved))))
  78
  79 (with-test-prefix "pseudo-randomize!"
  80   (let* ((state1 (random-source-state-ref default-random-source))
  81          (x1 (random-integer (expt 2 32))))
  82     (random-source-state-set! default-random-source state1)
  83     (random-source-pseudo-randomize! default-random-source 0 1)
  84     (let ((y1 (random-integer (expt 2 32))))
  85       (if (= x1 y1)
  86           (throw 'unresolved)))
  87     (random-source-state-set! default-random-source state1)
  88     (random-source-pseudo-randomize! default-random-source 1 0)
  89     (let ((y1 (random-integer (expt 2 32))))
  90       (if (= x1 y1)
  91           (throw 'unresolved)))))