code:
;;;; unif.test --- tests guile's uniform arrays     -*- scheme -*-
;;;;
;;;; Copyright 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-arrays)
  #:use-module ((system base compile) #:select (compile))
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-4 gnu))

;;;
;;; array?
;;;

(define exception:wrong-num-indices
  (cons 'misc-error "^wrong number of indices.*"))

(define exception:length-non-negative
  (cons 'read-error ".*array length must be non-negative.*"))

(with-test-prefix "sanity"
  ;; At the current time of writing, bignums have a tc7 that is one bit
  ;; away from strings. It used to be that the vector implementation
  ;; registered for strings had the TYP7S mask, not the TYP7 mask,
  ;; making the system think that bignums were vectors. Doh!
  (pass-if (not (uniform-vector? 12345678901234567890123456789))))

(with-test-prefix "array?"

  (let ((bool     (make-typed-array 'b    #t  '(5 6)))
	(char     (make-typed-array 'a    #\a '(5 6)))
	(byte     (make-typed-array 'u8   0   '(5 6)))
	(short    (make-typed-array 's16  0   '(5 6)))
	(ulong    (make-typed-array 'u32  0   '(5 6)))
	(long     (make-typed-array 's32  0   '(5 6)))
	(longlong (make-typed-array 's64  0   '(5 6)))
	(float    (make-typed-array 'f32  0   '(5 6)))
	(double   (make-typed-array 'f64  0   '(5 6)))
	(complex  (make-typed-array 'c64  0   '(5 6)))
	(scm      (make-typed-array #t    0   '(5 6))))

    (with-test-prefix "is bool"
      (pass-if (eq? #t (typed-array? bool     'b)))
      (pass-if (eq? #f (typed-array? char     'b)))
      (pass-if (eq? #f (typed-array? byte     'b)))
      (pass-if (eq? #f (typed-array? short    'b)))
      (pass-if (eq? #f (typed-array? ulong    'b)))
      (pass-if (eq? #f (typed-array? long     'b)))
      (pass-if (eq? #f (typed-array? longlong 'b)))
      (pass-if (eq? #f (typed-array? float    'b)))
      (pass-if (eq? #f (typed-array? double   'b)))
      (pass-if (eq? #f (typed-array? complex  'b)))
      (pass-if (eq? #f (typed-array? scm      'b))))

    (with-test-prefix "is char"
      (pass-if (eq? #f (typed-array? bool     'a)))
      (pass-if (eq? #t (typed-array? char     'a)))
      (pass-if (eq? #f (typed-array? byte     'a)))
      (pass-if (eq? #f (typed-array? short    'a)))
      (pass-if (eq? #f (typed-array? ulong    'a)))
      (pass-if (eq? #f (typed-array? long     'a)))
      (pass-if (eq? #f (typed-array? longlong 'a)))
      (pass-if (eq? #f (typed-array? float    'a)))
      (pass-if (eq? #f (typed-array? double   'a)))
      (pass-if (eq? #f (typed-array? complex  'a)))
      (pass-if (eq? #f (typed-array? scm      'a))))

    (with-test-prefix "is byte"
      (pass-if (eq? #f (typed-array? bool     'u8)))
      (pass-if (eq? #f (typed-array? char     'u8)))
      (pass-if (eq? #t (typed-array? byte     'u8)))
      (pass-if (eq? #f (typed-array? short    'u8)))
      (pass-if (eq? #f (typed-array? ulong    'u8)))
      (pass-if (eq? #f (typed-array? long     'u8)))
      (pass-if (eq? #f (typed-array? longlong 'u8)))
      (pass-if (eq? #f (typed-array? float    'u8)))
      (pass-if (eq? #f (typed-array? double   'u8)))
      (pass-if (eq? #f (typed-array? complex  'u8)))
      (pass-if (eq? #f (typed-array? scm      'u8))))

    (with-test-prefix "is short"
      (pass-if (eq? #f (typed-array? bool     's16)))
      (pass-if (eq? #f (typed-array? char     's16)))
      (pass-if (eq? #f (typed-array? byte     's16)))
      (pass-if (eq? #t (typed-array? short    's16)))
      (pass-if (eq? #f (typed-array? ulong    's16)))
      (pass-if (eq? #f (typed-array? long     's16)))
      (pass-if (eq? #f (typed-array? longlong 's16)))
      (pass-if (eq? #f (typed-array? float    's16)))
      (pass-if (eq? #f (typed-array? double   's16)))
      (pass-if (eq? #f (typed-array? complex  's16)))
      (pass-if (eq? #f (typed-array? scm      's16))))

    (with-test-prefix "is ulong"
      (pass-if (eq? #f (typed-array? bool     'u32)))
      (pass-if (eq? #f (typed-array? char     'u32)))
      (pass-if (eq? #f (typed-array? byte     'u32)))
      (pass-if (eq? #f (typed-array? short    'u32)))
      (pass-if (eq? #t (typed-array? ulong    'u32)))
      (pass-if (eq? #f (typed-array? long     'u32)))
      (pass-if (eq? #f (typed-array? longlong 'u32)))
      (pass-if (eq? #f (typed-array? float    'u32)))
      (pass-if (eq? #f (typed-array? double   'u32)))
      (pass-if (eq? #f (typed-array? complex  'u32)))
      (pass-if (eq? #f (typed-array? scm      'u32))))

    (with-test-prefix "is long"
      (pass-if (eq? #f (typed-array? bool     's32)))
      (pass-if (eq? #f (typed-array? char     's32)))
      (pass-if (eq? #f (typed-array? byte     's32)))
      (pass-if (eq? #f (typed-array? short    's32)))
      (pass-if (eq? #f (typed-array? ulong    's32)))
      (pass-if (eq? #t (typed-array? long     's32)))
      (pass-if (eq? #f (typed-array? longlong 's32)))
      (pass-if (eq? #f (typed-array? float    's32)))
      (pass-if (eq? #f (typed-array? double   's32)))
      (pass-if (eq? #f (typed-array? complex  's32)))
      (pass-if (eq? #f (typed-array? scm      's32))))

    (with-test-prefix "is long long"
      (pass-if (eq? #f (typed-array? bool     's64)))
      (pass-if (eq? #f (typed-array? char     's64)))
      (pass-if (eq? #f (typed-array? byte     's64)))
      (pass-if (eq? #f (typed-array? short    's64)))
      (pass-if (eq? #f (typed-array? ulong    's64)))
      (pass-if (eq? #f (typed-array? long     's64)))
      (pass-if (eq? #t (typed-array? longlong 's64)))
      (pass-if (eq? #f (typed-array? float    's64)))
      (pass-if (eq? #f (typed-array? double   's64)))
      (pass-if (eq? #f (typed-array? complex  's64)))
      (pass-if (eq? #f (typed-array? scm      's64))))

    (with-test-prefix "is float"
      (pass-if (eq? #f (typed-array? bool     'f32)))
      (pass-if (eq? #f (typed-array? char     'f32)))
      (pass-if (eq? #f (typed-array? byte     'f32)))
      (pass-if (eq? #f (typed-array? short    'f32)))
      (pass-if (eq? #f (typed-array? ulong    'f32)))
      (pass-if (eq? #f (typed-array? long     'f32)))
      (pass-if (eq? #f (typed-array? longlong 'f32)))
      (pass-if (eq? #t (typed-array? float    'f32)))
      (pass-if (eq? #f (typed-array? double   'f32)))
      (pass-if (eq? #f (typed-array? complex  'f32)))
      (pass-if (eq? #f (typed-array? scm      'f32))))

    (with-test-prefix "is double"
      (pass-if (eq? #f (typed-array? bool     'f64)))
      (pass-if (eq? #f (typed-array? char     'f64)))
      (pass-if (eq? #f (typed-array? byte     'f64)))
      (pass-if (eq? #f (typed-array? short    'f64)))
      (pass-if (eq? #f (typed-array? ulong    'f64)))
      (pass-if (eq? #f (typed-array? long     'f64)))
      (pass-if (eq? #f (typed-array? longlong 'f64)))
      (pass-if (eq? #f (typed-array? float    'f64)))
      (pass-if (eq? #t (typed-array? double   'f64)))
      (pass-if (eq? #f (typed-array? complex  'f64)))
      (pass-if (eq? #f (typed-array? scm      'f64))))

    (with-test-prefix "is complex"
      (pass-if (eq? #f (typed-array? bool     'c64)))
      (pass-if (eq? #f (typed-array? char     'c64)))
      (pass-if (eq? #f (typed-array? byte     'c64)))
      (pass-if (eq? #f (typed-array? short    'c64)))
      (pass-if (eq? #f (typed-array? ulong    'c64)))
      (pass-if (eq? #f (typed-array? long     'c64)))
      (pass-if (eq? #f (typed-array? longlong 'c64)))
      (pass-if (eq? #f (typed-array? float    'c64)))
      (pass-if (eq? #f (typed-array? double   'c64)))
      (pass-if (eq? #t (typed-array? complex  'c64)))
      (pass-if (eq? #f (typed-array? scm      'c64))))

    (with-test-prefix "is scm"
      (pass-if (eq? #f (typed-array? bool     #t)))
      (pass-if (eq? #f (typed-array? char     #t)))
      (pass-if (eq? #f (typed-array? byte     #t)))
      (pass-if (eq? #f (typed-array? short    #t)))
      (pass-if (eq? #f (typed-array? ulong    #t)))
      (pass-if (eq? #f (typed-array? long     #t)))
      (pass-if (eq? #f (typed-array? longlong #t)))
      (pass-if (eq? #f (typed-array? float    #t)))
      (pass-if (eq? #f (typed-array? double   #t)))
      (pass-if (eq? #f (typed-array? complex  #t)))
      (pass-if (eq? #t (typed-array? scm      #t))))))

;;;
;;; array-equal?
;;;

(with-test-prefix "array-equal?"

  (pass-if "#s16(...)"
    (array-equal? #s16(1 2 3) #s16(1 2 3))))

;;;
;;; array->list
;;;

(with-test-prefix "array->list"
  (pass-if (equal? (array->list #s16(1 2 3)) '(1 2 3)))
  (pass-if (equal? (array->list #(1 2 3)) '(1 2 3)))
  (pass-if (equal? (array->list #2((1 2) (3 4) (5 6))) '((1 2) (3 4) (5 6))))
  (pass-if (equal? (array->list #()) '())))

;;;
;;; array-fill!
;;;

(with-test-prefix "array-fill!"

  (with-test-prefix "bool"
    (let ((a (make-bitvector 1 #t)))
      (pass-if "#f" (array-fill! a #f) #t)
      (pass-if "#t" (array-fill! a #t) #t)))

  (with-test-prefix "char"
    (let ((a (make-string 1 #\a)))
      (pass-if "x" (array-fill! a #\x) #t)))

  (with-test-prefix "byte"
    (let ((a (make-s8vector 1 0)))
      (pass-if "0"    (array-fill! a 0)    #t)
      (pass-if "127" (array-fill! a 127)   #t)
      (pass-if "-128" (array-fill! a -128) #t)
      (pass-if-exception "128" exception:out-of-range
	(array-fill! a 128))
      (pass-if-exception "-129" exception:out-of-range
	(array-fill! a -129))
      (pass-if-exception "symbol" exception:wrong-type-arg
	(array-fill! a 'symbol))))

  (with-test-prefix "short"
    (let ((a (make-s16vector 1 0)))
      (pass-if "0"    (array-fill! a 0)    #t)
      (pass-if "123"  (array-fill! a 123)  #t)
      (pass-if "-123" (array-fill! a -123) #t)))

  (with-test-prefix "ulong"
    (let ((a (make-u32vector 1 1)))
      (pass-if "0"    (array-fill! a 0)   #t)
      (pass-if "123"  (array-fill! a 123) #t)
      (pass-if-exception "-123" exception:out-of-range
	(array-fill! a -123) #t)))

  (with-test-prefix "long"
    (let ((a (make-s32vector 1 -1)))
      (pass-if "0"    (array-fill! a 0)    #t)
      (pass-if "123"  (array-fill! a 123)  #t)
      (pass-if "-123" (array-fill! a -123) #t)))

  (with-test-prefix "float"
    (let ((a (make-f32vector 1 1.0)))
      (pass-if "0.0"    (array-fill! a 0)      #t)
      (pass-if "123.0"  (array-fill! a 123.0)  #t)
      (pass-if "-123.0" (array-fill! a -123.0) #t)
      (pass-if "0"      (array-fill! a 0)      #t)
      (pass-if "123"    (array-fill! a 123)    #t)
      (pass-if "-123"   (array-fill! a -123)   #t)
      (pass-if "5/8"    (array-fill! a 5/8)    #t)))

  (with-test-prefix "double"
    (let ((a (make-f64vector 1 1/3)))
      (pass-if "0.0"    (array-fill! a 0)      #t)
      (pass-if "123.0"  (array-fill! a 123.0)  #t)
      (pass-if "-123.0" (array-fill! a -123.0) #t)
      (pass-if "0"      (array-fill! a 0)      #t)
      (pass-if "123"    (array-fill! a 123)    #t)
      (pass-if "-123"   (array-fill! a -123)   #t)
      (pass-if "5/8"    (array-fill! a 5/8)    #t))))

;;;
;;; array-in-bounds?
;;;

(with-test-prefix "array-in-bounds?"

  (pass-if (let ((a (make-array #f '(425 425))))
	     (eq? #f (array-in-bounds? a 0)))))

;;;
;;; array-prototype
;;;

(with-test-prefix "array-type"

  (with-test-prefix "on make-foo-vector"

    (pass-if "bool"
      (eq? 'b (array-type (make-bitvector 1))))

    (pass-if "char"
      (eq? 'a (array-type (make-string 1))))

    (pass-if "byte"
      (eq? 'u8 (array-type (make-u8vector 1))))

    (pass-if "short"
      (eq? 's16 (array-type (make-s16vector 1))))

    (pass-if "ulong"
      (eq? 'u32 (array-type (make-u32vector 1))))

    (pass-if "long"
      (eq? 's32 (array-type (make-s32vector 1))))

    (pass-if "long long"
      (eq? 's64 (array-type (make-s64vector 1))))

    (pass-if "float"
      (eq? 'f32 (array-type (make-f32vector 1))))

    (pass-if "double"
      (eq? 'f64 (array-type (make-f64vector 1))))

    (pass-if "complex"
      (eq? 'c64 (array-type (make-c64vector 1))))

    (pass-if "scm"
      (eq? #t (array-type (make-vector 1)))))

  (with-test-prefix "on make-typed-array"

    (let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64)))
      (for-each (lambda (type)
		  (pass-if (symbol->string type)
		     (eq? type
			  (array-type (make-typed-array type
							*unspecified*
							'(5 6))))))
		types))))

;;;
;;; array-set!
;;;

(with-test-prefix "array-set!"

  (with-test-prefix "bitvector"

    ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set!
    ;; on a bitvector like the following
    (let ((a (make-bitvector 1)))
      (pass-if "one elem set #t"
	(begin
	  (array-set! a #t 0)
	  (eq? #t (array-ref a 0))))
      (pass-if "one elem set #f"
	(begin
	  (array-set! a #f 0)
	  (eq? #f (array-ref a 0))))))

  (with-test-prefix "byte"

    (let ((a (make-s8vector 1)))

      (pass-if "-128"
	(begin (array-set! a -128 0) #t))
      (pass-if "0"
	(begin (array-set! a 0 0) #t))
      (pass-if "127"
	(begin (array-set! a 127 0) #t))
      (pass-if-exception "-129" exception:out-of-range
	(begin (array-set! a -129 0) #t))
      (pass-if-exception "128" exception:out-of-range
	(begin (array-set! a 128 0) #t))))

  (with-test-prefix "short"

    (let ((a (make-s16vector 1)))
      ;; true if n can be array-set! into a
      (define (fits? n)
	(false-if-exception (begin (array-set! a n 0) #t)))

      (with-test-prefix "store/fetch"
	;; Check array-ref gives back what was put with array-set!.
	;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and
	;; would silently truncate to a short.

	(do ((n 1 (1+ (* 2 n))))  ;; n=2^k-1
	    ((not (fits? n)))
	  (array-set! a n 0)
	  (pass-if n
	    (= n (array-ref a 0))))

	(do ((n -1 (* 2 n)))      ;; -n=2^k
	    ((not (fits? n)))
	  (array-set! a n 0)
	  (pass-if n
	    (= n (array-ref a 0))))))))

;;;
;;; array-set!
;;;

(with-test-prefix "array-set!"

  (with-test-prefix "one dim"
    (let ((a (make-array #f '(3 5))))
      (pass-if "start"
	(array-set! a 'y 3)
	#t)
      (pass-if "end"
	(array-set! a 'y 5)
	#t)
      (pass-if-exception "start-1" exception:out-of-range
	(array-set! a 'y 2))
      (pass-if-exception "end+1" exception:out-of-range
	(array-set! a 'y 6))
      (pass-if-exception "two indexes" exception:out-of-range
	(array-set! a 'y 6 7))))

  (with-test-prefix "two dim"
    (let ((a (make-array #f '(3 5) '(7 9))))
      (pass-if "start"
	(array-set! a 'y 3 7)
	#t)
      (pass-if "end"
	(array-set! a 'y 5 9)
	#t)
      (pass-if-exception "start i-1" exception:out-of-range
	(array-set! a 'y 2 7))
      (pass-if-exception "end i+1" exception:out-of-range
	(array-set! a 'y 6 9))
      (pass-if-exception "one index" exception:wrong-num-indices
	(array-set! a 'y 4))
      (pass-if-exception "three indexes" exception:wrong-num-indices
	(array-set! a 'y 4 8 0)))))

;;;
;;; make-shared-array
;;;

(define exception:mapping-out-of-range
  (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array

(with-test-prefix "make-shared-array"

  ;; this failed in guile 1.8.0
  (pass-if "vector unchanged"
    (let* ((a (make-array #f '(0 7)))
	   (s (make-shared-array a list '(0 7))))
      (array-equal? a s)))

  (pass-if-exception "vector, high too big" exception:mapping-out-of-range
    (let* ((a (make-array #f '(0 7))))
      (make-shared-array a list '(0 8))))

  (pass-if-exception "vector, low too big" exception:out-of-range
    (let* ((a (make-array #f '(0 7))))
      (make-shared-array a list '(-1 7))))

  (pass-if "truncate columns"
    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
		  #2((a b) (d e) (g h))))

  (pass-if "pick one column"
    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
				     (lambda (i) (list i 2))
				     '(0 2))
		  #(c f i)))

  (pass-if "diagonal"
    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
				     (lambda (i) (list i i))
				     '(0 2))
		  #(a e i)))

  ;; this failed in guile 1.8.0
  (pass-if "2 dims from 1 dim"
    (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
				     (lambda (i j) (list (+ (* i 3) j)))
				     4 3)
		  #2((a b c) (d e f) (g h i) (j k l))))

  (pass-if "reverse columns"
    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
				     (lambda (i j) (list i (- 2 j)))
				     3 3)
		  #2((c b a) (f e d) (i h g))))

  (pass-if "fixed offset, 0 based becomes 1 based"
    (let* ((x #2((a b c) (d e f) (g h i)))
	   (y (make-shared-array x
				 (lambda (i j) (list (1- i) (1- j)))
				 '(1 3) '(1 3))))
      (and (eq? (array-ref x 0 0) 'a)
	   (eq? (array-ref y 1 1) 'a))))

  ;; this failed in guile 1.8.0
  (pass-if "stride every third element"
    (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
				     (lambda (i) (list (* i 3)))
				     4)
		  #1(a d g j)))

  (pass-if "shared of shared"
    (let* ((a  #2((1 2 3) (4 5 6) (7 8 9)))
	   (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
	   (s2 (make-shared-array s1 list '(1 2))))
      (and (eqv? 5 (array-ref s2 1))
	   (eqv? 8 (array-ref s2 2))))))

;;;
;;; uniform-vector-ref
;;;

(with-test-prefix "uniform-vector-ref"

  (with-test-prefix "byte"

    (let ((a (make-s8vector 1)))

      (pass-if "0"
	(begin
	  (array-set! a 0 0)
	  (= 0 (uniform-vector-ref a 0))))
      (pass-if "127"
	(begin
	  (array-set! a 127 0)
	  (= 127 (uniform-vector-ref a 0))))
      (pass-if "-128"
	(begin
	  (array-set! a -128 0)
	  (= -128 (uniform-vector-ref a 0)))))))

;;;
;;; syntax
;;;

(with-test-prefix "syntax"

  (pass-if "rank and lower bounds"
    ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
    (let ((a '#2u32@2@7((1 2) (3 4))))
      (and (array? a)
           (typed-array? a 'u32)
           (= (array-rank a) 2)
           (let loop ((bounds '((2 7) (2 8) (3 7) (3 8)))
                      (result #t))
             (if (null? bounds)
                 result
                 (and result
                      (loop (cdr bounds)
                            (apply array-in-bounds? a (car bounds)))))))))

  (pass-if "negative lower bound"
     (let ((a '#1@-3(a b)))
       (and (array? a)
            (= (array-rank a) 1)
            (array-in-bounds? a -3) (array-in-bounds? a -2)
            (eq? 'a (array-ref a -3))
            (eq? 'b (array-ref a -2)))))

  (pass-if-exception "negative length" exception:length-non-negative
     (with-input-from-string "'#1:-3(#t #t)" read))

  (pass-if "bitvector is self-evaluating"
     (equal? (compile (bitvector)) (bitvector))))

;;;
;;; equal? with vector and one-dimensional array
;;;

(with-test-prefix "equal?"
  (pass-if "array and non-array"
    (not (equal? #2f64((0 1) (2 3)) 100)))

  (pass-if "empty vectors of different types"
    (not (equal? #s32() #f64())))

  (pass-if "empty arrays of different types"
    (not (equal? #2s32() #2f64())))

  (pass-if "empty arrays of the same type"
    (equal? #s32() #s32()))

  (pass-if "identical uniform vectors of the same type"
    (equal? #s32(1) #s32(1)))

  (pass-if "nonidentical uniform vectors of the same type"
    (not (equal? #s32(1) #s32(-1))))

  (pass-if "identical uniform vectors of different types"
    (not (equal? #s32(1) #s64(1))))

  (pass-if "nonidentical uniform vectors of different types"
    (not (equal? #s32(1) #s64(-1))))

  (pass-if "vector and one-dimensional array"
    (equal? (make-shared-array #2((a b c) (d e f) (g h i))
                               (lambda (i) (list i i))
                               '(0 2))
            #(a e i))))


code:
;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite tests asm-to-bytecode)
  #:use-module (rnrs bytevectors)
  #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
  #:use-module (test-suite lib)
  #:use-module (system vm instruction)
  #:use-module (language assembly compile-bytecode))

(define write-bytecode
  (@@ (language assembly compile-bytecode) write-bytecode))

(define (->u8-list sym val)
  (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
                           (uint32 4 ,bytevector-u32-native-set!))
                         sym)))
    (or entry (error "unknown sym" sym))
    (let ((bv (make-bytevector (car entry))))
      ((cadr entry) bv 0 val)
      (bytevector->u8-list bv))))

(define (munge-bytecode v)
  (let lp ((i 0) (out '()))
    (if (= i (vector-length v))
        (u8-list->bytevector (reverse out))
        (let ((x (vector-ref v i)))
          (cond
           ((symbol? x)
            (lp (1+ i) (cons (instruction->opcode x) out)))
           ((integer? x)
            (lp (1+ i) (cons x out)))
           ((pair? x)
            (lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
           (else (error "bad test bytecode" x)))))))

(define (comp-test x y)
  (let* ((y   (munge-bytecode y))
         (len (bytevector-length y))
         (v   #f))

    (run-test `(length ,x) #t
              (lambda ()
                (call-with-values open-bytevector-output-port
                  (lambda (port get-bytevector)
                    (write-bytecode x port '() 0 #t)
                    (set! v (get-bytevector))
                    (= (bytevector-length v) len)))))
    (run-test `(compile-equal? ,x ,y) #t
              (lambda ()
                (equal? v y)))))

(with-test-prefix "compiler"
  (with-test-prefix "asm-to-bytecode"

    (comp-test '(make-int8 3)
               #(make-int8 3))

    (comp-test '(load-number "3.14")
               (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.)
                       (char->integer #\1) (char->integer #\4)))

    (comp-test '(load-string "foo")
               (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o)
                       (char->integer #\o)))

    (comp-test '(load-symbol "foo")
               (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
                       (char->integer #\o)))

    (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string
               (vector 'load-string 0 0 1 230))

    (comp-test '(load-wide-string "λ")
               (apply vector 'load-wide-string 0 0 4
                      (if (eq? (native-endianness) (endianness little))
                          '(187 3 0 0)
                          '(0 0 3 187))))

    (comp-test '(load-program () 3 #f (make-int8 3) (return))
               #(load-program
                 (uint32 3)     ;; len
                 (uint32 0)     ;; metalen
                 make-int8 3
                 return))

    ;; the nops are to pad meta to an 8-byte alignment. not strictly
    ;; necessary for this test, but representative of the common case.
    (comp-test '(load-program () 8
                              (load-program () 3
                                            #f
                                            (make-int8 3) (return))
                              (make-int8 3) (return)
                              (nop) (nop) (nop) (nop) (nop))
               #(load-program
                 (uint32 8)     ;; len
                 (uint32 11)    ;; metalen
                 make-int8 3
                 return
                 nop nop nop nop nop
                 (uint32 3)     ;; len
                 (uint32 0)     ;; metalen
                 make-int8 3
                 return))))

license: mit


code:
;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-bit-operations)
  :use-module (test-suite lib)
  :use-module (ice-9 documentation))

;;;
;;; miscellaneous
;;;

(define (run-tests name-proc test-proc arg-sets)
  (for-each
   (lambda (arg-set)
     (pass-if (apply name-proc arg-set)
       (apply test-proc arg-set)))
   arg-sets))

(define (documented? object)
  (not (not (object-documentation object))))

(define fixnum-bit
  (inexact->exact (round (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1))))

(define fixnum-min most-negative-fixnum)
(define fixnum-max most-positive-fixnum)

(with-test-prefix "bit-extract"

  (pass-if "documented?"
    (documented? bit-extract))

  (with-test-prefix "extract from zero"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list 0 0 1 0)
      (list 0 1 2 0)
      (list 0 (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
      (list 0 (+ fixnum-bit -1) (+ fixnum-bit  0) 0)
      (list 0 (+ fixnum-bit  0) (+ fixnum-bit  1) 0)
      (list 0 (+ fixnum-bit  1) (+ fixnum-bit  2) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list 0 0 (+ fixnum-bit -1) 0)
      (list 0 1 (+ fixnum-bit  0) 0)
      (list 0 2 (+ fixnum-bit  1) 0)
      (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 0)
      (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0)
      (list 0 (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit -1) 0)
      (list 0 (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  0) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list 0 0 (+ fixnum-bit  0) 0)
      (list 0 1 (+ fixnum-bit  1) 0)
      (list 0 2 (+ fixnum-bit  2) 0)
      (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 0)
      (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0)
      (list 0 (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  0) 0)
      (list 0 (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  1) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list 0 0 (+ fixnum-bit  1) 0)
      (list 0 1 (+ fixnum-bit  2) 0)
      (list 0 2 (+ fixnum-bit  3) 0)
      (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 0)
      (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit  0) 0)
      (list 0 (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  1) 0)
      (list 0 (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  2) 0))))

  (with-test-prefix "extract from fixnum-max"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-max 0 1 1)
      (list fixnum-max 1 2 1)
      (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit -1) 1)
      (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit  0) 0)
      (list fixnum-max (+ fixnum-bit  0) (+ fixnum-bit  1) 0)
      (list fixnum-max (+ fixnum-bit  1) (+ fixnum-bit  2) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-max 0 (+ fixnum-bit -1) (ash fixnum-max  0))
      (list fixnum-max 1 (+ fixnum-bit  0) (ash fixnum-max -1))
      (list fixnum-max 2 (+ fixnum-bit  1) (ash fixnum-max -2))
      (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 1)
      (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0)
      (list fixnum-max (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit -1) 0)
      (list fixnum-max (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  0) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-max 0 (+ fixnum-bit  0) (ash fixnum-max  0))
      (list fixnum-max 1 (+ fixnum-bit  1) (ash fixnum-max -1))
      (list fixnum-max 2 (+ fixnum-bit  2) (ash fixnum-max -2))
      (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 1)
      (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0)
      (list fixnum-max (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  0) 0)
      (list fixnum-max (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  1) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-max 0 (+ fixnum-bit  1) (ash fixnum-max  0))
      (list fixnum-max 1 (+ fixnum-bit  2) (ash fixnum-max -1))
      (list fixnum-max 2 (+ fixnum-bit  3) (ash fixnum-max -2))
      (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 1)
      (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit  0) 0)
      (list fixnum-max (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  1) 0)
      (list fixnum-max (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  2) 0))))

  (with-test-prefix "extract from fixnum-max + 1"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (+ fixnum-max 1) 0 1 0)
      (list (+ fixnum-max 1) 1 2 0)
      (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit  0) 1)
      (list (+ fixnum-max 1) (+ fixnum-bit  0) (+ fixnum-bit  1) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit  1) (+ fixnum-bit  2) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (+ fixnum-max 1) 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1)))
      (list (+ fixnum-max 1) 1 (+ fixnum-bit  0) (ash 1 (- fixnum-bit 2)))
      (list (+ fixnum-max 1) 2 (+ fixnum-bit  1) (ash 1 (- fixnum-bit 3)))
      (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 2)
      (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 1)
      (list (+ fixnum-max 1) (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit -1) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  0) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (+ fixnum-max 1) 0 (+ fixnum-bit  0) (ash 1 (- fixnum-bit 1)))
      (list (+ fixnum-max 1) 1 (+ fixnum-bit  1) (ash 1 (- fixnum-bit 2)))
      (list (+ fixnum-max 1) 2 (+ fixnum-bit  2) (ash 1 (- fixnum-bit 3)))
      (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 2)
      (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 1)
      (list (+ fixnum-max 1) (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  0) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  1) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (+ fixnum-max 1) 0 (+ fixnum-bit  1) (ash 1 (- fixnum-bit 1)))
      (list (+ fixnum-max 1) 1 (+ fixnum-bit  2) (ash 1 (- fixnum-bit 2)))
      (list (+ fixnum-max 1) 2 (+ fixnum-bit  3) (ash 1 (- fixnum-bit 3)))
      (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 2)
      (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit  0) 1)
      (list (+ fixnum-max 1) (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  1) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  2) 0))))

  (with-test-prefix "extract from fixnum-min"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-min 0 1 0)
      (list fixnum-min 1 2 0)
      (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
      (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit  0) 1)
      (list fixnum-min (+ fixnum-bit  0) (+ fixnum-bit  1) 1)
      (list fixnum-min (+ fixnum-bit  1) (+ fixnum-bit  2) 1)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-min 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1)))
      (list fixnum-min 1 (+ fixnum-bit  0) (ash 1 (- fixnum-bit 2)))
      (list fixnum-min 2 (+ fixnum-bit  1) (ash 3 (- fixnum-bit 3)))
      (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3)
            (- (ash 1	(- fixnum-bit 1)) 2))
      (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2)
            (- (ash 1	(- fixnum-bit 1)) 1))
      (list fixnum-min (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit -1)
            (- (ash 1	(- fixnum-bit 1)) 1))
      (list fixnum-min (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  0)
            (- (ash 1	(- fixnum-bit 1)) 1))))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-min 0 (+ fixnum-bit  0) (ash 1 (- fixnum-bit 1)))
      (list fixnum-min 1 (+ fixnum-bit  1) (ash 3 (- fixnum-bit 2)))
      (list fixnum-min 2 (+ fixnum-bit  2) (ash 7 (- fixnum-bit 3)))
      (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2)
            (- (ash 1	fixnum-bit) 2))
      (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1)
            (- (ash 1	fixnum-bit) 1))
      (list fixnum-min (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  0)
            (- (ash 1	fixnum-bit) 1))
      (list fixnum-min (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  1)
            (- (ash 1	fixnum-bit) 1))))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-min 0 (+ fixnum-bit  1) (ash  3 (- fixnum-bit 1)))
      (list fixnum-min 1 (+ fixnum-bit  2) (ash  7 (- fixnum-bit 2)))
      (list fixnum-min 2 (+ fixnum-bit  3) (ash 15 (- fixnum-bit 3)))
      (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1)
            (- (ash 1 (+ fixnum-bit 1)) 2))
      (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit  0)
            (- (ash 1 (+ fixnum-bit 1)) 1))
      (list fixnum-min (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  1)
            (- (ash 1 (+ fixnum-bit 1)) 1))
      (list fixnum-min (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  2)
            (- (ash 1 (+ fixnum-bit 1)) 1)))))

  (with-test-prefix "extract from fixnum-min - 1"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (- fixnum-min 1) 0 1 1)
      (list (- fixnum-min 1) 1 2 1)
      (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 1)
      (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit  0) 0)
      (list (- fixnum-min 1) (+ fixnum-bit  0) (+ fixnum-bit  1) 1)
      (list (- fixnum-min 1) (+ fixnum-bit  1) (+ fixnum-bit  2) 1)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (- fixnum-min 1) 0 (+ fixnum-bit -1)
            (- (ash 1 (- fixnum-bit 1)) 1 (ash 0 (- fixnum-bit 1))))
      (list (- fixnum-min 1) 1 (+ fixnum-bit  0)
            (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2))))
      (list (- fixnum-min 1) 2 (+ fixnum-bit  1)
            (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3))))
      (list (- fixnum-min 1) (+ fixnum-bit -2)
            (+ fixnum-bit fixnum-bit -3) (- (ash 1 (- fixnum-bit 1)) 3))
      (list (- fixnum-min 1) (+ fixnum-bit -1)
            (+ fixnum-bit fixnum-bit -2) (- (ash 1 (- fixnum-bit 1)) 2))
      (list (- fixnum-min 1) (+ fixnum-bit  0)
            (+ fixnum-bit fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1))
      (list (- fixnum-min 1) (+ fixnum-bit  1)
            (+ fixnum-bit fixnum-bit  0) (- (ash 1 (- fixnum-bit 1)) 1))))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (- fixnum-min 1) 0 (+ fixnum-bit  0)
            (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 1))))
      (list (- fixnum-min 1) 1 (+ fixnum-bit  1)
            (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 2))))
      (list (- fixnum-min 1) 2 (+ fixnum-bit  2)
            (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 3))))
      (list (- fixnum-min 1) (+ fixnum-bit -2)
            (+ fixnum-bit fixnum-bit -2) (- (ash 1 fixnum-bit) 3))
      (list (- fixnum-min 1) (+ fixnum-bit -1)
            (+ fixnum-bit fixnum-bit -1) (- (ash 1 fixnum-bit) 2))
      (list (- fixnum-min 1) (+ fixnum-bit  0)
            (+ fixnum-bit fixnum-bit  0) (- (ash 1 fixnum-bit) 1))
      (list (- fixnum-min 1) (+ fixnum-bit  1)
            (+ fixnum-bit fixnum-bit  1) (- (ash 1 fixnum-bit) 1))))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (- fixnum-min 1) 0 (+ fixnum-bit  1)
            (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 1))))
      (list (- fixnum-min 1) 1 (+ fixnum-bit  2)
            (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2))))
      (list (- fixnum-min 1) 2 (+ fixnum-bit  3)
            (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3))))
      (list (- fixnum-min 1) (+ fixnum-bit -2)
            (+ fixnum-bit fixnum-bit -1) (- (ash 1 (+ fixnum-bit 1)) 3))
      (list (- fixnum-min 1) (+ fixnum-bit -1)
            (+ fixnum-bit fixnum-bit  0) (- (ash 1 (+ fixnum-bit 1)) 2))
      (list (- fixnum-min 1) (+ fixnum-bit  0)
            (+ fixnum-bit fixnum-bit  1) (- (ash 1 (+ fixnum-bit 1)) 1))
      (list (- fixnum-min 1) (+ fixnum-bit  1)
            (+ fixnum-bit fixnum-bit  2) (- (ash 1 (+ fixnum-bit 1)) 1))))))

(with-test-prefix "bitshifts on word boundaries"
  (pass-if (= (ash 1 32) 4294967296))
  (pass-if (= (ash 1 64) 18446744073709551616)))


code:
;;;; test brainfuck compilation -*- scheme -*-
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite tests brainfuck)
  #:use-module (test-suite lib)
  #:use-module (system base compile))

;; This program taken from Wikipedia's brainfuck introduction page.
(define prog "
   +++ +++ +++ +           initialize counter (cell #0) to 10
   [                       use loop to set the next four cells to 70/100/30/10
       > +++ +++ +             add  7 to cell #1
       > +++ +++ +++ +         add 10 to cell #2
       > +++                   add  3 to cell #3
       > +                     add  1 to cell #4
       <<< < -                 decrement counter (cell #0)
   ]
   >++ .                   print 'H'
   >+.                     print 'e'
   +++ +++ +.              print 'l'
   .                       print 'l'
   +++ .                   print 'o'
   >++ .                   print ' '
   <<+ +++ +++ +++ +++ ++. print 'W'
   >.                      print 'o'
   +++ .                   print 'r'
   --- --- .               print 'l'
   --- --- --.             print 'd'
   >+.                     print '!'")

(pass-if
 (equal? (with-output-to-string
          (lambda ()
            (call-with-input-string
             prog
             (lambda (port)
               (read-and-compile port #:from 'brainfuck #:to 'value)))))
         "Hello World!"))


code:
;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-bytevector)
  :use-module (test-suite lib)
  :use-module (system base compile)
  :use-module (rnrs bytevectors))

;;; Some of the tests in here are examples taken from the R6RS Standard
;;; Libraries document.

(define-syntax c&e
  (syntax-rules (pass-if pass-if-exception)
    ((_ (pass-if test-name exp))
     (begin (pass-if (string-append test-name " (eval)")
                     (primitive-eval 'exp))
            (pass-if (string-append test-name " (compile)")
                     (compile 'exp #:to 'value #:env (current-module)))))
    ((_ (pass-if-exception test-name exc exp))
     (begin (pass-if-exception (string-append test-name " (eval)")
                               exc (primitive-eval 'exp))
            (pass-if-exception (string-append test-name " (compile)")
                               exc (compile 'exp #:to 'value
                                            #:env (current-module)))))))

(define-syntax with-test-prefix/c&e
  (syntax-rules ()
    ((_ section-name exp ...)
     (with-test-prefix section-name (c&e exp) ...))))

(with-test-prefix/c&e "2.2 General Operations"

  (pass-if "native-endianness"
    (not (not (memq (native-endianness) '(big little)))))

  (pass-if "make-bytevector"
    (and (bytevector? (make-bytevector 20))
         (bytevector? (make-bytevector 20 3))))

  (pass-if "bytevector-length"
    (= (bytevector-length (make-bytevector 20)) 20))

  (pass-if "bytevector=?"
    (and (bytevector=? (make-bytevector 20 7)
                       (make-bytevector 20 7))
         (not (bytevector=? (make-bytevector 20 7)
                            (make-bytevector 20 0))))))

(with-test-prefix/c&e "2.3 Operations on Bytes and Octets"

  (pass-if "bytevector-{u8,s8}-ref"
    (equal? '(-127 129 -1 255)
            (let ((b1 (make-bytevector 16 -127))
                  (b2 (make-bytevector 16 255)))
              (list (bytevector-s8-ref b1 0)
                    (bytevector-u8-ref b1 0)
                    (bytevector-s8-ref b2 0)
                    (bytevector-u8-ref b2 0)))))

  (pass-if "bytevector-{u8,s8}-set!"
    (equal? '(-126 130 -10 246)
            (let ((b (make-bytevector 16 -127)))

              (bytevector-s8-set! b 0 -126)
              (bytevector-u8-set! b 1 246)

              (list (bytevector-s8-ref b 0)
                    (bytevector-u8-ref b 0)
                    (bytevector-s8-ref b 1)
                    (bytevector-u8-ref b 1)))))

  (pass-if "bytevector->u8-list"
    (let ((lst '(1 2 3 128 150 255)))
      (equal? lst
              (bytevector->u8-list
               (let ((b (make-bytevector 6)))
                 (for-each (lambda (i v)
                             (bytevector-u8-set! b i v))
                           (iota 6)
                           lst)
                 b)))))

  (pass-if "u8-list->bytevector"
    (let ((lst '(1 2 3 128 150 255)))
      (equal? lst
              (bytevector->u8-list (u8-list->bytevector lst)))))

  (pass-if "bytevector-uint-{ref,set!} [small]"
    (let ((b (make-bytevector 15)))
      (bytevector-uint-set! b 0 #x1234
                            (endianness little) 2)
      (equal? (bytevector-uint-ref b 0 (endianness big) 2)
              #x3412)))

  (pass-if "bytevector-uint-set! [large]"
    (let ((b (make-bytevector 16)))
      (bytevector-uint-set! b 0 (- (expt 2 128) 3)
                            (endianness little) 16)
      (equal? (bytevector->u8-list b)
              '(253 255 255 255 255 255 255 255
                255 255 255 255 255 255 255 255))))

  (pass-if "bytevector-uint-{ref,set!} [large]"
    (let ((b (make-bytevector 120)))
      (bytevector-uint-set! b 0 (- (expt 2 128) 3)
                            (endianness little) 16)
      (equal? (bytevector-uint-ref b 0 (endianness little) 16)
              #xfffffffffffffffffffffffffffffffd)))

  (pass-if "bytevector-sint-ref [small]"
    (let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
      (equal? (bytevector-sint-ref b 0 (endianness big) 2)
              (bytevector-sint-ref b 1 (endianness little) 2)
              -16)))

  (pass-if "bytevector-sint-ref [large]"
    (let ((b (make-bytevector 50)))
      (bytevector-uint-set! b 0 (- (expt 2 128) 3)
                            (endianness little) 16)
      (equal? (bytevector-sint-ref b 0 (endianness little) 16)
              -3)))

  (pass-if "bytevector-sint-set! [small]"
    (let ((b (make-bytevector 3)))
      (bytevector-sint-set! b 0 -16 (endianness big) 2)
      (bytevector-sint-set! b 1 -16 (endianness little) 2)
      (equal? (bytevector->u8-list b)
	      '(#xff #xf0 #xff))))

  (pass-if "equal?"
    (let ((bv1 (u8-list->bytevector (iota 123)))
          (bv2 (u8-list->bytevector (iota 123))))
      (equal? bv1 bv2))))

(with-test-prefix/c&e "2.4 Operations on Integers of Arbitrary Size"

  (pass-if "bytevector->sint-list"
    (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
      (equal? (bytevector->sint-list b (endianness little) 2)
              '(513 -253 513 513))))

  (pass-if "bytevector->uint-list"
    (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1))))
      (equal? (bytevector->uint-list b (endianness big) 2)
              '(513 65283 513 513))))

  (pass-if "bytevector->uint-list [empty]"
    (let ((b (make-bytevector 0)))
      (null? (bytevector->uint-list b (endianness big) 2))))

  (pass-if-exception "bytevector->sint-list [out-of-range]"
    exception:out-of-range
    (bytevector->sint-list (make-bytevector 6) (endianness little) 8))

  (pass-if "bytevector->sint-list [off-by-one]"
    (equal? (bytevector->sint-list (make-bytevector 31 #xff)
                                   (endianness little) 8)
            '(-1 -1 -1)))

  (pass-if "{sint,uint}-list->bytevector"
    (let ((b1 (sint-list->bytevector '(513 -253 513 513)
                                     (endianness little) 2))
          (b2 (uint-list->bytevector '(513 65283 513 513)
                                     (endianness little) 2))
          (b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
      (and (bytevector=? b1 b2)
           (bytevector=? b2 b3))))

  (pass-if "sint-list->bytevector [limits]"
           (bytevector=? (sint-list->bytevector '(-32768 32767)
                                                (endianness big) 2)
                         (let ((bv (make-bytevector 4)))
                           (bytevector-u8-set! bv 0 #x80)
                           (bytevector-u8-set! bv 1 #x00)
                           (bytevector-u8-set! bv 2 #x7f)
                           (bytevector-u8-set! bv 3 #xff)
                           bv)))

  (pass-if-exception "sint-list->bytevector [out-of-range]"
    exception:out-of-range
    (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big)
                           2))

  (pass-if-exception "uint-list->bytevector [out-of-range]"
    exception:out-of-range
    (uint-list->bytevector '(0 -1) (endianness big) 2)))

(with-test-prefix/c&e "2.5 Operations on 16-Bit Integers"

  (pass-if "bytevector-u16-ref"
    (let ((b (u8-list->bytevector
              '(255 255 255 255 255 255 255 255
                255 255 255 255 255 255 255 253))))
      (and (equal? (bytevector-u16-ref b 14 (endianness little))
                   #xfdff)
           (equal? (bytevector-u16-ref b 14 (endianness big))
                   #xfffd))))

  (pass-if "bytevector-s16-ref"
    (let ((b (u8-list->bytevector
              '(255 255 255 255 255 255 255 255
                255 255 255 255 255 255 255 253))))
      (and (equal? (bytevector-s16-ref b 14 (endianness little))
                   -513)
           (equal? (bytevector-s16-ref b 14 (endianness big))
                   -3))))

  (pass-if "bytevector-s16-ref [unaligned]"
    (let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
      (equal? (bytevector-s16-ref b 1 (endianness little))
	      -16)))

  (pass-if "bytevector-{u16,s16}-ref"
    (let ((b (make-bytevector 2)))
      (bytevector-u16-set! b 0 44444 (endianness little))
      (and (equal? (bytevector-u16-ref b 0 (endianness little))
                   44444)
           (equal? (bytevector-s16-ref b 0 (endianness little))
                   (- 44444 65536)))))

  (pass-if "bytevector-native-{u16,s16}-{ref,set!}"
    (let ((b (make-bytevector 2)))
      (bytevector-u16-native-set! b 0 44444)
      (and (equal? (bytevector-u16-native-ref b 0)
                   44444)
           (equal? (bytevector-s16-native-ref b 0)
                   (- 44444 65536)))))

  (pass-if "bytevector-s16-{ref,set!} [unaligned]"
    (let ((b (make-bytevector 3)))
      (bytevector-s16-set! b 1 -77 (endianness little))
      (equal? (bytevector-s16-ref b 1 (endianness little))
	      -77))))

(with-test-prefix/c&e "2.6 Operations on 32-bit Integers"

  (pass-if "bytevector-u32-ref"
    (let ((b (u8-list->bytevector
              '(255 255 255 255 255 255 255 255
                255 255 255 255 255 255 255 253))))
      (and (equal? (bytevector-u32-ref b 12 (endianness little))
                   #xfdffffff)
           (equal? (bytevector-u32-ref b 12 (endianness big))
                   #xfffffffd))))

  (pass-if "bytevector-s32-ref"
    (let ((b (u8-list->bytevector
              '(255 255 255 255 255 255 255 255
                255 255 255 255 255 255 255 253))))
      (and (equal? (bytevector-s32-ref b 12 (endianness little))
                   -33554433)
           (equal? (bytevector-s32-ref b 12 (endianness big))
                   -3))))

  (pass-if "bytevector-{u32,s32}-ref"
    (let ((b (make-bytevector 4)))
      (bytevector-u32-set! b 0 2222222222 (endianness little))
      (and (equal? (bytevector-u32-ref b 0 (endianness little))
                   2222222222)
           (equal? (bytevector-s32-ref b 0 (endianness little))
                   (- 2222222222 (expt 2 32))))))

  (pass-if "bytevector-{u32,s32}-native-{ref,set!}"
    (let ((b (make-bytevector 4)))
      (bytevector-u32-native-set! b 0 2222222222)
      (and (equal? (bytevector-u32-native-ref b 0)
                   2222222222)
           (equal? (bytevector-s32-native-ref b 0)
                   (- 2222222222 (expt 2 32)))))))

(with-test-prefix/c&e "2.7 Operations on 64-bit Integers"

  (pass-if "bytevector-u64-ref"
    (let ((b (u8-list->bytevector
              '(255 255 255 255 255 255 255 255
                255 255 255 255 255 255 255 253))))
      (and (equal? (bytevector-u64-ref b 8 (endianness little))
                   #xfdffffffffffffff)
           (equal? (bytevector-u64-ref b 8 (endianness big))
                   #xfffffffffffffffd))))

  (pass-if "bytevector-s64-ref"
    (let ((b (u8-list->bytevector
              '(255 255 255 255 255 255 255 255
                255 255 255 255 255 255 255 253))))
      (and (equal? (bytevector-s64-ref b 8 (endianness little))
                   -144115188075855873)
           (equal? (bytevector-s64-ref b 8 (endianness big))
                   -3))))

  (pass-if "bytevector-{u64,s64}-ref"
    (let ((b (make-bytevector 8))
          (big 9333333333333333333))
      (bytevector-u64-set! b 0 big (endianness little))
      (and (equal? (bytevector-u64-ref b 0 (endianness little))
                   big)
           (equal? (bytevector-s64-ref b 0 (endianness little))
                   (- big (expt 2 64))))))

  (pass-if "bytevector-{u64,s64}-native-{ref,set!}"
    (let ((b (make-bytevector 8))
          (big 9333333333333333333))
      (bytevector-u64-native-set! b 0 big)
      (and (equal? (bytevector-u64-native-ref b 0)
                   big)
           (equal? (bytevector-s64-native-ref b 0)
                   (- big (expt 2 64))))))

  (pass-if "ref/set! with zero"
     (let ((b (make-bytevector 8)))
       (bytevector-s64-set! b 0 -1 (endianness big))
       (bytevector-u64-set! b 0  0 (endianness big))
       (= 0 (bytevector-u64-ref b 0 (endianness big))))))

(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations"

  (pass-if "bytevector-ieee-single-native-{ref,set!}"
    (let ((b (make-bytevector 4))
          (number 3.00))
      (bytevector-ieee-single-native-set! b 0 number)
      (equal? (bytevector-ieee-single-native-ref b 0)
              number)))

  (pass-if "bytevector-ieee-single-{ref,set!}"
    (let ((b (make-bytevector 8))
          (number 3.14))
      (bytevector-ieee-single-set! b 0 number (endianness little))
      (bytevector-ieee-single-set! b 4 number (endianness big))
      (equal? (bytevector-ieee-single-ref b 0 (endianness little))
              (bytevector-ieee-single-ref b 4 (endianness big)))))

  (pass-if "bytevector-ieee-single-{ref,set!} [unaligned]"
    (let ((b (make-bytevector 9))
          (number 3.14))
      (bytevector-ieee-single-set! b 1 number (endianness little))
      (bytevector-ieee-single-set! b 5 number (endianness big))
      (equal? (bytevector-ieee-single-ref b 1 (endianness little))
              (bytevector-ieee-single-ref b 5 (endianness big)))))

  (pass-if "bytevector-ieee-double-native-{ref,set!}"
    (let ((b (make-bytevector 8))
          (number 3.14))
      (bytevector-ieee-double-native-set! b 0 number)
      (equal? (bytevector-ieee-double-native-ref b 0)
              number)))

  (pass-if "bytevector-ieee-double-{ref,set!}"
    (let ((b (make-bytevector 16))
          (number 3.14))
      (bytevector-ieee-double-set! b 0 number (endianness little))
      (bytevector-ieee-double-set! b 8 number (endianness big))
      (equal? (bytevector-ieee-double-ref b 0 (endianness little))
              (bytevector-ieee-double-ref b 8 (endianness big))))))

;; Default to the C locale for the following tests.
(setlocale LC_ALL "C")

(with-test-prefix "2.9 Operations on Strings"

  (pass-if "string->utf8"
    (let* ((str  "hello, world")
           (utf8 (string->utf8 str)))
      (and (bytevector? utf8)
           (= (bytevector-length utf8)
              (string-length str))
           (equal? (string->list str)
                   (map integer->char (bytevector->u8-list utf8))))))

  (pass-if "string->utf8 [latin-1]"
    (let* ((str  "hé, ça va bien ?")
           (utf8 (string->utf8 str)))
      (and (bytevector? utf8)
           (= (bytevector-length utf8)
              (+ 2 (string-length str))))))

  (pass-if "string->utf16"
    (let* ((str   "hello, world")
           (utf16 (string->utf16 str)))
      (and (bytevector? utf16)
           (= (bytevector-length utf16)
              (* 2 (string-length str)))
           (equal? (string->list str)
                   (map integer->char
                        (bytevector->uint-list utf16
                                               (endianness big) 2))))))

  (pass-if "string->utf16 [little]"
    (let* ((str   "hello, world")
           (utf16 (string->utf16 str (endianness little))))
      (and (bytevector? utf16)
           (= (bytevector-length utf16)
              (* 2 (string-length str)))
           (equal? (string->list str)
                   (map integer->char
                        (bytevector->uint-list utf16
                                               (endianness little) 2))))))

  (pass-if "string->utf32"
    (let* ((str   "hello, world")
           (utf32 (string->utf32 str)))
      (and (bytevector? utf32)
           (= (bytevector-length utf32)
              (* 4 (string-length str)))
           (equal? (string->list str)
                   (map integer->char
                        (bytevector->uint-list utf32
                                               (endianness big) 4))))))

  (pass-if "string->utf32 [Greek]"
    (let* ((str   "Ἄνεμοι")
           (utf32 (string->utf32 str)))
      (and (bytevector? utf32)
           (equal? (bytevector->uint-list utf32 (endianness big) 4)
                   '(#x1f0c #x3bd #x3b5 #x3bc #x3bf #x3b9)))))

  (pass-if "string->utf32 [little]"
    (let* ((str   "hello, world")
           (utf32 (string->utf32 str (endianness little))))
      (and (bytevector? utf32)
           (= (bytevector-length utf32)
              (* 4 (string-length str)))
           (equal? (string->list str)
                   (map integer->char
                        (bytevector->uint-list utf32
                                               (endianness little) 4))))))

  (pass-if "utf8->string"
    (let* ((utf8  (u8-list->bytevector (map char->integer
                                            (string->list "hello, world"))))
           (str   (utf8->string utf8)))
      (and (string? str)
           (= (string-length str)
              (bytevector-length utf8))
           (equal? (string->list str)
                   (map integer->char (bytevector->u8-list utf8))))))

  (pass-if "utf8->string [latin-1]"
    (let* ((utf8  (string->utf8 "hé, ça va bien ?"))
           (str   (utf8->string utf8)))
      (and (string? str)
           (= (string-length str)
              (- (bytevector-length utf8) 2)))))

  (pass-if "utf16->string"
    (let* ((utf16  (uint-list->bytevector (map char->integer
                                               (string->list "hello, world"))
                                          (endianness big) 2))
           (str   (utf16->string utf16)))
      (and (string? str)
           (= (* 2 (string-length str))
              (bytevector-length utf16))
           (equal? (string->list str)
                   (map integer->char
                        (bytevector->uint-list utf16 (endianness big)
                                               2))))))

  (pass-if "utf16->string [little]"
    (let* ((utf16  (uint-list->bytevector (map char->integer
                                               (string->list "hello, world"))
                                          (endianness little) 2))
           (str   (utf16->string utf16 (endianness little))))
      (and (string? str)
           (= (* 2 (string-length str))
              (bytevector-length utf16))
           (equal? (string->list str)
                   (map integer->char
                        (bytevector->uint-list utf16 (endianness little)
                                               2))))))
  (pass-if "utf32->string"
    (let* ((utf32  (uint-list->bytevector (map char->integer
                                               (string->list "hello, world"))
                                          (endianness big) 4))
           (str   (utf32->string utf32)))
      (and (string? str)
           (= (* 4 (string-length str))
              (bytevector-length utf32))
           (equal? (string->list str)
                   (map integer->char
                        (bytevector->uint-list utf32 (endianness big)
                                               4))))))

  (pass-if "utf32->string [little]"
    (let* ((utf32  (uint-list->bytevector (map char->integer
                                               (string->list "hello, world"))
                                          (endianness little) 4))
           (str   (utf32->string utf32 (endianness little))))
      (and (string? str)
           (= (* 4 (string-length str))
              (bytevector-length utf32))
           (equal? (string->list str)
                   (map integer->char
                        (bytevector->uint-list utf32 (endianness little)
                                               4)))))))

(with-test-prefix "Datum Syntax"

  (pass-if "empty"
    (equal? (with-input-from-string "#vu8()" read)
            (make-bytevector 0)))

  (pass-if "simple"
    (equal? (with-input-from-string "#vu8(1 2 3   4 5)" read)
            (u8-list->bytevector '(1 2 3 4 5))))

  (pass-if ">127"
    (equal? (with-input-from-string "#vu8(0 255 127 128)" read)
            (u8-list->bytevector '(0 255 127 128))))

  (pass-if "self-evaluating?"
    (self-evaluating? (make-bytevector 1)))

  (pass-if "self-evaluating"
    (equal? (eval (with-input-from-string "#vu8(1 2 3 4 5)" read)
                  (current-module))
            (u8-list->bytevector '(1 2 3 4 5))))

  (pass-if "quoted"
    (equal? (eval (with-input-from-string "'#vu8(1 2 3 4 5)" read)
                  (current-module))
            (u8-list->bytevector '(1 2 3 4 5))))

  (pass-if "literal simple"
    (equal? #vu8(1 2 3   4 5)
            (u8-list->bytevector '(1 2 3 4 5))))

  (pass-if "literal >127"
    (equal? #vu8(0 255 127 128)
            (u8-list->bytevector '(0 255 127 128))))

  (pass-if "literal quoted"
    (equal? '#vu8(1 2 3   4 5)
            (u8-list->bytevector '(1 2 3 4 5))))

  (pass-if-exception "incorrect prefix"
    exception:read-error
    (with-input-from-string "#vi8(1 2 3)" read))

  (pass-if-exception "extraneous space"
    exception:read-error
    (with-input-from-string "#vu8 (1 2 3)" read))

  (pass-if-exception "negative integers"
    exception:wrong-type-arg
    (with-input-from-string "#vu8(-1 -2 -3)" read))

  (pass-if-exception "out-of-range integers"
    exception:wrong-type-arg
    (with-input-from-string "#vu8(0 256)" read)))

(with-test-prefix "Generalized Vectors"

  (pass-if "generalized-vector?"
    (generalized-vector? #vu8(1 2 3)))

  (pass-if "generalized-vector-length"
    (equal? (iota 16)
            (map generalized-vector-length
                 (map make-bytevector (iota 16)))))

  (pass-if "generalized-vector-ref"
    (let ((bv #vu8(255 127)))
      (and (= 255 (generalized-vector-ref bv 0))
           (= 127 (generalized-vector-ref bv 1)))))

  (pass-if-exception "generalized-vector-ref [index out-of-range]"
    exception:out-of-range
    (let ((bv #vu8(1 2)))
      (generalized-vector-ref bv 2)))

  (pass-if "generalized-vector-set!"
    (let ((bv (make-bytevector 2)))
      (generalized-vector-set! bv 0 255)
      (generalized-vector-set! bv 1 77)
      (equal? '(255 77)
              (bytevector->u8-list bv))))

  (pass-if-exception "generalized-vector-set! [index out-of-range]"
    exception:out-of-range
    (let ((bv (make-bytevector 2)))
      (generalized-vector-set! bv 2 0)))

  (pass-if-exception "generalized-vector-set! [value out-of-range]"
    exception:out-of-range
    (let ((bv (make-bytevector 2)))
      (generalized-vector-set! bv 0 256)))

  (pass-if "array-type"
    (eq? 'vu8 (array-type #vu8())))

  (pass-if "array-contents"
    (let ((bv (u8-list->bytevector (iota 10))))
      (eq? bv (array-contents bv))))

  (pass-if "array-ref"
    (let ((bv (u8-list->bytevector (iota 10))))
      (equal? (iota 10)
              (map (lambda (i) (array-ref bv i))
                   (iota 10)))))

  (pass-if "array-set!"
    (let ((bv (make-bytevector 10)))
      (for-each (lambda (i)
                  (array-set! bv i i))
                (iota 10))
      (equal? (iota 10)
              (bytevector->u8-list bv))))

  (pass-if "make-typed-array"
    (let ((bv (make-typed-array 'vu8 77 33)))
      (equal? bv (u8-list->bytevector (make-list 33 77)))))

  (pass-if-exception "make-typed-array [out-of-range]"
    exception:out-of-range
    (make-typed-array 'vu8 256 77)))

(with-test-prefix "uniform-array->bytevector"

  (pass-if "bytevector"
    (let ((bv #vu8(0 1 128 255)))
      (equal? bv (uniform-array->bytevector bv))))

  (pass-if "empty bitvector"
    (let ((bv (uniform-array->bytevector (make-bitvector 0))))
      (equal? bv #vu8())))

  (pass-if "bitvector < 8"
    (let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
      (= (bytevector-length bv) 1)))

  (pass-if "bitvector == 8"
    (let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
      (= (bytevector-length bv) 1)))

  (pass-if "bitvector > 8"
    (let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
      (= (bytevector-length bv) 2))))


code:
;;;; c-api.test --- complementary test suite for the c-api     -*- scheme -*-
;;;; MDJ 990915 <djurfeldt@nada.kth.se>
;;;;
;;;; 	Copyright (C) 1999, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define srcdir (cdr (assq 'srcdir %guile-build-info)))

(define (egrep string filename)
  (zero? (system (string-append "egrep '" string "' " filename " >/dev/null"))))

(define (seek-offset-test dirname)
  (let ((dir (opendir dirname)))
    (do ((filename (readdir dir) (readdir dir)))
	((eof-object? filename))
      (if (and
	   (eqv? (string-ref filename (- (string-length filename) 1)) #\c)
	   (eqv? (string-ref filename (- (string-length filename) 2)) #\.))
	  (let ((file (string-append dirname "/" filename)))
	    (if (and (file-exists? file)
		     (egrep "SEEK_(SET|CUR|END)" file)
		     (not (egrep "unistd.h" file)))
		(fail file)))))))

;;; A rough conservative test to check that all source files
;;; which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h.
;;;
;;; If this test start to trigger without reason, we just modify it
;;; to be more precise.
(with-test-prefix "SEEK_XXX => #include <unistd.h>"
  (if (file-exists? srcdir)
      (seek-offset-test srcdir)))


code:
;;;; chars.test --- test suite for Guile's char functions    -*- scheme -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
;;;; 	Copyright (C) 2000, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(use-modules (test-suite lib))

(define exception:wrong-type-to-apply
  (cons 'misc-error "^Wrong type to apply:"))

(define exception:unknown-character-name
  (cons #t "unknown character"))

(define exception:out-of-range-octal
  (cons #t "out-of-range"))

(with-test-prefix "basic char handling"

  (with-test-prefix "evaluator"

    ;; The following test makes sure that the evaluator distinguishes between
    ;; evaluator-internal instruction codes and characters.
    (pass-if-exception "evaluating chars"
      exception:wrong-type-arg
      (eval '(#\0) (interaction-environment))))

  (with-test-prefix "comparisons"

    ;; char=?
    (pass-if "char=? #\\A #\\A"
      (char=? #\A #\A))

    (expect-fail "char=? #\\A #\\a"
      (char=? #\A #\a))

    (expect-fail "char=? #\\A #\\B"
      (char=? #\A #\B))

    (expect-fail "char=? #\\B #\\A"
      (char=? #\A #\B))

    ;; char<?
    (expect-fail "char<? #\\A #\\A"
      (char<? #\A #\A))

    (pass-if "char<? #\\A #\\a"
      (char<? #\A #\a))

    (pass-if "char<? #\\A #\\B"
      (char<? #\A #\B))

    (expect-fail "char<? #\\B #\\A"
      (char<? #\B #\A))

    ;; char<=?
    (pass-if "char<=? #\\A #\\A"
      (char<=? #\A #\A))

    (pass-if "char<=? #\\A #\\a"
      (char<=? #\A #\a))

    (pass-if "char<=? #\\A #\\B"
      (char<=? #\A #\B))

    (expect-fail "char<=? #\\B #\\A"
      (char<=? #\B #\A))

    ;; char>?
    (expect-fail "char>? #\\A #\\A"
      (char>? #\A #\A))

    (expect-fail "char>? #\\A #\\a"
      (char>? #\A #\a))

    (expect-fail "char>? #\\A #\\B"
      (char>? #\A #\B))

    (pass-if "char>? #\\B #\\A"
      (char>? #\B #\A))

    ;; char>=?
    (pass-if "char>=? #\\A #\\A"
      (char>=? #\A #\A))

    (expect-fail "char>=? #\\A #\\a"
      (char>=? #\A #\a))

    (expect-fail "char>=? #\\A #\\B"
      (char>=? #\A #\B))

    (pass-if "char>=? #\\B #\\A"
      (char>=? #\B #\A))

    ;; char-ci=?
    (pass-if "char-ci=? #\\A #\\A"
      (char-ci=? #\A #\A))

    (pass-if "char-ci=? #\\A #\\a"
      (char-ci=? #\A #\a))

    (expect-fail "char-ci=? #\\A #\\B"
      (char-ci=? #\A #\B))

    (expect-fail "char-ci=? #\\B #\\A"
      (char-ci=? #\A #\B))

    ;; char-ci<?
    (expect-fail "char-ci<? #\\A #\\A"
      (char-ci<? #\A #\A))

    (expect-fail "char-ci<? #\\A #\\a"
      (char-ci<? #\A #\a))

    (pass-if "char-ci<? #\\A #\\B"
      (char-ci<? #\A #\B))

    (expect-fail "char-ci<? #\\B #\\A"
      (char-ci<? #\B #\A))

    ;; char-ci<=?
    (pass-if "char-ci<=? #\\A #\\A"
      (char-ci<=? #\A #\A))

    (pass-if "char-ci<=? #\\A #\\a"
      (char-ci<=? #\A #\a))

    (pass-if "char-ci<=? #\\A #\\B"
      (char-ci<=? #\A #\B))

    (expect-fail "char-ci<=? #\\B #\\A"
      (char-ci<=? #\B #\A))

    ;; char-ci>?
    (expect-fail "char-ci>? #\\A #\\A"
      (char-ci>? #\A #\A))

    (expect-fail "char-ci>? #\\A #\\a"
      (char-ci>? #\A #\a))

    (expect-fail "char-ci>? #\\A #\\B"
      (char-ci>? #\A #\B))

    (pass-if "char-ci>? #\\B #\\A"
      (char-ci>? #\B #\A))

    ;; char-ci>=?
    (pass-if "char-ci>=? #\\A #\\A"
      (char-ci>=? #\A #\A))

    (pass-if "char-ci>=? #\\A #\\a"
      (char-ci>=? #\A #\a))

    (expect-fail "char-ci>=? #\\A #\\B"
      (char-ci>=? #\A #\B))

    (pass-if "char-ci>=? #\\B #\\A"
      (char-ci>=? #\B #\A)))

  (with-test-prefix "categories"

    (pass-if "char-alphabetic?"
      (and (char-alphabetic? #\a)
           (char-alphabetic? #\A)
           (not (char-alphabetic? #\1))
           (not (char-alphabetic? #\+))))

    (pass-if "char-numeric?"
      (and (not (char-numeric? #\a))
           (not (char-numeric? #\A))
           (char-numeric? #\1)
           (not (char-numeric? #\+))))

    (pass-if "char-whitespace?"
      (and (not (char-whitespace? #\a))
           (not (char-whitespace? #\A))
           (not (char-whitespace? #\1))
           (char-whitespace? #\space)
           (not (char-whitespace? #\+))))

    (pass-if "char-upper-case?"
      (and (not (char-upper-case? #\a))
           (char-upper-case? #\A)
           (not (char-upper-case? #\1))
           (not (char-upper-case? #\+))))

    (pass-if "char-lower-case?"
      (and (char-lower-case? #\a)
           (not (char-lower-case? #\A))
           (not (char-lower-case? #\1))
           (not (char-lower-case? #\+))))

    (pass-if "char-is-both? works"
      (and
       (not (char-is-both? #\?))
       (not (char-is-both? #\newline))
       (char-is-both? #\a)
       (char-is-both? #\Z)
       (not (char-is-both? #\1))))

    (pass-if "char-general-category"
      (and (eq? (char-general-category #\a) 'Ll)
	   (eq? (char-general-category #\A) 'Lu)
	   (eq? (char-general-category #\762) 'Lt))))

  (with-test-prefix "integer"

    (pass-if "char->integer"
      (eqv? (char->integer #\A) 65))

    (pass-if "integer->char"
      (eqv? (integer->char 65) #\A))

    (pass-if-exception "integer->char out of range, -1" exception:out-of-range
      (integer->char -1))

    (pass-if-exception "integer->char out of range, surrrogate"
                       exception:out-of-range
      (integer->char #xd800))

    (pass-if-exception "integer->char out of range, too big"
                       exception:out-of-range
      (integer->char #x110000))

    (pass-if-exception "octal out of range, surrrogate"
                       exception:out-of-range-octal
      (with-input-from-string "#\\154000" read))

    (pass-if-exception "octal out of range, too big"
                       exception:out-of-range-octal
      (with-input-from-string "#\\4200000" read)))

  (with-test-prefix "case"

    (pass-if "char-upcase"
      (eqv? (char-upcase #\a) #\A))

    (pass-if "char-downcase"
      (eqv? (char-downcase #\A) #\a))

    (pass-if "char-titlecase"
      (and (eqv? (char-titlecase #\a) #\A)
           (eqv? (char-titlecase #\763) #\762))))

  (with-test-prefix "charnames"

    (pass-if "R5RS character names"
      (and (eqv? #\space (integer->char #x20))
           (eqv? #\newline (integer->char #x0A))))

    (pass-if "R6RS character names"
      (and (eqv? #\nul (integer->char #x00))
           (eqv? #\alarm (integer->char #x07))
           (eqv? #\backspace (integer->char #x08))
           (eqv? #\tab (integer->char #x09))
           (eqv? #\linefeed (integer->char #x0A))
           (eqv? #\newline (integer->char #x0A))
           (eqv? #\vtab (integer->char #x0B))
           (eqv? #\page (integer->char #x0C))
           (eqv? #\return (integer->char #x0D))
           (eqv? #\esc (integer->char #x1B))
           (eqv? #\space (integer->char #x20))
           (eqv? #\delete (integer->char #x7F))))

    (pass-if "R5RS character names are case insensitive"
      (and (eqv? #\space #\ )
           (eqv? #\SPACE #\ )
           (eqv? #\Space #\ )
           (eqv? #\newline (integer->char 10))
           (eqv? #\NEWLINE (integer->char 10))
           (eqv? #\Newline (integer->char 10))))

    (pass-if "C0 control names are case insensitive"
      (and (eqv? #\nul #\000)
           (eqv? #\soh #\001)
           (eqv? #\stx #\002)
           (eqv? #\NUL #\000)
           (eqv? #\SOH #\001)
           (eqv? #\STX #\002)
           (eqv? #\Nul #\000)
           (eqv? #\Soh #\001)
           (eqv? #\Stx #\002)))

    (pass-if "alt charnames are case insensitive"
      (eqv? #\null #\nul)
      (eqv? #\NULL #\nul)
      (eqv? #\Null #\nul))

    (pass-if-exception "bad charname" exception:unknown-character-name
      (with-input-from-string "#\\blammo" read))

    (pass-if "R5RS character names are preferred write format"
      (string=?
       (with-output-to-string (lambda () (write #\space)))
       "#\\space"))

    (pass-if "C0 control character names are preferred write format"
      (string=?
       (with-output-to-string (lambda () (write #\soh)))
       "#\\soh"))))


code:
;;;; common-list.test --- tests guile's common list functions -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-common-list)
  #:use-module (test-suite lib)
  #:use-module (ice-9 documentation)
  #:use-module (ice-9 common-list))

;;;
;;; miscellaneous
;;;

(define (documented? object)
  (not (not (object-documentation object))))

;;;
;;; intersection
;;;

(with-test-prefix "intersection"

  (pass-if "documented?"
    (documented? intersection))

  (pass-if "both arguments empty"
    (eq? (intersection '() '()) '()))

  (pass-if "first argument empty"
    (eq? (intersection '() '(1)) '()))

  (pass-if "second argument empty"
    (eq? (intersection '(1) '()) '()))

  (pass-if "disjoint arguments"
    (eq? (intersection '(1) '(2)) '()))

  (pass-if "equal arguments"
    (equal? (intersection '(1) '(1)) '(1)))

  (pass-if "reverse argument order"
    (equal? (intersection '(1 2 3) '(3 2 1)) '(1 2 3)))

  (pass-if "multiple matches in first list"
    (equal? (intersection '(1 1 2 2 3) '(3 2 1)) '(1 1 2 2 3)))

  (pass-if "multiple matches in second list"
    (equal? (intersection '(1 2 3) '(3 3 2 2 1)) '(1 2 3)))

  (pass-if "mixed arguments"
    (equal? (intersection '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(1 3 7 8)))

  )

;;;
;;; set-difference
;;;

(with-test-prefix "set-difference"

  (pass-if "documented?"
    (documented? set-difference))

  (pass-if "both arguments empty"
    (eq? (set-difference '() '()) '()))

  (pass-if "first argument empty"
    (eq? (set-difference '() '(1)) '()))

  (pass-if "second argument empty"
    (equal? (set-difference '(1) '()) '(1)))

  (pass-if "disjoint arguments"
    (equal? (set-difference '(1) '(2)) '(1)))

  (pass-if "equal arguments"
    (eq? (set-difference '(1) '(1)) '()))

  (pass-if "reverse argument order"
    (eq? (set-difference '(1 2 3) '(3 2 1)) '()))

  (pass-if "multiple matches in first list"
    (eq? (set-difference '(1 1 2 2 3) '(3 2 1)) '()))

  (pass-if "multiple matches in second list"
    (eq? (set-difference '(1 2 3) '(3 3 2 2 1)) '()))

  (pass-if "mixed arguments"
    (equal? (set-difference '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(2 5 10)))

  )

;;;
;;; remove-if
;;;

(with-test-prefix "remove-if"

  (pass-if "documented?"
    (documented? remove-if))

  (pass-if "empty list, remove all"
    (eq? (remove-if (lambda (x) #t) '()) '()))

  (pass-if "empty list, remove none"
    (eq? (remove-if (lambda (x) #f) '()) '()))

  (pass-if "non-empty list, remove all"
    (eq? (remove-if (lambda (x) #t) '(1 2 3 4)) '()))

  (pass-if "non-empty list, remove none"
    (equal? (remove-if (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4)))

  (pass-if "non-empty list, remove some"
    (equal? (remove-if odd? '(1 2 3 4)) '(2 4)))

  )

;;;
;;; remove-if-not
;;;

(with-test-prefix "remove-if-not"

  (pass-if "documented?"
    (documented? remove-if-not))

  (pass-if "empty list, remove all"
    (eq? (remove-if-not (lambda (x) #f) '()) '()))

  (pass-if "empty list, remove none"
    (eq? (remove-if-not (lambda (x) #t) '()) '()))

  (pass-if "non-empty list, remove all"
    (eq? (remove-if-not (lambda (x) #f) '(1 2 3 4)) '()))

  (pass-if "non-empty list, remove none"
    (equal? (remove-if-not (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4)))

  (pass-if "non-empty list, remove some"
    (equal? (remove-if-not odd? '(1 2 3 4)) '(1 3)))

  )

;;;
;;; delete-if!
;;;

(with-test-prefix "delete-if!"

  (pass-if "documented?"
    (documented? delete-if!))

  (pass-if "empty list, remove all"
    (eq? (delete-if! (lambda (x) #t) '()) '()))

  (pass-if "empty list, remove none"
    (eq? (delete-if! (lambda (x) #f) '()) '()))

  (pass-if "non-empty list, remove all"
    (eq? (delete-if! (lambda (x) #t) '(1 2 3 4)) '()))

  (pass-if "non-empty list, remove none"
    (equal? (delete-if! (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4)))

  (pass-if "non-empty list, remove some"
    (equal? (delete-if! odd? '(1 2 3 4)) '(2 4)))

  )

;;;
;;; delete-if-not!
;;;

(with-test-prefix "delete-if-not!"

  (pass-if "documented?"
    (documented? delete-if-not!))

  (pass-if "empty list, remove all"
    (eq? (delete-if-not! (lambda (x) #f) '()) '()))

  (pass-if "empty list, remove none"
    (eq? (delete-if-not! (lambda (x) #t) '()) '()))

  (pass-if "non-empty list, remove all"
    (eq? (delete-if-not! (lambda (x) #f) '(1 2 3 4)) '()))

  (pass-if "non-empty list, remove none"
    (equal? (delete-if-not! (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4)))

  (pass-if "non-empty list, remove some"
    (equal? (delete-if-not! odd? '(1 2 3 4)) '(1 3)))

  )


code:
;;;; compiler.test --- tests for the compiler      -*- scheme -*-
;;;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite tests compiler)
  #:use-module (test-suite lib)
  #:use-module (test-suite guile-test)
  #:use-module (system base compile)
  #:use-module ((system vm vm) #:select (the-vm vm-load))
  #:use-module ((system vm program) #:select (program-sources source:addr)))

(define read-and-compile
  (@@ (system base compile) read-and-compile))

(with-test-prefix "basic"

  (pass-if "compile to value"
    (equal? (compile 1) 1)))

(with-test-prefix "psyntax"

  (pass-if "compile uses a fresh module by default"
    (begin
      (compile '(define + -))
      (eq? (compile '+) +)))

  (pass-if "compile-time definitions are isolated"
    (begin
      (compile '(define foo-bar #t))
      (not (module-variable (current-module) 'foo-bar))))

  (pass-if "compile in current module"
    (let ((o (begin
               (compile '(define-macro (foo) 'bar)
                        #:env (current-module))
               (compile '(let ((bar 'ok)) (foo))
                        #:env (current-module)))))
      (and (macro? (module-ref (current-module) 'foo))
           (eq? o 'ok))))

  (pass-if "compile in fresh module"
    (let* ((m  (let ((m (make-module)))
                 (beautify-user-module! m)
                 m))
           (o  (begin
                 (compile '(define-macro (foo) 'bar) #:env m)
                 (compile '(let ((bar 'ok)) (foo)) #:env m))))
      (and (module-ref m 'foo)
           (eq? o 'ok))))

  (pass-if "redefinition"
    ;; In this case the locally-bound `round' must have the same value as the
    ;; imported `round'.  See the same test in `syntax.test' for details.
    (let ((m (make-module)))
      (beautify-user-module! m)
      (compile '(define round round) #:env m)
      (eq? round (module-ref m 'round)))))

(with-test-prefix "current-reader"

  (pass-if "default compile-time current-reader differs"
    (not (eq? (compile 'current-reader)
              current-reader)))

  (pass-if "compile-time changes are honored and isolated"
    ;; Make sure changing `current-reader' as the side-effect of a defmacro
    ;; actually works.
    (let ((r     (fluid-ref current-reader))
          (input (open-input-string
                  "(define-macro (install-reader!)
                     ;;(format #t \"current-reader = ~A~%\" current-reader)
                     (fluid-set! current-reader
                                 (let ((first? #t))
                                   (lambda args
                                     (if first?
                                         (begin
                                           (set! first? #f)
                                           ''ok)
                                         (read (open-input-string \"\"))))))
                     #f)
                   (install-reader!)
                   this-should-be-ignored")))
      (and (eq? (vm-load (the-vm) (read-and-compile input))
                'ok)
           (eq? r (fluid-ref current-reader)))))

  (pass-if "with eval-when"
    (let ((r (fluid-ref current-reader)))
      (compile '(eval-when (compile eval)
                  (fluid-set! current-reader (lambda args 'chbouib))))
      (eq? (fluid-ref current-reader) r))))

(with-test-prefix "procedure-name"

  (pass-if "program"
    (let ((m  (make-module)))
      (beautify-user-module! m)
      (compile '(define (foo x) x) #:env m)
      (eq? (procedure-name (module-ref m 'foo)) 'foo)))

  (pass-if "program with lambda"
    (let ((m  (make-module)))
      (beautify-user-module! m)
      (compile '(define foo (lambda (x) x)) #:env m)
      (eq? (procedure-name (module-ref m 'foo)) 'foo)))

  (pass-if "subr"
    (eq? (procedure-name waitpid) 'waitpid)))

(with-test-prefix "program-sources"

  (with-test-prefix "source info associated with IP 0"

    ;; Tools like `(system vm coverage)' like it when source info is associated
    ;; with IP 0 of a VM program, which corresponds to the entry point.  See
    ;; also <http://savannah.gnu.org/bugs/?29817> for details.

    (pass-if "lambda"
      (let ((s (program-sources (compile '(lambda (x) x)))))
        (not (not (memv 0 (map source:addr s))))))

    (pass-if "lambda*"
      (let ((s (program-sources
                (compile '(lambda* (x #:optional y) x)))))
        (not (not (memv 0 (map source:addr s))))))

    (pass-if "case-lambda"
      (let ((s (program-sources
                (compile '(case-lambda (()    #t)
                                       ((y)   y)
                                       ((y z) (list y z)))))))
        (not (not (memv 0 (map source:addr s))))))))


code:
;;;;                                                          -*- scheme -*-
;;;; continuations.test --- test suite for continutations
;;;;
;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-continuations)
  :use-module (test-suite lib))

(define (block-reentry body)
  (let ((active #f))
    (dynamic-wind
	(lambda ()
	  (if active
	      (throw 'no-reentry)))
	(lambda ()
	  (set! active #t)
	  (body))
	(lambda () #f))))

(define (catch-tag body)
  (catch #t
	 body
	 (lambda (tag . args) tag)))

(define (check-cont)
  (catch-tag
   (lambda ()
     (block-reentry (lambda () (call/cc identity))))))

(define (dont-crash-please)
  (let ((k (check-cont)))
    (if (procedure? k)
	(k 12)
	k)))

(with-test-prefix "continuations"

  (pass-if "throwing to a rewound catch context"
    (eq? (dont-crash-please) 'no-reentry))

  (pass-if "can print a continuation"
    (let ((s (with-output-to-string
	       (lambda ()
		 (call-with-current-continuation write)))))
      (string=? "#<continuation " (substring s 0 15))))

  (pass-if "blocked attempt to cross a continuation barrier"
    (call-with-current-continuation
     (lambda (k)
       (with-continuation-barrier
	(lambda ()
	  (catch 'misc-error
		 (lambda ()
		   (k 1)
		   #f)
		 (lambda _
		   #t)))))))

  (pass-if "uncaught exception is handled by continuation barrier"
    (let* ((handled #f)
	   (s (with-error-to-string
	       (lambda ()
		 (set! handled
		       (not (with-continuation-barrier
			     (lambda ()
			       (error "Catch me if you can!")))))))))
      handled))

  (with-debugging-evaluator

    (pass-if "make a stack from a continuation"
      (stack? (call-with-current-continuation make-stack)))

    (pass-if "get a continuation's stack ID"
      (let ((id (call-with-current-continuation stack-id)))
	(or (boolean? id) (symbol? id)))))

)


code:
;;;;                                                          -*- scheme -*-
;;;; control.test --- test suite for delimited continuations
;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-control)
  #:use-module (ice-9 control)
  #:use-module (srfi srfi-11)
  #:use-module (test-suite lib))

;; For these, the compiler should be able to prove that "k" is not referenced,
;; so it avoids reifying the continuation. Since that's a slightly different
;; codepath, we test them both.
(with-test-prefix "escape-only continuations"
  (pass-if "no values, normal exit"
    (equal? '()
            (call-with-values
                (lambda ()
                  (% (values)
                     (lambda (k . args)
                       (error "unexpected exit" args))))
              list)))

  (pass-if "no values, abnormal exit"
    (equal? '()
            (% (begin
                 (abort)
                 (error "unexpected exit"))
               (lambda (k . args)
                 args))))

  (pass-if "single value, normal exit"
    (equal? '(foo)
            (call-with-values
                (lambda ()
                  (% 'foo
                     (lambda (k . args)
                       (error "unexpected exit" args))))
              list)))

  (pass-if "single value, abnormal exit"
    (equal? '(foo)
            (% (begin
                 (abort 'foo)
                 (error "unexpected exit"))
               (lambda (k . args)
                 args))))

  (pass-if "multiple values, normal exit"
    (equal? '(foo bar baz)
            (call-with-values
                (lambda ()
                  (% (values 'foo 'bar 'baz)
                     (lambda (k . args)
                       (error "unexpected exit" args))))
              list)))

  (pass-if "multiple values, abnormal exit"
    (equal? '(foo bar baz)
            (% (begin
                 (abort 'foo 'bar 'baz)
                 (error "unexpected exit"))
               (lambda (k . args)
                 args)))))

;;; And the case in which the compiler has to reify the continuation.
(with-test-prefix "reified continuations"
  (pass-if "no values, normal exit"
    (equal? '()
            (call-with-values
                (lambda ()
                  (% (values)
                     (lambda (k . args)
                       (error "unexpected exit" k args))))
              list)))

  (pass-if "no values, abnormal exit"
    (equal? '()
            (cdr
             (% (begin
                  (abort)
                  (error "unexpected exit"))
                (lambda args
                  args)))))

  (pass-if "single value, normal exit"
    (equal? '(foo)
            (call-with-values
                (lambda ()
                  (% 'foo
                     (lambda (k . args)
                       (error "unexpected exit" k args))))
              list)))

  (pass-if "single value, abnormal exit"
    (equal? '(foo)
            (cdr
             (% (begin
                  (abort 'foo)
                  (error "unexpected exit"))
                (lambda args
                  args)))))

  (pass-if "multiple values, normal exit"
    (equal? '(foo bar baz)
            (call-with-values
                (lambda ()
                  (% (values 'foo 'bar 'baz)
                     (lambda (k . args)
                       (error "unexpected exit" k args))))
              list)))

  (pass-if "multiple values, abnormal exit"
    (equal? '(foo bar baz)
            (cdr
             (% (begin
                  (abort 'foo 'bar 'baz)
                  (error "unexpected exit"))
                (lambda args
                  args))))))

;; The variants check different cases in the compiler.
(with-test-prefix "restarting partial continuations"
  (pass-if "in side-effect position"
    (let ((k (% (begin (abort) 'foo)
                (lambda (k) k))))
      (eq? (k)
           'foo)))

  (pass-if "passing values to side-effect abort"
    (let ((k (% (begin (abort) 'foo)
                (lambda (k) k))))
      (eq? (k 'qux 'baz 'hello)
           'foo)))

  (pass-if "called for one value"
    (let ((k (% (+ (abort) 3)
                (lambda (k) k))))
      (eqv? (k 39)
            42)))

  (pass-if "called for multiple values"
    (let ((k (% (let-values (((a b . c) (abort)))
                  (list a b c))
                (lambda (k) k))))
      (equal? (k 1 2 3 4)
              '(1 2 (3 4)))))

  (pass-if "in tail position"
    (let ((k (% (abort)
                (lambda (k) k))))
      (eq? (k 'xyzzy)
           'xyzzy))))

(define fl (make-fluid))
(fluid-set! fl 0)

(with-test-prefix "suspend/resume with fluids"
  (pass-if "normal"
    (zero? (% (fluid-ref fl)
              error)))
  (pass-if "with-fluids normal"
    (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
                (fluid-ref fl))
              error)
            1))
  (pass-if "normal (post)"
    (zero? (fluid-ref fl)))
  (pass-if "with-fluids and fluid-set!"
    (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
                 (fluid-set! fl (1+ (fluid-ref fl)))
                 (fluid-ref fl))
               error)
            2))
  (pass-if "normal (post2)"
    (zero? (fluid-ref fl)))
  (pass-if "normal fluid-set!"
    (equal? (begin
              (fluid-set! fl (1+ (fluid-ref fl)))
              (fluid-ref fl))
            1))
  (pass-if "reset fluid-set!"
    (equal? (begin
              (fluid-set! fl (1- (fluid-ref fl)))
              (fluid-ref fl))
            0))

  (let ((k (% (with-fluids ((fl (1+ (fluid-ref fl))))
                (abort)
                (fluid-ref fl))
              (lambda (k) k))))
    (pass-if "pre"
      (equal? (fluid-ref fl) 0))
    (pass-if "res"
      (equal? (k) 1))
    (pass-if "post"
      (equal? (fluid-ref fl) 0))))

(with-test-prefix "rewinding prompts"
  (pass-if "nested prompts"
    (let ((k (% 'a
                (% 'b
                   (begin
                     (abort-to-prompt 'a)
                     (abort-to-prompt 'b #t))
                   (lambda (k x) x))
                (lambda (k) k))))
      (k))))

(with-test-prefix "abort to unknown prompt"
  (pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
                     (abort-to-prompt 'does-not-exist)))