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   (pass-if (eqv? #b110  (rotate-bit-field #b110 1 1 2)))
 272   (pass-if (eqv? #b1010 (rotate-bit-field #b110 1 2 4)))
 273   (pass-if (eqv? #b1011 (rotate-bit-field #b0111 -1 1 4)))
 274
 275   (pass-if (eqv? #b0  (rotate-bit-field #b0 128 0 256)))
 276   (pass-if (eqv? #b1  (rotate-bit-field #b1 128 1 256)))
 277   (pass-if
 278       (eqv? #x100000000000000000000000000000000
 279             (rotate-bit-field #x100000000000000000000000000000000 128 0 64)))
 280   (pass-if
 281       (eqv? #x100000000000000000000000000000008
 282             (rotate-bit-field #x100000000000000000000000000000001 3 0 64)))
 283   (pass-if
 284       (eqv? #x100000000000000002000000000000000
 285             (rotate-bit-field #x100000000000000000000000000000001 -3 0 64)))
 286
 287   (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 10)))
 288   (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 256)))
 289
 290   (pass-if "bignum becomes inum"
 291     (eqv? 1 (rotate-bit-field #x100000000000000000000000000000000 1 0 129))))
 292
 293 ;;
 294 ;; reverse-bit-field
 295 ;;
 296
 297 (with-test-prefix "reverse-bit-field"
 298   (pass-if (eqv? 6 (reverse-bit-field 6 1 3)))
 299   (pass-if (eqv? 12 (reverse-bit-field 6 1 4)))
 300
 301   (pass-if (eqv? #x80000000 (reverse-bit-field 1 0 32)))
 302   (pass-if (eqv? #x40000000 (reverse-bit-field 1 0 31)))
 303   (pass-if (eqv? #x20000000 (reverse-bit-field 1 0 30)))
 304
 305   (pass-if (eqv? (logior (ash -1 32) #xFBFFFFFF)
 306                  (reverse-bit-field -2 0 27)))
 307   (pass-if (eqv? (logior (ash -1 32) #xF7FFFFFF)
 308                  (reverse-bit-field -2 0 28)))
 309   (pass-if (eqv? (logior (ash -1 32) #xEFFFFFFF)
 310                  (reverse-bit-field -2 0 29)))
 311   (pass-if (eqv? (logior (ash -1 32) #xDFFFFFFF)
 312                  (reverse-bit-field -2 0 30)))
 313   (pass-if (eqv? (logior (ash -1 32) #xBFFFFFFF)
 314                  (reverse-bit-field -2 0 31)))
 315   (pass-if (eqv? (logior (ash -1 32) #x7FFFFFFF)
 316                  (reverse-bit-field -2 0 32)))
 317
 318   (pass-if "bignum becomes inum"
 319     (eqv? 5 (reverse-bit-field #x140000000000000000000000000000000 0 129))))
 320
 321 ;;
 322 ;; integer->list
 323 ;;
 324
 325 (with-test-prefix "integer->list"
 326   (pass-if (equal? '(#t #t #f) (integer->list 6)))
 327   (pass-if (equal? '(#f #t #t #f) (integer->list 6 4)))
 328   (pass-if (equal? '(#t #f) (integer->list 6 2)))
 329
 330   (pass-if "zeros above top of positive inum"
 331     (equal? '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 332                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 333                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 334                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 335                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 336                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 337                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 338                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
 339             (integer->list 1 128)))
 340
 341   (pass-if "ones above top of negative inum"
 342     (equal? '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 343                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 344                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 345                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 346                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 347                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 348                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
 349                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)
 350             (integer->list -1 128)))
 351
 352   (pass-if (equal? '(#t
 353                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 354                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 355                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 356                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 357                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 358                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 359                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 360                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
 361                    (integer->list #x100000000000000000000000000000000))))
 362
 363 ;;
 364 ;; list->integer
 365 ;;
 366
 367 (with-test-prefix "list->integer"
 368   (pass-if (eqv? 6 (list->integer '(#t #t #f))))
 369   (pass-if (eqv? 6 (list->integer '(#f #t #t #f))))
 370   (pass-if (eqv? 2 (list->integer '(#t #f))))
 371
 372   (pass-if "leading #f's"
 373     (eqv? 1 (list->integer
 374              '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 375                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 376                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 377                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 378                   #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 #t))))
 382
 383   (pass-if (eqv? #x100000000000000000000000000000000
 384                  (list->integer
 385                   '(#t
 386                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 387                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 388                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 389                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 390                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 391                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 392                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
 393                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))))
 394
 395   (pass-if (eqv? #x03FFFFFF (list->integer '(#t #t
 396                                                 #t #t #t #t #t #t #t #t
 397                                                 #t #t #t #t #t #t #t #t
 398                                                 #t #t #t #t #t #t #t #t))))
 399   (pass-if (eqv? #x07FFFFFF (list->integer '(#t #t #t
 400                                                 #t #t #t #t #t #t #t #t
 401                                                 #t #t #t #t #t #t #t #t
 402                                                 #t #t #t #t #t #t #t #t))))
 403   (pass-if (eqv? #x0FFFFFFF (list->integer '(#t #t #t #t
 404                                                 #t #t #t #t #t #t #t #t
 405                                                 #t #t #t #t #t #t #t #t
 406                                                 #t #t #t #t #t #t #t #t))))
 407   (pass-if (eqv? #x1FFFFFFF (list->integer '(#t #t #t #t #t
 408                                                 #t #t #t #t #t #t #t #t
 409                                                 #t #t #t #t #t #t #t #t
 410                                                 #t #t #t #t #t #t #t #t))))
 411   (pass-if (eqv? #x3FFFFFFF (list->integer '(#t #t #t #t #t #t
 412                                                 #t #t #t #t #t #t #t #t
 413                                                 #t #t #t #t #t #t #t #t
 414                                                 #t #t #t #t #t #t #t #t))))
 415   (pass-if (eqv? #x7FFFFFFF (list->integer '(#t #t #t #t #t #t #t
 416                                                 #t #t #t #t #t #t #t #t
 417                                                 #t #t #t #t #t #t #t #t
 418                                                 #t #t #t #t #t #t #t #t))))
 419   (pass-if (eqv? #xFFFFFFFF (list->integer '(#t #t #t #t #t #t #t #t
 420                                                 #t #t #t #t #t #t #t #t
 421                                                 #t #t #t #t #t #t #t #t
 422                                                 #t #t #t #t #t #t #t #t))))
 423   (pass-if (eqv? #x1FFFFFFFF (list->integer '(#t
 424                                               #t #t #t #t #t #t #t #t
 425                                               #t #t #t #t #t #t #t #t
 426                                               #t #t #t #t #t #t #t #t
 427                                               #t #t #t #t #t #t #t #t)))))
 428
 429 ;;
 430 ;; list->integer
 431 ;;
 432
 433 (with-test-prefix "list->integer"
 434   (pass-if (eqv? 0 (booleans->integer)))
 435   (pass-if (eqv? 6 (booleans->integer #t #t #f))))