guile18/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 program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program 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
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  18 ;;;; Boston, MA 02110-1301 USA
  19
  20 (define-module (test-srfi-60)
  21   #:duplicates (last)  ;; avoid warning about srfi-60 replacing `bit-count'
  22   #:use-module (test-suite lib)
  23   #:use-module (srfi srfi-60))
  24
  25
  26 (pass-if "cond-expand srfi-60"
  27   (cond-expand (srfi-60 #t)
  28                (else    #f)))
  29
  30 ;;
  31 ;; logand
  32 ;;
  33
  34 (with-test-prefix "logand"
  35   (pass-if (eqv? 6 (logand 14 6))))
  36
  37 ;;
  38 ;; bitwise-and
  39 ;;
  40
  41 (with-test-prefix "bitwise-and"
  42   (pass-if (eqv? 6 (bitwise-and 14 6))))
  43
  44 ;;
  45 ;; logior
  46 ;;
  47
  48 (with-test-prefix "logior"
  49   (pass-if (eqv? 14 (logior 10 12))))
  50
  51 ;;
  52 ;; bitwise-ior
  53 ;;
  54
  55 (with-test-prefix "bitwise-ior"
  56   (pass-if (eqv? 14 (bitwise-ior 10 12))))
  57
  58 ;;
  59 ;; logxor
  60 ;;
  61
  62 (with-test-prefix "logxor"
  63   (pass-if (eqv? 6 (logxor 10 12))))
  64
  65 ;;
  66 ;; bitwise-xor
  67 ;;
  68
  69 (with-test-prefix "bitwise-xor"
  70   (pass-if (eqv? 6 (bitwise-xor 10 12))))
  71
  72 ;;
  73 ;; lognot
  74 ;;
  75
  76 (with-test-prefix "lognot"
  77   (pass-if (eqv? -1 (lognot 0)))
  78   (pass-if (eqv? 0 (lognot -1))))
  79
  80 ;;
  81 ;; bitwise-not
  82 ;;
  83
  84 (with-test-prefix "bitwise-not"
  85   (pass-if (eqv? -1 (bitwise-not 0)))
  86   (pass-if (eqv? 0 (bitwise-not -1))))
  87
  88 ;;
  89 ;; bitwise-if
  90 ;;
  91
  92 (with-test-prefix "bitwise-if"
  93   (pass-if (eqv? 9 (bitwise-if 3 1 8)))
  94   (pass-if (eqv? 0 (bitwise-if 3 8 1))))
  95
  96 ;;
  97 ;; bitwise-merge
  98 ;;
  99
 100 (with-test-prefix "bitwise-merge"
 101   (pass-if (eqv? 9 (bitwise-merge 3 1 8)))
 102   (pass-if (eqv? 0 (bitwise-merge 3 8 1))))
 103
 104 ;;
 105 ;; logtest
 106 ;;
 107
 108 (with-test-prefix "logtest"
 109   (pass-if (eq? #t (logtest 3 6)))
 110   (pass-if (eq? #f (logtest 3 12))))
 111
 112 ;;
 113 ;; any-bits-set?
 114 ;;
 115
 116 (with-test-prefix "any-bits-set?"
 117   (pass-if (eq? #t (any-bits-set? 3 6)))
 118   (pass-if (eq? #f (any-bits-set? 3 12))))
 119
 120 ;;
 121 ;; logcount
 122 ;;
 123
 124 (with-test-prefix "logcount"
 125   (pass-if (eqv? 2 (logcount 12))))
 126
 127 ;;
 128 ;; bit-count
 129 ;;
 130
 131 (with-test-prefix "bit-count"
 132   (pass-if (eqv? 2 (bit-count 12))))
 133
 134 ;;
 135 ;; integer-length
 136 ;;
 137
 138 (with-test-prefix "integer-length"
 139   (pass-if (eqv? 0 (integer-length 0)))
 140   (pass-if (eqv? 8 (integer-length 128)))
 141   (pass-if (eqv? 8 (integer-length 255)))
 142   (pass-if (eqv? 9 (integer-length 256))))
 143
 144 ;;
 145 ;; log2-binary-factors
 146 ;;
 147
 148 (with-test-prefix "log2-binary-factors"
 149   (pass-if (eqv? -1 (log2-binary-factors 0)))
 150   (pass-if (eqv? 0 (log2-binary-factors 1)))
 151   (pass-if (eqv? 0 (log2-binary-factors 3)))
 152   (pass-if (eqv? 2 (log2-binary-factors 4)))
 153   (pass-if (eqv? 1 (log2-binary-factors 6)))
 154   (pass-if (eqv? 0 (log2-binary-factors -1)))
 155   (pass-if (eqv? 1 (log2-binary-factors -2)))
 156   (pass-if (eqv? 0 (log2-binary-factors -3)))
 157   (pass-if (eqv? 2 (log2-binary-factors -4)))
 158   (pass-if (eqv? 128 (log2-binary-factors #x100000000000000000000000000000000))))
 159
 160 ;;
 161 ;; first-set-bit
 162 ;;
 163
 164 (with-test-prefix "first-set-bit"
 165   (pass-if (eqv? -1 (first-set-bit 0)))
 166   (pass-if (eqv? 0 (first-set-bit 1)))
 167   (pass-if (eqv? 0 (first-set-bit 3)))
 168   (pass-if (eqv? 2 (first-set-bit 4)))
 169   (pass-if (eqv? 1 (first-set-bit 6)))
 170   (pass-if (eqv? 0 (first-set-bit -1)))
 171   (pass-if (eqv? 1 (first-set-bit -2)))
 172   (pass-if (eqv? 0 (first-set-bit -3)))
 173   (pass-if (eqv? 2 (first-set-bit -4))))
 174
 175 ;;
 176 ;; logbit?
 177 ;;
 178
 179 (with-test-prefix "logbit?"
 180   (pass-if (eq? #t (logbit? 0 1)))
 181   (pass-if (eq? #f (logbit? 1 1)))
 182   (pass-if (eq? #f (logbit? 1 8)))
 183   (pass-if (eq? #t (logbit? 1000 -1))))
 184
 185 ;;
 186 ;; bit-set?
 187 ;;
 188
 189 (with-test-prefix "bit-set?"
 190   (pass-if (eq? #t (bit-set? 0 1)))
 191   (pass-if (eq? #f (bit-set? 1 1)))
 192   (pass-if (eq? #f (bit-set? 1 8)))
 193   (pass-if (eq? #t (bit-set? 1000 -1))))
 194
 195 ;;
 196 ;; copy-bit
 197 ;;
 198
 199 (with-test-prefix "copy-bit"
 200   (pass-if (eqv? 0 (copy-bit 0 0 #f)))
 201   (pass-if (eqv? 0 (copy-bit 30 0 #f)))
 202   (pass-if (eqv? 0 (copy-bit 31 0 #f)))
 203   (pass-if (eqv? 0 (copy-bit 62 0 #f)))
 204   (pass-if (eqv? 0 (copy-bit 63 0 #f)))
 205   (pass-if (eqv? 0 (copy-bit 128 0 #f)))
 206
 207   (pass-if (eqv? -1 (copy-bit 0 -1 #t)))
 208   (pass-if (eqv? -1 (copy-bit 30 -1 #t)))
 209   (pass-if (eqv? -1 (copy-bit 31 -1 #t)))
 210   (pass-if (eqv? -1 (copy-bit 62 -1 #t)))
 211   (pass-if (eqv? -1 (copy-bit 63 -1 #t)))
 212   (pass-if (eqv? -1 (copy-bit 128 -1 #t)))
 213
 214   (pass-if (eqv? 1 (copy-bit 0 0 #t)))
 215   (pass-if (eqv? #x106 (copy-bit 8 6 #t)))
 216   (pass-if (eqv? 6 (copy-bit 8 6 #f)))
 217   (pass-if (eqv? -2 (copy-bit 0 -1 #f)))
 218
 219   (pass-if "bignum becomes inum"
 220     (eqv? 0 (copy-bit 128 #x100000000000000000000000000000000 #f)))
 221
 222   ;; bignums unchanged
 223   (pass-if (eqv? #x100000000000000000000000000000000
 224                  (copy-bit 128 #x100000000000000000000000000000000 #t)))
 225   (pass-if (eqv? #x100000000000000000000000000000000
 226                  (copy-bit 64 #x100000000000000000000000000000000 #f)))
 227   (pass-if (eqv? #x-100000000000000000000000000000000
 228                  (copy-bit 64 #x-100000000000000000000000000000000 #f)))
 229   (pass-if (eqv? #x-100000000000000000000000000000000
 230                  (copy-bit 256 #x-100000000000000000000000000000000 #t))))
 231
 232 ;;
 233 ;; bit-field
 234 ;;
 235
 236 (with-test-prefix "bit-field"
 237   (pass-if (eqv? 0 (bit-field 6 0 1)))
 238   (pass-if (eqv? 3 (bit-field 6 1 3)))
 239   (pass-if (eqv? 1 (bit-field 6 2 999)))
 240   (pass-if (eqv? 1 (bit-field #x100000000000000000000000000000000 128 129))))
 241
 242 ;;
 243 ;; copy-bit-field
 244 ;;
 245
 246 (with-test-prefix "copy-bit-field"
 247   (pass-if (eqv? #b111 (copy-bit-field #b110 1 0 1)))
 248   (pass-if (eqv? #b110 (copy-bit-field #b110 1 1 2)))
 249   (pass-if (eqv? #b010 (copy-bit-field #b110 1 1 3))))
 250
 251 ;;
 252 ;; ash
 253 ;;
 254
 255 (with-test-prefix "ash"
 256   (pass-if (eqv? 2 (ash 1 1)))
 257   (pass-if (eqv? 0 (ash 1 -1))))
 258
 259 ;;
 260 ;; arithmetic-shift
 261 ;;
 262
 263 (with-test-prefix "arithmetic-shift"
 264   (pass-if (eqv? 2 (arithmetic-shift 1 1)))
 265   (pass-if (eqv? 0 (arithmetic-shift 1 -1))))
 266
 267 ;;
 268 ;; rotate-bit-field
 269 ;;
 270
 271 (with-test-prefix "rotate-bit-field"
 272   (pass-if (eqv? #b110  (rotate-bit-field #b110 1 1 2)))
 273   (pass-if (eqv? #b1010 (rotate-bit-field #b110 1 2 4)))
 274   (pass-if (eqv? #b1011 (rotate-bit-field #b0111 -1 1 4)))
 275
 276   (pass-if (eqv? #b0  (rotate-bit-field #b0 128 0 256)))
 277   (pass-if (eqv? #b1  (rotate-bit-field #b1 128 1 256)))
 278   (pass-if
 279       (eqv? #x100000000000000000000000000000000
 280             (rotate-bit-field #x100000000000000000000000000000000 128 0 64)))
 281   (pass-if
 282       (eqv? #x100000000000000000000000000000008
 283             (rotate-bit-field #x100000000000000000000000000000001 3 0 64)))
 284   (pass-if
 285       (eqv? #x100000000000000002000000000000000
 286             (rotate-bit-field #x100000000000000000000000000000001 -3 0 64)))
 287
 288   (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 10)))
 289   (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 256)))
 290
 291   (pass-if "bignum becomes inum"
 292     (eqv? 1 (rotate-bit-field #x100000000000000000000000000000000 1 0 129))))
 293
 294 ;;
 295 ;; reverse-bit-field
 296 ;;
 297
 298 (with-test-prefix "reverse-bit-field"
 299   (pass-if (eqv? 6 (reverse-bit-field 6 1 3)))
 300   (pass-if (eqv? 12 (reverse-bit-field 6 1 4)))
 301
 302   (pass-if (eqv? #x80000000 (reverse-bit-field 1 0 32)))
 303   (pass-if (eqv? #x40000000 (reverse-bit-field 1 0 31)))
 304   (pass-if (eqv? #x20000000 (reverse-bit-field 1 0 30)))
 305
 306   (pass-if (eqv? (logior (ash -1 32) #xFBFFFFFF)
 307                  (reverse-bit-field -2 0 27)))
 308   (pass-if (eqv? (logior (ash -1 32) #xF7FFFFFF)
 309                  (reverse-bit-field -2 0 28)))
 310   (pass-if (eqv? (logior (ash -1 32) #xEFFFFFFF)
 311                  (reverse-bit-field -2 0 29)))
 312   (pass-if (eqv? (logior (ash -1 32) #xDFFFFFFF)
 313                  (reverse-bit-field -2 0 30)))
 314   (pass-if (eqv? (logior (ash -1 32) #xBFFFFFFF)
 315                  (reverse-bit-field -2 0 31)))
 316   (pass-if (eqv? (logior (ash -1 32) #x7FFFFFFF)
 317                  (reverse-bit-field -2 0 32)))
 318
 319   (pass-if "bignum becomes inum"
 320     (eqv? 5 (reverse-bit-field #x140000000000000000000000000000000 0 129))))
 321
 322 ;;
 323 ;; integer->list
 324 ;;
 325
 326 (with-test-prefix "integer->list"
 327   (pass-if (equal? '(#t #t #f) (integer->list 6)))
 328   (pass-if (equal? '(#f #t #t #f) (integer->list 6 4)))
 329   (pass-if (equal? '(#t #f) (integer->list 6 2)))
 330
 331   (pass-if "zeros above top of positive inum"
 332     (equal? '(#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 #f
 339                  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
 340             (integer->list 1 128)))
 341
 342   (pass-if "ones above top of negative inum"
 343     (equal? '(#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                  #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)
 351             (integer->list -1 128)))
 352
 353   (pass-if (equal? '(#t
 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                      #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
 362                    (integer->list #x100000000000000000000000000000000))))
 363
 364 ;;
 365 ;; list->integer
 366 ;;
 367
 368 (with-test-prefix "list->integer"
 369   (pass-if (eqv? 6 (list->integer '(#t #t #f))))
 370   (pass-if (eqv? 6 (list->integer '(#f #t #t #f))))
 371   (pass-if (eqv? 2 (list->integer '(#t #f))))
 372
 373   (pass-if "leading #f's"
 374     (eqv? 1 (list->integer
 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 #f
 382                   #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t))))
 383
 384   (pass-if (eqv? #x100000000000000000000000000000000
 385                  (list->integer
 386                   '(#t
 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                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))))
 395
 396   (pass-if (eqv? #x03FFFFFF (list->integer '(#t #t
 397                                                 #t #t #t #t #t #t #t #t
 398                                                 #t #t #t #t #t #t #t #t
 399                                                 #t #t #t #t #t #t #t #t))))
 400   (pass-if (eqv? #x07FFFFFF (list->integer '(#t #t #t
 401                                                 #t #t #t #t #t #t #t #t
 402                                                 #t #t #t #t #t #t #t #t
 403                                                 #t #t #t #t #t #t #t #t))))
 404   (pass-if (eqv? #x0FFFFFFF (list->integer '(#t #t #t #t
 405                                                 #t #t #t #t #t #t #t #t
 406                                                 #t #t #t #t #t #t #t #t
 407                                                 #t #t #t #t #t #t #t #t))))
 408   (pass-if (eqv? #x1FFFFFFF (list->integer '(#t #t #t #t #t
 409                                                 #t #t #t #t #t #t #t #t
 410                                                 #t #t #t #t #t #t #t #t
 411                                                 #t #t #t #t #t #t #t #t))))
 412   (pass-if (eqv? #x3FFFFFFF (list->integer '(#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                                                 #t #t #t #t #t #t #t #t))))
 416   (pass-if (eqv? #x7FFFFFFF (list->integer '(#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                                                 #t #t #t #t #t #t #t #t))))
 420   (pass-if (eqv? #xFFFFFFFF (list->integer '(#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                                                 #t #t #t #t #t #t #t #t))))
 424   (pass-if (eqv? #x1FFFFFFFF (list->integer '(#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                                               #t #t #t #t #t #t #t #t)))))
 429
 430 ;;
 431 ;; list->integer
 432 ;;
 433
 434 (with-test-prefix "list->integer"
 435   (pass-if (eqv? 0 (booleans->integer)))
 436   (pass-if (eqv? 6 (booleans->integer #t #t #f))))