test-suite/tests/srfi-60.test

   1 ;;;; srfi-60.test --- Test suite for Guile's SRFI-60 functions. -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2005, 2006 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
  19 (define-module (test-srfi-60)
  20   #:duplicates (last)  ;; avoid warning about srfi-60 replacing `bit-count'
  21   #:use-module (test-suite lib)
  22   #:use-module (srfi srfi-60))
  23
  24
  25 (pass-if "cond-expand srfi-60"
  26   (cond-expand (srfi-60 #t)
  27                (else    #f)))
  28
  29 ;;
  30 ;; logand
  31 ;;
  32
  33 (with-test-prefix "logand"
  34   (pass-if (eqv? 6 (logand 14 6))))
  35
  36 ;;
  37 ;; bitwise-and
  38 ;;
  39
  40 (with-test-prefix "bitwise-and"
  41   (pass-if (eqv? 6 (bitwise-and 14 6))))
  42
  43 ;;
  44 ;; logior
  45 ;;
  46
  47 (with-test-prefix "logior"
  48   (pass-if (eqv? 14 (logior 10 12))))
  49
  50 ;;
  51 ;; bitwise-ior
  52 ;;
  53
  54 (with-test-prefix "bitwise-ior"
  55   (pass-if (eqv? 14 (bitwise-ior 10 12))))
  56
  57 ;;
  58 ;; logxor
  59 ;;
  60
  61 (with-test-prefix "logxor"
  62   (pass-if (eqv? 6 (logxor 10 12))))
  63
  64 ;;
  65 ;; bitwise-xor
  66 ;;
  67
  68 (with-test-prefix "bitwise-xor"
  69   (pass-if (eqv? 6 (bitwise-xor 10 12))))
  70
  71 ;;
  72 ;; lognot
  73 ;;
  74
  75 (with-test-prefix "lognot"
  76   (pass-if (eqv? -1 (lognot 0)))
  77   (pass-if (eqv? 0 (lognot -1))))
  78
  79 ;;
  80 ;; bitwise-not
  81 ;;
  82
  83 (with-test-prefix "bitwise-not"
  84   (pass-if (eqv? -1 (bitwise-not 0)))
  85   (pass-if (eqv? 0 (bitwise-not -1))))
  86
  87 ;;
  88 ;; bitwise-if
  89 ;;
  90
  91 (with-test-prefix "bitwise-if"
  92   (pass-if (eqv? 9 (bitwise-if 3 1 8)))
  93   (pass-if (eqv? 0 (bitwise-if 3 8 1))))
  94
  95 ;;
  96 ;; bitwise-merge
  97 ;;
  98
  99 (with-test-prefix "bitwise-merge"
 100   (pass-if (eqv? 9 (bitwise-merge 3 1 8)))
 101   (pass-if (eqv? 0 (bitwise-merge 3 8 1))))
 102
 103 ;;
 104 ;; logtest
 105 ;;
 106
 107 (with-test-prefix "logtest"
 108   (pass-if (eq? #t (logtest 3 6)))
 109   (pass-if (eq? #f (logtest 3 12))))
 110
 111 ;;
 112 ;; any-bits-set?
 113 ;;
 114
 115 (with-test-prefix "any-bits-set?"
 116   (pass-if (eq? #t (any-bits-set? 3 6)))
 117   (pass-if (eq? #f (any-bits-set? 3 12))))
 118
 119 ;;
 120 ;; logcount
 121 ;;
 122
 123 (with-test-prefix "logcount"
 124   (pass-if (eqv? 2 (logcount 12))))
 125
 126 ;;
 127 ;; bit-count
 128 ;;
 129
 130 (with-test-prefix "bit-count"
 131   (pass-if (eqv? 2 (bit-count 12))))
 132
 133 ;;
 134 ;; integer-length
 135 ;;
 136
 137 (with-test-prefix "integer-length"
 138   (pass-if (eqv? 0 (integer-length 0)))
 139   (pass-if (eqv? 8 (integer-length 128)))
 140   (pass-if (eqv? 8 (integer-length 255)))
 141   (pass-if (eqv? 9 (integer-length 256))))
 142
 143 ;;
 144 ;; log2-binary-factors
 145 ;;
 146
 147 (with-test-prefix "log2-binary-factors"
 148   (pass-if (eqv? -1 (log2-binary-factors 0)))
 149   (pass-if (eqv? 0 (log2-binary-factors 1)))
 150   (pass-if (eqv? 0 (log2-binary-factors 3)))
 151   (pass-if (eqv? 2 (log2-binary-factors 4)))
 152   (pass-if (eqv? 1 (log2-binary-factors 6)))
 153   (pass-if (eqv? 0 (log2-binary-factors -1)))
 154   (pass-if (eqv? 1 (log2-binary-factors -2)))
 155   (pass-if (eqv? 0 (log2-binary-factors -3)))
 156   (pass-if (eqv? 2 (log2-binary-factors -4)))
 157   (pass-if (eqv? 128 (log2-binary-factors #x100000000000000000000000000000000))))
 158
 159 ;;
 160 ;; first-set-bit
 161 ;;
 162
 163 (with-test-prefix "first-set-bit"
 164   (pass-if (eqv? -1 (first-set-bit 0)))
 165   (pass-if (eqv? 0 (first-set-bit 1)))
 166   (pass-if (eqv? 0 (first-set-bit 3)))
 167   (pass-if (eqv? 2 (first-set-bit 4)))
 168   (pass-if (eqv? 1 (first-set-bit 6)))
 169   (pass-if (eqv? 0 (first-set-bit -1)))
 170   (pass-if (eqv? 1 (first-set-bit -2)))
 171   (pass-if (eqv? 0 (first-set-bit -3)))
 172   (pass-if (eqv? 2 (first-set-bit -4))))
 173
 174 ;;
 175 ;; logbit?
 176 ;;
 177
 178 (with-test-prefix "logbit?"
 179   (pass-if (eq? #t (logbit? 0 1)))
 180   (pass-if (eq? #f (logbit? 1 1)))
 181   (pass-if (eq? #f (logbit? 1 8)))
 182   (pass-if (eq? #t (logbit? 1000 -1))))
 183
 184 ;;
 185 ;; bit-set?
 186 ;;
 187
 188 (with-test-prefix "bit-set?"
 189   (pass-if (eq? #t (bit-set? 0 1)))
 190   (pass-if (eq? #f (bit-set? 1 1)))
 191   (pass-if (eq? #f (bit-set? 1 8)))
 192   (pass-if (eq? #t (bit-set? 1000 -1))))
 193
 194 ;;
 195 ;; copy-bit
 196 ;;
 197
 198 (with-test-prefix "copy-bit"
 199   (pass-if (eqv? 0 (copy-bit 0 0 #f)))
 200   (pass-if (eqv? 0 (copy-bit 30 0 #f)))
 201   (pass-if (eqv? 0 (copy-bit 31 0 #f)))
 202   (pass-if (eqv? 0 (copy-bit 62 0 #f)))
 203   (pass-if (eqv? 0 (copy-bit 63 0 #f)))
 204   (pass-if (eqv? 0 (copy-bit 128 0 #f)))
 205
 206   (pass-if (eqv? -1 (copy-bit 0 -1 #t)))
 207   (pass-if (eqv? -1 (copy-bit 30 -1 #t)))
 208   (pass-if (eqv? -1 (copy-bit 31 -1 #t)))
 209   (pass-if (eqv? -1 (copy-bit 62 -1 #t)))
 210   (pass-if (eqv? -1 (copy-bit 63 -1 #t)))
 211   (pass-if (eqv? -1 (copy-bit 128 -1 #t)))
 212
 213   (pass-if (eqv? 1 (copy-bit 0 0 #t)))
 214   (pass-if (eqv? #x106 (copy-bit 8 6 #t)))
 215   (pass-if (eqv? 6 (copy-bit 8 6 #f)))
 216   (pass-if (eqv? -2 (copy-bit 0 -1 #f)))
 217
 218   (pass-if "bignum becomes inum"
 219     (eqv? 0 (copy-bit 128 #x100000000000000000000000000000000 #f)))
 220
 221   ;; bignums unchanged
 222   (pass-if (eqv? #x100000000000000000000000000000000
 223                  (copy-bit 128 #x100000000000000000000000000000000 #t)))
 224   (pass-if (eqv? #x100000000000000000000000000000000
 225                  (copy-bit 64 #x100000000000000000000000000000000 #f)))
 226   (pass-if (eqv? #x-100000000000000000000000000000000
 227                  (copy-bit 64 #x-100000000000000000000000000000000 #f)))
 228   (pass-if (eqv? #x-100000000000000000000000000000000
 229                  (copy-bit 256 #x-100000000000000000000000000000000 #t))))
 230
 231 ;;
 232 ;; bit-field
 233 ;;
 234
 235 (with-test-prefix "bit-field"
 236   (pass-if (eqv? 0 (bit-field 6 0 1)))
 237   (pass-if (eqv? 3 (bit-field 6 1 3)))
 238   (pass-if (eqv? 1 (bit-field 6 2 999)))
 239   (pass-if (eqv? 1 (bit-field #x100000000000000000000000000000000 128 129))))
 240
 241 ;;
 242 ;; copy-bit-field
 243 ;;
 244
 245 (with-test-prefix "copy-bit-field"
 246   (pass-if (eqv? #b111 (copy-bit-field #b110 1 0 1)))
 247   (pass-if (eqv? #b110 (copy-bit-field #b110 1 1 2)))
 248   (pass-if (eqv? #b010 (copy-bit-field #b110 1 1 3))))
 249
 250 ;;
 251 ;; ash
 252 ;;
 253
 254 (with-test-prefix "ash"
 255   (pass-if (eqv? 2 (ash 1 1)))
 256   (pass-if (eqv? 0 (ash 1 -1))))
 257
 258 ;;
 259 ;; arithmetic-shift
 260 ;;
 261
 262 (with-test-prefix "arithmetic-shift"
 263   (pass-if (eqv? 2 (arithmetic-shift 1 1)))
 264   (pass-if (eqv? 0 (arithmetic-shift 1 -1))))
 265
 266 ;;
 267 ;; rotate-bit-field
 268 ;;
 269
 270 (with-test-prefix "rotate-bit-field"
 271   (define-syntax-rule (check expected x count start end)
 272     (begin
 273       (pass-if-equal expected (rotate-bit-field x count start end))
 274       (pass-if-equal (lognot expected)
 275           (rotate-bit-field (lognot x) count start end))))
 276
 277   (check #b110  #b110 1 1 2)
 278   (check #b1010 #b110 1 2 4)
 279   (check #b1011 #b0111 -1 1 4)
 280
 281   (check #b0 #b0 128 0 256)
 282   (check #b1 #b1 128 1 256)
 283   (check #x100000000000000000000000000000000
 284          #x100000000000000000000000000000000 128 0 64)
 285   (check #x100000000000000000000000000000008
 286          #x100000000000000000000000000000001 3 0 64)
 287   (check #x100000000000000002000000000000000
 288          #x100000000000000000000000000000001 -3 0 64)
 289
 290   (check #b110 #b110 0 0 10)
 291   (check #b110 #b110 0 0 256)
 292
 293   (check #b110  #b110 1 1 1)
 294
 295   (check #b10111010001100111101110010101
 296          #b11010001100111101110001110101 -26 5 28)
 297   (check #b11000110011110111000111011001
 298          #b11010001100111101110001110101 28 2 28)
 299
 300   (check #b01111010001100111101110010101
 301          #b11010001100111101110001110101 -3 5 29)
 302   (check #b10100011001111011100011101101
 303          #b11010001100111101110001110101 28 2 29)
 304
 305   (check #b110110100011001111011100010101
 306          #b011010001100111101110001110101 48 5 30)
 307   (check #b110100011001111011100011101001
 308          #b011010001100111101110001110101 85 2 30)
 309   (check #b011010001100111101110001110101
 310          #b110100011001111011100011101001 83 2 30)
 311
 312   (check
 313    #b1101100110101001110000111110011010000111011101011101110111011
 314    #b1100110101001110000111110011010000111011101011101110110111011 -3 5 60)
 315   (check
 316    #b1011010100111000011111001101000011101110101110111011011101110
 317    #b1100110101001110000111110011010000111011101011101110110111011 62 0 60)
 318
 319   (check
 320    #b1011100110101001110000111110011010000111011101011101110111011
 321    #b1100110101001110000111110011010000111011101011101110110111011 53 5 61)
 322   (check
 323    #b1001101010011100001111100110100001110111010111011101101110111
 324    #b1100110101001110000111110011010000111011101011101110110111011 62 0 61)
 325
 326   (check
 327    #b11011001101010011100001111100110100001110111010111011100111011
 328    #b01100110101001110000111110011010000111011101011101110110111011 53 7 62)
 329   (check
 330    #b11011001101010011100001111100110100001110111010111011100111011
 331    #b01100110101001110000111110011010000111011101011101110110111011 -2 7 62)
 332   (check
 333    #b01100110101001110000111110011010000111011101011101110110111011
 334    #b11011001101010011100001111100110100001110111010111011100111011 2 7 62)
 335
 336   (pass-if-equal "bignum becomes inum"
 337       1
 338     (rotate-bit-field #x100000000000000000000000000000000 1 0 129)))
 339
 340 ;;
 341 ;; reverse-bit-field
 342 ;;
 343
 344 (with-test-prefix "reverse-bit-field"
 345   (pass-if (eqv? 6 (reverse-bit-field 6 1 3)))
 346   (pass-if (eqv? 12 (reverse-bit-field 6 1 4)))
 347
 348   (pass-if (eqv? #x80000000 (reverse-bit-field 1 0 32)))
 349   (pass-if (eqv? #x40000000 (reverse-bit-field 1 0 31)))
 350   (pass-if (eqv? #x20000000 (reverse-bit-field 1 0 30)))
 351
 352   (pass-if (eqv? (logior (ash -1 32) #xFBFFFFFF)
 353                  (reverse-bit-field -2 0 27)))
 354   (pass-if (eqv? (logior (ash -1 32) #xF7FFFFFF)
 355                  (reverse-bit-field -2 0 28)))
 356   (pass-if (eqv? (logior (ash -1 32) #xEFFFFFFF)
 357                  (reverse-bit-field -2 0 29)))
 358   (pass-if (eqv? (logior (ash -1 32) #xDFFFFFFF)
 359                  (reverse-bit-field -2 0 30)))
 360   (pass-if (eqv? (logior (ash -1 32) #xBFFFFFFF)
 361                  (reverse-bit-field -2 0 31)))
 362   (pass-if (eqv? (logior (ash -1 32) #x7FFFFFFF)
 363                  (reverse-bit-field -2 0 32)))
 364
 365   (pass-if "bignum becomes inum"
 366     (eqv? 5 (reverse-bit-field #x140000000000000000000000000000000 0 129))))
 367
 368 ;;
 369 ;; integer->list
 370 ;;
 371
 372 (with-test-prefix "integer->list"
 373   (pass-if (equal? '(#t #t #f) (integer->list 6)))
 374   (pass-if (equal? '(#f #t #t #f) (integer->list 6 4)))
 375   (pass-if (equal? '(#t #f) (integer->list 6 2)))
 376
 377   (pass-if "zeros above top of positive inum"
 378     (equal? '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 379                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 380                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 381                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 382                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 383                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 384                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 385                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
 386             (integer->list 1 128)))
 387
 388   (pass-if "ones above top of negative inum"
 389     (equal? '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 390                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 391                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 392                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 393                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 394                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 395                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 396                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)
 397             (integer->list -1 128)))
 398
 399   (pass-if (equal? '(#t
 400                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 401                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 402                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 403                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 404                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 405                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 406                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 407                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
 408                    (integer->list #x100000000000000000000000000000000))))
 409
 410 ;;
 411 ;; list->integer
 412 ;;
 413
 414 (with-test-prefix "list->integer"
 415   (pass-if (eqv? 6 (list->integer '(#t #t #f))))
 416   (pass-if (eqv? 6 (list->integer '(#f #t #t #f))))
 417   (pass-if (eqv? 2 (list->integer '(#t #f))))
 418
 419   (pass-if "leading #f's"
 420     (eqv? 1 (list->integer
 421              '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 422                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 423                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 424                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 425                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 426                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 427                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 428                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t))))
 429
 430   (pass-if (eqv? #x100000000000000000000000000000000
 431                  (list->integer
 432                   '(#t
 433                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 434                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 435                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 436                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 437                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 438                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 439                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 440                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))))
 441
 442   (pass-if (eqv? #x03FFFFFF (list->integer '(#t #t
 443                                                 #t #t #t #t #t #t #t #t
 444                                                 #t #t #t #t #t #t #t #t
 445                                                 #t #t #t #t #t #t #t #t))))
 446   (pass-if (eqv? #x07FFFFFF (list->integer '(#t #t #t
 447                                                 #t #t #t #t #t #t #t #t
 448                                                 #t #t #t #t #t #t #t #t
 449                                                 #t #t #t #t #t #t #t #t))))
 450   (pass-if (eqv? #x0FFFFFFF (list->integer '(#t #t #t #t
 451                                                 #t #t #t #t #t #t #t #t
 452                                                 #t #t #t #t #t #t #t #t
 453                                                 #t #t #t #t #t #t #t #t))))
 454   (pass-if (eqv? #x1FFFFFFF (list->integer '(#t #t #t #t #t
 455                                                 #t #t #t #t #t #t #t #t
 456                                                 #t #t #t #t #t #t #t #t
 457                                                 #t #t #t #t #t #t #t #t))))
 458   (pass-if (eqv? #x3FFFFFFF (list->integer '(#t #t #t #t #t #t
 459                                                 #t #t #t #t #t #t #t #t
 460                                                 #t #t #t #t #t #t #t #t
 461                                                 #t #t #t #t #t #t #t #t))))
 462   (pass-if (eqv? #x7FFFFFFF (list->integer '(#t #t #t #t #t #t #t
 463                                                 #t #t #t #t #t #t #t #t
 464                                                 #t #t #t #t #t #t #t #t
 465                                                 #t #t #t #t #t #t #t #t))))
 466   (pass-if (eqv? #xFFFFFFFF (list->integer '(#t #t #t #t #t #t #t #t
 467                                                 #t #t #t #t #t #t #t #t
 468                                                 #t #t #t #t #t #t #t #t
 469                                                 #t #t #t #t #t #t #t #t))))
 470   (pass-if (eqv? #x1FFFFFFFF (list->integer '(#t
 471                                               #t #t #t #t #t #t #t #t
 472                                               #t #t #t #t #t #t #t #t
 473                                               #t #t #t #t #t #t #t #t
 474                                               #t #t #t #t #t #t #t #t)))))
 475
 476 ;;
 477 ;; list->integer
 478 ;;
 479
 480 (with-test-prefix "list->integer"
 481   (pass-if (eqv? 0 (booleans->integer)))
 482   (pass-if (eqv? 6 (booleans->integer #t #t #f))))