test-suite/tests/r6rs-base.test

   1 ;;; r6rs-base.test --- Test suite for R6RS (rnrs base)
   2
   3 ;;      Copyright (C) 2010, 2011 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 \f
  19
  20 (define-module (test-suite test-r6rs-base)
  21   :use-module ((rnrs base) :version (6))
  22   :use-module ((rnrs conditions) :version (6))
  23   :use-module ((rnrs exceptions) :version (6))
  24   :use-module (test-suite lib))
  25
  26
  27 ;; numbers are considered =? if their difference is less than a set
  28 ;; tolerance
  29 (define (=? alpha beta)
  30   (< (abs (- alpha beta)) 1e-10))
  31
  32 (with-test-prefix "log (2nd arg)"
  33   (pass-if "log positive-base" (=? (log 8 2) 3))
  34   (pass-if "log negative-base" (=? (real-part (log 256 -4))
  35                                    0.6519359443))
  36   (pass-if "log base-one" (= (log 10 1) +inf.0))
  37   (pass-if "log base-zero"
  38     (catch #t
  39       (lambda () (log 10 0) #f)
  40       (lambda args #t))))
  41
  42 (with-test-prefix "boolean=?"
  43   (pass-if "boolean=? null" (boolean=?))
  44   (pass-if "boolean=? unary" (boolean=? #f))
  45   (pass-if "boolean=? many"
  46     (and (boolean=? #t #t #t)
  47          (boolean=? #f #f #f)
  48          (not (boolean=? #t #f #t))))
  49   (pass-if "boolean=? mixed type" (not (boolean=? #t #t 'foo))))
  50
  51 (with-test-prefix "symbol=?"
  52   (pass-if "symbol=? null" (symbol=?))
  53   (pass-if "symbol=? unary" (symbol=? 'a))
  54   (pass-if "symbol=? many"
  55     (and (symbol=? 'a 'a 'a)
  56          (symbol=? 'foo 'foo 'foo)
  57          (not (symbol=? 'a 'foo 'a))))
  58   (pass-if "symbol=? mixed type" (not (symbol=? 'a 'a 123))))
  59
  60 (with-test-prefix "infinite?"
  61   (pass-if "infinite? true on infinities"
  62     (and (infinite? +inf.0) (infinite? -inf.0)))
  63   (pass-if "infinite? false on non-infities"
  64     (and (not (infinite? 123)) (not (infinite? +nan.0)))))
  65
  66 (with-test-prefix "finite?"
  67   (pass-if "finite? false on infinities"
  68     (and (not (finite? +inf.0)) (not (finite? -inf.0))))
  69   (pass-if "finite? true on non-infinities"
  70     (and (finite? 123) (finite? 123.0))))
  71
  72 (with-test-prefix "exact-integer-sqrt"
  73   (pass-if "exact-integer-sqrt simple"
  74     (let-values (((s e) (exact-integer-sqrt 5)))
  75       (and (eqv? s 2) (eqv? e 1)))))
  76
  77 (with-test-prefix "integer-valued?"
  78   (pass-if "true on integers"
  79     (and (integer-valued? 3) (integer-valued? 3.0) (integer-valued? 3.0+0.0i)))
  80   (pass-if "false on rationals" (not (integer-valued? 3.1)))
  81   (pass-if "false on reals" (not (integer-valued? +nan.0))))
  82
  83 (with-test-prefix "rational-valued?"
  84   (pass-if "true on integers" (rational-valued? 3))
  85   (pass-if "true on rationals"
  86     (and (rational-valued? 3.1) (rational-valued? 3.1+0.0i)))
  87   (pass-if "false on reals"
  88     (or (not (rational-valued? +nan.0))
  89         (throw 'unresolved))))
  90
  91 (with-test-prefix "real-valued?"
  92   (pass-if "true on integers" (real-valued? 3))
  93   (pass-if "true on rationals" (real-valued? 3.1))
  94   (pass-if "true on reals" (real-valued? +nan.0)))
  95
  96 (with-test-prefix "vector-for-each"
  97   (pass-if "vector-for-each simple"
  98     (let ((sum 0))
  99       (vector-for-each (lambda (x) (set! sum (+ sum x))) '#(1 2 3))
 100       (eqv? sum 6))))
 101
 102 (with-test-prefix "vector-map"
 103   (pass-if "vector-map simple"
 104     (equal? '#(3 2 1) (vector-map (lambda (x) (- 4 x)) '#(1 2 3)))))
 105
 106 (with-test-prefix "real-valued?"
 107   (pass-if (real-valued? +nan.0))
 108   (pass-if (real-valued? +nan.0+0i))
 109   (pass-if (real-valued? +nan.0+0.0i))
 110   (pass-if (real-valued? +inf.0))
 111   (pass-if (real-valued? -inf.0))
 112   (pass-if (real-valued? +inf.0+0.0i))
 113   (pass-if (real-valued? -inf.0-0.0i))
 114   (pass-if (real-valued? 3))
 115   (pass-if (real-valued? -2.5))
 116   (pass-if (real-valued? -2.5+0i))
 117   (pass-if (real-valued? -2.5+0.0i))
 118   (pass-if (real-valued? -2.5-0i))
 119   (pass-if (real-valued? #e1e10))
 120   (pass-if (real-valued? 1e200))
 121   (pass-if (real-valued? 1e200+0.0i))
 122   (pass-if (real-valued? 6/10))
 123   (pass-if (real-valued? 6/10+0.0i))
 124   (pass-if (real-valued? 6/10+0i))
 125   (pass-if (real-valued? 6/3))
 126   (pass-if (not (real-valued? 3+i)))
 127   (pass-if (not (real-valued? -2.5+0.01i)))
 128   (pass-if (not (real-valued? +nan.0+0.01i)))
 129   (pass-if (not (real-valued? +nan.0+nan.0i)))
 130   (pass-if (not (real-valued? +inf.0-0.01i)))
 131   (pass-if (not (real-valued? +0.01i)))
 132   (pass-if (not (real-valued? -inf.0i))))
 133
 134 (with-test-prefix "rational-valued?"
 135   (pass-if (not (rational-valued? +nan.0)))
 136   (pass-if (not (rational-valued? +nan.0+0i)))
 137   (pass-if (not (rational-valued? +nan.0+0.0i)))
 138   (pass-if (not (rational-valued? +inf.0)))
 139   (pass-if (not (rational-valued? -inf.0)))
 140   (pass-if (not (rational-valued? +inf.0+0.0i)))
 141   (pass-if (not (rational-valued? -inf.0-0.0i)))
 142   (pass-if (rational-valued? 3))
 143   (pass-if (rational-valued? -2.5))
 144   (pass-if (rational-valued? -2.5+0i))
 145   (pass-if (rational-valued? -2.5+0.0i))
 146   (pass-if (rational-valued? -2.5-0i))
 147   (pass-if (rational-valued? #e1e10))
 148   (pass-if (rational-valued? 1e200))
 149   (pass-if (rational-valued? 1e200+0.0i))
 150   (pass-if (rational-valued? 6/10))
 151   (pass-if (rational-valued? 6/10+0.0i))
 152   (pass-if (rational-valued? 6/10+0i))
 153   (pass-if (rational-valued? 6/3))
 154   (pass-if (not (rational-valued? 3+i)))
 155   (pass-if (not (rational-valued? -2.5+0.01i)))
 156   (pass-if (not (rational-valued? +nan.0+0.01i)))
 157   (pass-if (not (rational-valued? +nan.0+nan.0i)))
 158   (pass-if (not (rational-valued? +inf.0-0.01i)))
 159   (pass-if (not (rational-valued? +0.01i)))
 160   (pass-if (not (rational-valued? -inf.0i))))
 161
 162 (with-test-prefix "integer-valued?"
 163   (pass-if (not (integer-valued? +nan.0)))
 164   (pass-if (not (integer-valued? +nan.0+0i)))
 165   (pass-if (not (integer-valued? +nan.0+0.0i)))
 166   (pass-if (not (integer-valued? +inf.0)))
 167   (pass-if (not (integer-valued? -inf.0)))
 168   (pass-if (not (integer-valued? +inf.0+0.0i)))
 169   (pass-if (not (integer-valued? -inf.0-0.0i)))
 170   (pass-if (integer-valued? 3))
 171   (pass-if (integer-valued? 3.0))
 172   (pass-if (integer-valued? 3+0i))
 173   (pass-if (integer-valued? 3+0.0i))
 174   (pass-if (integer-valued? 8/4))
 175   (pass-if (integer-valued? #e1e10))
 176   (pass-if (integer-valued? 1e200))
 177   (pass-if (integer-valued? 1e200+0.0i))
 178   (pass-if (not (integer-valued? -2.5)))
 179   (pass-if (not (integer-valued? -2.5+0i)))
 180   (pass-if (not (integer-valued? -2.5+0.0i)))
 181   (pass-if (not (integer-valued? -2.5-0i)))
 182   (pass-if (not (integer-valued? 6/10)))
 183   (pass-if (not (integer-valued? 6/10+0.0i)))
 184   (pass-if (not (integer-valued? 6/10+0i)))
 185   (pass-if (not (integer-valued? 3+i)))
 186   (pass-if (not (integer-valued? -2.5+0.01i)))
 187   (pass-if (not (integer-valued? +nan.0+0.01i)))
 188   (pass-if (not (integer-valued? +nan.0+nan.0i)))
 189   (pass-if (not (integer-valued? +inf.0-0.01i)))
 190   (pass-if (not (integer-valued? +0.01i)))
 191   (pass-if (not (integer-valued? -inf.0i))))
 192
 193 (with-test-prefix "assert"
 194   (pass-if "assert returns value" (= 1 (assert 1)))
 195   (pass-if "assertion-violation"
 196     (guard (condition ((assertion-violation? condition) #t))
 197       (assert #f)
 198       #f)))
 199
 200 (with-test-prefix "string-for-each"
 201   (pass-if "reverse string"
 202     (let ((s "reverse me") (l '()))
 203       (string-for-each (lambda (x) (set! l (cons x l))) s)
 204       (equal? "em esrever" (list->string l))))
 205   (pass-if "two strings good"
 206     (let ((s1 "two legs good")
 207           (s2 "four legs bad")
 208           (c '()))
 209       (string-for-each (lambda (c1 c2)
 210                          (set! c (cons* c2 c1 c)))
 211                        s1 s2)
 212       (equal? (list->string c)
 213               "ddaobo gs gsegle lr uoowft")))
 214   (pass-if "two strings bad"
 215     (let ((s1 "frotz")
 216           (s2 "veeblefetzer"))
 217       (guard (condition ((assertion-violation? condition) #t))
 218         (string-for-each (lambda (s1 s2) #f) s1 s2)
 219         #f)))
 220   (pass-if "many strings good"
 221     (let ((s1 "foo")
 222           (s2 "bar")
 223           (s3 "baz")
 224           (s4 "zot")
 225           (c '()))
 226       (string-for-each (lambda (c1 c2 c3 c4)
 227                          (set! c (cons* c4 c3 c2 c1 c)))
 228                        s1 s2 s3 s4)
 229       (equal? (list->string c)
 230               "tzrooaaozbbf")))
 231   (pass-if "many strings bad"
 232     (let ((s1 "foo")
 233           (s2 "bar")
 234           (s3 "baz")
 235           (s4 "quux"))
 236       (guard (condition ((assertion-violation? condition) #t))
 237         (string-for-each (lambda _ #f) s1 s2 s3 s4)
 238         #f))))