guile/test-suite/tests/srfi-60.test

;;;; srfi-60.test --- Test suite for Guile's SRFI-60 functions. -*- scheme -*-
;;;;
;;;; Copyright 2005, 2006 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-srfi-60)
  #:duplicates (last)  ;; avoid warning about srfi-60 replacing `bit-count'
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-60))


(pass-if "cond-expand srfi-60"
  (cond-expand (srfi-60 #t)
	       (else    #f)))

;;
;; logand
;;

(with-test-prefix "logand"
  (pass-if (eqv? 6 (logand 14 6))))

;;
;; bitwise-and
;;

(with-test-prefix "bitwise-and"
  (pass-if (eqv? 6 (bitwise-and 14 6))))

;;
;; logior
;;

(with-test-prefix "logior"
  (pass-if (eqv? 14 (logior 10 12))))

;;
;; bitwise-ior
;;

(with-test-prefix "bitwise-ior"
  (pass-if (eqv? 14 (bitwise-ior 10 12))))

;;
;; logxor
;;

(with-test-prefix "logxor"
  (pass-if (eqv? 6 (logxor 10 12))))

;;
;; bitwise-xor
;;

(with-test-prefix "bitwise-xor"
  (pass-if (eqv? 6 (bitwise-xor 10 12))))

;;
;; lognot
;;

(with-test-prefix "lognot"
  (pass-if (eqv? -1 (lognot 0)))
  (pass-if (eqv? 0 (lognot -1))))

;;
;; bitwise-not
;;

(with-test-prefix "bitwise-not"
  (pass-if (eqv? -1 (bitwise-not 0)))
  (pass-if (eqv? 0 (bitwise-not -1))))

;;
;; bitwise-if
;;

(with-test-prefix "bitwise-if"
  (pass-if (eqv? 9 (bitwise-if 3 1 8)))
  (pass-if (eqv? 0 (bitwise-if 3 8 1))))

;;
;; bitwise-merge
;;

(with-test-prefix "bitwise-merge"
  (pass-if (eqv? 9 (bitwise-merge 3 1 8)))
  (pass-if (eqv? 0 (bitwise-merge 3 8 1))))

;;
;; logtest
;;

(with-test-prefix "logtest"
  (pass-if (eq? #t (logtest 3 6)))
  (pass-if (eq? #f (logtest 3 12))))

;;
;; any-bits-set?
;;

(with-test-prefix "any-bits-set?"
  (pass-if (eq? #t (any-bits-set? 3 6)))
  (pass-if (eq? #f (any-bits-set? 3 12))))

;;
;; logcount
;;

(with-test-prefix "logcount"
  (pass-if (eqv? 2 (logcount 12))))

;;
;; bit-count
;;

(with-test-prefix "bit-count"
  (pass-if (eqv? 2 (bit-count 12))))

;;
;; integer-length
;;

(with-test-prefix "integer-length"
  (pass-if (eqv? 0 (integer-length 0)))
  (pass-if (eqv? 8 (integer-length 128)))
  (pass-if (eqv? 8 (integer-length 255)))
  (pass-if (eqv? 9 (integer-length 256))))

;;
;; log2-binary-factors
;;

(with-test-prefix "log2-binary-factors"
  (pass-if (eqv? -1 (log2-binary-factors 0)))
  (pass-if (eqv? 0 (log2-binary-factors 1)))
  (pass-if (eqv? 0 (log2-binary-factors 3)))
  (pass-if (eqv? 2 (log2-binary-factors 4)))
  (pass-if (eqv? 1 (log2-binary-factors 6)))
  (pass-if (eqv? 0 (log2-binary-factors -1)))
  (pass-if (eqv? 1 (log2-binary-factors -2)))
  (pass-if (eqv? 0 (log2-binary-factors -3)))
  (pass-if (eqv? 2 (log2-binary-factors -4)))
  (pass-if (eqv? 128 (log2-binary-factors #x100000000000000000000000000000000))))

;;
;; first-set-bit
;;

(with-test-prefix "first-set-bit"
  (pass-if (eqv? -1 (first-set-bit 0)))
  (pass-if (eqv? 0 (first-set-bit 1)))
  (pass-if (eqv? 0 (first-set-bit 3)))
  (pass-if (eqv? 2 (first-set-bit 4)))
  (pass-if (eqv? 1 (first-set-bit 6)))
  (pass-if (eqv? 0 (first-set-bit -1)))
  (pass-if (eqv? 1 (first-set-bit -2)))
  (pass-if (eqv? 0 (first-set-bit -3)))
  (pass-if (eqv? 2 (first-set-bit -4))))

;;
;; logbit?
;;

(with-test-prefix "logbit?"
  (pass-if (eq? #t (logbit? 0 1)))
  (pass-if (eq? #f (logbit? 1 1)))
  (pass-if (eq? #f (logbit? 1 8)))
  (pass-if (eq? #t (logbit? 1000 -1))))

;;
;; bit-set?
;;

(with-test-prefix "bit-set?"
  (pass-if (eq? #t (bit-set? 0 1)))
  (pass-if (eq? #f (bit-set? 1 1)))
  (pass-if (eq? #f (bit-set? 1 8)))
  (pass-if (eq? #t (bit-set? 1000 -1))))

;;
;; copy-bit
;;

(with-test-prefix "copy-bit"
  (pass-if (eqv? 0 (copy-bit 0 0 #f)))
  (pass-if (eqv? 0 (copy-bit 30 0 #f)))
  (pass-if (eqv? 0 (copy-bit 31 0 #f)))
  (pass-if (eqv? 0 (copy-bit 62 0 #f)))
  (pass-if (eqv? 0 (copy-bit 63 0 #f)))
  (pass-if (eqv? 0 (copy-bit 128 0 #f)))

  (pass-if (eqv? -1 (copy-bit 0 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 30 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 31 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 62 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 63 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 128 -1 #t)))

  (pass-if (eqv? 1 (copy-bit 0 0 #t)))
  (pass-if (eqv? #x106 (copy-bit 8 6 #t)))
  (pass-if (eqv? 6 (copy-bit 8 6 #f)))
  (pass-if (eqv? -2 (copy-bit 0 -1 #f)))

  (pass-if "bignum becomes inum"
    (eqv? 0 (copy-bit 128 #x100000000000000000000000000000000 #f)))

  ;; bignums unchanged
  (pass-if (eqv? #x100000000000000000000000000000000
		 (copy-bit 128 #x100000000000000000000000000000000 #t)))
  (pass-if (eqv? #x100000000000000000000000000000000
		 (copy-bit 64 #x100000000000000000000000000000000 #f)))
  (pass-if (eqv? #x-100000000000000000000000000000000
		 (copy-bit 64 #x-100000000000000000000000000000000 #f)))
  (pass-if (eqv? #x-100000000000000000000000000000000
		 (copy-bit 256 #x-100000000000000000000000000000000 #t))))

;;
;; bit-field
;;

(with-test-prefix "bit-field"
  (pass-if (eqv? 0 (bit-field 6 0 1)))
  (pass-if (eqv? 3 (bit-field 6 1 3)))
  (pass-if (eqv? 1 (bit-field 6 2 999)))
  (pass-if (eqv? 1 (bit-field #x100000000000000000000000000000000 128 129))))

;;
;; copy-bit-field
;;

(with-test-prefix "copy-bit-field"
  (pass-if (eqv? #b111 (copy-bit-field #b110 1 0 1)))
  (pass-if (eqv? #b110 (copy-bit-field #b110 1 1 2)))
  (pass-if (eqv? #b010 (copy-bit-field #b110 1 1 3))))

;;
;; ash
;;

(with-test-prefix "ash"
  (pass-if (eqv? 2 (ash 1 1)))
  (pass-if (eqv? 0 (ash 1 -1))))

;;
;; arithmetic-shift
;;

(with-test-prefix "arithmetic-shift"
  (pass-if (eqv? 2 (arithmetic-shift 1 1)))
  (pass-if (eqv? 0 (arithmetic-shift 1 -1))))

;;
;; rotate-bit-field
;;

(with-test-prefix "rotate-bit-field"
  (pass-if (eqv? #b110  (rotate-bit-field #b110 1 1 2)))
  (pass-if (eqv? #b1010 (rotate-bit-field #b110 1 2 4)))
  (pass-if (eqv? #b1011 (rotate-bit-field #b0111 -1 1 4)))

  (pass-if (eqv? #b0  (rotate-bit-field #b0 128 0 256)))
  (pass-if (eqv? #b1  (rotate-bit-field #b1 128 1 256)))
  (pass-if
      (eqv? #x100000000000000000000000000000000
	    (rotate-bit-field #x100000000000000000000000000000000 128 0 64)))
  (pass-if
      (eqv? #x100000000000000000000000000000008
	    (rotate-bit-field #x100000000000000000000000000000001 3 0 64)))
  (pass-if
      (eqv? #x100000000000000002000000000000000
	    (rotate-bit-field #x100000000000000000000000000000001 -3 0 64)))

  (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 10)))
  (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 256)))

  (pass-if "bignum becomes inum"
    (eqv? 1 (rotate-bit-field #x100000000000000000000000000000000 1 0 129))))

;;
;; reverse-bit-field
;;

(with-test-prefix "reverse-bit-field"
  (pass-if (eqv? 6 (reverse-bit-field 6 1 3)))
  (pass-if (eqv? 12 (reverse-bit-field 6 1 4)))

  (pass-if (eqv? #x80000000 (reverse-bit-field 1 0 32)))
  (pass-if (eqv? #x40000000 (reverse-bit-field 1 0 31)))
  (pass-if (eqv? #x20000000 (reverse-bit-field 1 0 30)))

  (pass-if (eqv? (logior (ash -1 32) #xFBFFFFFF)
		 (reverse-bit-field -2 0 27)))
  (pass-if (eqv? (logior (ash -1 32) #xF7FFFFFF)
		 (reverse-bit-field -2 0 28)))
  (pass-if (eqv? (logior (ash -1 32) #xEFFFFFFF)
		 (reverse-bit-field -2 0 29)))
  (pass-if (eqv? (logior (ash -1 32) #xDFFFFFFF)
		 (reverse-bit-field -2 0 30)))
  (pass-if (eqv? (logior (ash -1 32) #xBFFFFFFF)
		 (reverse-bit-field -2 0 31)))
  (pass-if (eqv? (logior (ash -1 32) #x7FFFFFFF)
		 (reverse-bit-field -2 0 32)))

  (pass-if "bignum becomes inum"
    (eqv? 5 (reverse-bit-field #x140000000000000000000000000000000 0 129))))

;;
;; integer->list
;;

(with-test-prefix "integer->list"
  (pass-if (equal? '(#t #t #f) (integer->list 6)))
  (pass-if (equal? '(#f #t #t #f) (integer->list 6 4)))
  (pass-if (equal? '(#t #f) (integer->list 6 2)))

  (pass-if "zeros above top of positive inum"
    (equal? '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
	    (integer->list 1 128)))

  (pass-if "ones above top of negative inum"
    (equal? '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)
	    (integer->list -1 128)))

  (pass-if (equal? '(#t
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
		   (integer->list #x100000000000000000000000000000000))))

;;
;; list->integer
;;

(with-test-prefix "list->integer"
  (pass-if (eqv? 6 (list->integer '(#t #t #f))))
  (pass-if (eqv? 6 (list->integer '(#f #t #t #f))))
  (pass-if (eqv? 2 (list->integer '(#t #f))))

  (pass-if "leading #f's"
    (eqv? 1 (list->integer
	     '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t))))

  (pass-if (eqv? #x100000000000000000000000000000000
		 (list->integer
		  '(#t
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))))

  (pass-if (eqv? #x03FFFFFF (list->integer '(#t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x07FFFFFF (list->integer '(#t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x0FFFFFFF (list->integer '(#t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x1FFFFFFF (list->integer '(#t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x3FFFFFFF (list->integer '(#t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x7FFFFFFF (list->integer '(#t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #xFFFFFFFF (list->integer '(#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x1FFFFFFFF (list->integer '(#t
					      #t #t #t #t #t #t #t #t
					      #t #t #t #t #t #t #t #t
					      #t #t #t #t #t #t #t #t
					      #t #t #t #t #t #t #t #t)))))

;;
;; list->integer
;;

(with-test-prefix "list->integer"
  (pass-if (eqv? 0 (booleans->integer)))
  (pass-if (eqv? 6 (booleans->integer #t #t #f))))