test-suite/tests/r6rs-arithmetic-fixnums.test

   1 ;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise)
   2
   3 ;;      Copyright (C) 2010, 2011, 2013 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-arithmetic-fixnums)
  21   :use-module ((rnrs arithmetic fixnums) :version (6))
  22   :use-module ((rnrs conditions) :version (6))
  23   :use-module ((rnrs exceptions) :version (6))
  24   :use-module (test-suite lib))
  25
  26 (with-test-prefix "fixnum-width"
  27   (pass-if-equal "consistent with least-fixnum"
  28       (- (expt 2 (- (fixnum-width) 1)))
  29     (least-fixnum))
  30   (pass-if-equal "consistent with greatest-fixnum"
  31       (- (expt 2 (- (fixnum-width) 1)) 1)
  32     (greatest-fixnum)))
  33
  34 (with-test-prefix "fixnum?"
  35   (pass-if "fixnum? is #t for fixnums" (fixnum? 0))
  36
  37   (pass-if "fixnum? is #f for non-fixnums" (not (fixnum? 'foo)))
  38
  39   (pass-if "fixnum? is #f for non-fixnum numbers"
  40     (and (not (fixnum? 1.0)) (not (fixnum? (+ (greatest-fixnum) 1))))))
  41
  42 (with-test-prefix "fx=?"
  43   (pass-if "fx=? is #t for eqv inputs" (fx=? 3 3 3))
  44
  45   (pass-if "fx=? is #f for non-eqv inputs" (not (fx=? 1 2 3))))
  46
  47 (with-test-prefix "fx>?"
  48   (pass-if "fx>? is #t for monotonically > inputs" (fx>? 3 2 1))
  49
  50   (pass-if "fx>? is #f for non-monotonically > inputs" (not (fx>? 1 2 3))))
  51
  52 (with-test-prefix "fx<?"
  53   (pass-if "fx<? is #t for monotonically < inputs" (fx<? 1 2 3))
  54
  55   (pass-if "fx<? is #t for non-monotonically < inputs" (not (fx<? 3 2 1))))
  56
  57 (with-test-prefix "fx>=?"
  58   (pass-if "fx>=? is #t for monotonically > or = inputs" (fx>=? 3 2 2 1))
  59
  60   (pass-if "fx>=? is #f for non-monotonically > or = inputs"
  61     (not (fx>=? 1 2 3))))
  62
  63 (with-test-prefix "fx<=?"
  64   (pass-if "fx<=? is #t for monotonically < or = inputs" (fx<=? 1 2 2 3))
  65
  66   (pass-if "fx<=? is #f for non-monotonically < or = inputs"
  67     (not (fx<=? 3 2 1))))
  68
  69 (with-test-prefix "fxzero?"
  70   (pass-if "fxzero? is #t for zero" (fxzero? 0))
  71
  72   (pass-if "fxzero? is #f for non-zero fixnums"
  73     (and (not (fxzero? 1)) (not (fxzero? -1)))))
  74
  75 (with-test-prefix "fxpositive?"
  76   (pass-if "fxpositive? is #t for positive fixnums" (fxpositive? 1))
  77
  78   (pass-if "fxpositive? is #f for non-positive fixnums"
  79     (and (not (fxpositive? -1))
  80          (not (fxpositive? 0)))))
  81
  82 (with-test-prefix "fxnegative?"
  83   (pass-if "fxnegative? is #t for negative fixnums" (fxnegative? -1))
  84
  85   (pass-if "fxnegative? is #f for non-negative fixnums"
  86     (and (not (fxnegative? 1))
  87          (not (fxnegative? 0)))))
  88
  89 (with-test-prefix "fxodd?"
  90   (pass-if "fxodd? is #t for odd fixnums" (fxodd? 1))
  91
  92   (pass-if "fxodd? is #f for even fixnums" (not (fxodd? 2))))
  93
  94 (with-test-prefix "fxeven?"
  95   (pass-if "fxeven? is #t for even fixnums" (fxeven? 2))
  96
  97   (pass-if "fxeven? is #f for odd fixnums" (not (fxeven? 1))))
  98
  99 (with-test-prefix "fxmax" (pass-if "simple" (fx=? (fxmax 1 3 2) 3)))
 100
 101 (with-test-prefix "fxmin" (pass-if "simple" (fx=? (fxmin -1 0 2) -1)))
 102
 103 (with-test-prefix "fx+"
 104   (pass-if "simple" (fx=? (fx+ 1 2) 3))
 105
 106   (pass-if "&implementation-restriction on non-fixnum result"
 107     (guard (condition ((implementation-restriction-violation? condition) #t)
 108                       (else #f))
 109            (begin (fx+ (greatest-fixnum) 1) #f))))
 110
 111 (with-test-prefix "fx*"
 112   (pass-if "simple" (fx=? (fx* 2 3) 6))
 113
 114   (pass-if "&implementation-restriction on non-fixnum result"
 115     (guard (condition ((implementation-restriction-violation? condition) #t)
 116                       (else #f))
 117            (begin (fx* (greatest-fixnum) 2) #f))))
 118
 119 (with-test-prefix "fx-"
 120   (pass-if "unary fx- negates argument" (fx=? (fx- 1) -1))
 121
 122   (pass-if "simple" (fx=? (fx- 3 2) 1))
 123
 124   (pass-if "&assertion on non-fixnum result"
 125     (guard (condition ((assertion-violation? condition) #t) (else #f))
 126            (fx- (least-fixnum) 1))))
 127
 128 (with-test-prefix "fxdiv-and-mod"
 129   (pass-if "simple"
 130     (call-with-values (lambda () (fxdiv-and-mod 123 10))
 131       (lambda (d m)
 132         (and (fx=? d 12) (fx=? m 3))))))
 133
 134 (with-test-prefix "fxdiv" (pass-if "simple" (fx=? (fxdiv -123 10) -13)))
 135 (with-test-prefix "fxmod" (pass-if "simple" (fx=? (fxmod -123 10) 7)))
 136
 137 (with-test-prefix "fxdiv0-and-mod0"
 138   (pass-if "simple"
 139     (call-with-values (lambda () (fxdiv0-and-mod0 -123 10))
 140       (lambda (d m)
 141         (and (fx=? d -12) (fx=? m -3))))))
 142
 143 (with-test-prefix "fxdiv0" (pass-if "simple" (fx=? (fxdiv0 -123 10) -12)))
 144 (with-test-prefix "fxmod0" (pass-if "simple" (fx=? (fxmod0 -123 10) -3)))
 145
 146
 147 ;; Without working div and mod implementations and without any example results
 148 ;; from the spec, I have no idea what the results of these functions should
 149 ;; be.  -juliang
 150 ;; UPDATE: div and mod implementations are now working properly  -mhw
 151
 152 (with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved)))
 153
 154 (with-test-prefix "fx-/carry" (pass-if "simple" (throw 'unresolved)))
 155
 156 (with-test-prefix "fx*/carry" (pass-if "simple" (throw 'unresolved)))
 157
 158 (with-test-prefix "fxnot" (pass-if "simple" (fx=? (fxnot 3) -4)))
 159
 160 (with-test-prefix "fxand" (pass-if "simple" (fx=? (fxand 5 6) 4)))
 161
 162 (with-test-prefix "fxior" (pass-if "simple" (fx=? (fxior 2 4) 6)))
 163
 164 (with-test-prefix "fxxor" (pass-if "simple" (fx=? (fxxor 5 4) 1)))
 165
 166 (with-test-prefix "fxif" (pass-if "simple" (fx=? (fxif 5 3 4) 1)))
 167
 168 (with-test-prefix "fxbit-count"
 169   (pass-if "simple" (fx=? (fxbit-count 5) 2))
 170   (pass-if "negative" (fx=? (fxbit-count -5) -2)))
 171
 172 (with-test-prefix "fxlength" (pass-if "simple" (fx=? (fxlength 5) 3)))
 173
 174 (with-test-prefix "fxfirst-bit-set"
 175   (pass-if "simple"
 176     (and (eqv? (fxfirst-bit-set 1) 0)
 177          (eqv? (fxfirst-bit-set -4) 2)))
 178
 179   (pass-if "fxfirst-bit-set is -1 on zero"
 180     (and (eqv? (fxfirst-bit-set 0) -1))))
 181
 182 (with-test-prefix "fxbit-set?"
 183   (pass-if "fxbit-set? is #t on index of set bit" (fxbit-set? 5 2))
 184
 185   (pass-if "fxbit-set? is #f on index of unset bit" (not (fxbit-set? 5 1))))
 186
 187 (with-test-prefix "fxcopy-bit" (pass-if "simple" (fx=? (fxcopy-bit 2 2 1) 6)))
 188
 189 (with-test-prefix "fxbit-field"
 190   (pass-if "simple" (fx=? (fxbit-field 50 1 4) 1)))
 191
 192 (with-test-prefix "fxcopy-bit-field"
 193   (pass-if "simple" (fx=? (fxcopy-bit-field 255 2 6 10) 235)))
 194
 195 (with-test-prefix "fxarithmetic-shift"
 196   (pass-if "simple"
 197     (and (fx=? (fxarithmetic-shift -6 -1) -3)
 198          (fx=? (fxarithmetic-shift -5 -1) -3)
 199          (fx=? (fxarithmetic-shift -4 -1) -2)
 200          (fx=? (fxarithmetic-shift -3 -1) -2)
 201          (fx=? (fxarithmetic-shift -2 -1) -1)
 202          (fx=? (fxarithmetic-shift -1 -1) -1))))
 203
 204 (with-test-prefix "fxarithmetic-shift-left"
 205   (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 -1) -3)))
 206
 207 (with-test-prefix "fxarithmetic-shift-right"
 208   (pass-if "simple" (fx=? (fxarithmetic-shift-right -6 1) -3)))
 209
 210 (with-test-prefix "fxrotate-bit-field"
 211   (pass-if "simple" (fx=? (fxrotate-bit-field 227 2 6 2) 203)))
 212
 213 (with-test-prefix "fxreverse-bit-field"
 214   (pass-if "simple" (fx=? (fxreverse-bit-field 82 1 4) 88)))