;;;;                                                    -*- coding: utf-8 -*-
;;;;
;;;; test-r7rs.stk      -- Testing R7RS constructs/primitives
;;;;
;;;; Copyright © 2011-2022 Erick Gallesio - Polytech Nice Sophia <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 17-Apr-2011 20:58 (eg)
;;;;

(require "test")

(test-section "R7RS")

(test-subsection "4.2 Derived expression types")

(test "R7RS cond.1"
      'greater
      (cond ((> 3 2) 'greater)
            ((< 3 2) 'less)))

(test "R7RS cond.2"
      'equal
      (cond ((> 3 3) 'greater)
            ((< 3 3) 'less)
            (else 'equal)))

(test "R7RS cond.3"
      2
      (cond ((assv 'b '((a 1) (b 2))) => cadr)
            (else #f)))

(test "R7RS case.1"
      'composite
      (case (* 2 3)
        ((2 3 5 7) 'prime)
        ((1 4 6 8 9) 'composite)))


(test "R7RS case.2"
      'c
      (case (car '(c d))
        ((a e i o u) 'vowel)
        ((w y) 'semivowel)
        (else => (lambda (x) x))))


(test "Chibi case"
      #t
      (equal?
       '((other . z) (semivowel . y) (other . x)
         (semivowel . w) (vowel . u))
       (map (lambda (x)
             (case x
               ((a e i o u) => (lambda (w) (cons 'vowel w)))
               ((w y) (cons 'semivowel x))
               (else => (lambda (w) (cons 'other w)))))
           '(z y x w u))))

(test "R7RS and.1" #t           (and (= 2 2) (> 2 1)))
(test "R7RS and.2" #f           (and (= 2 2) (< 2 1)))
(test "R7RS and.3" '(f g)       (and 1 2 'c '(f g)))
(test "R7RS and.4" #t           (and))

(test "or"        #f            (or))
(test "R7RS or.1" #t            (or (= 2 2) (> 2 1)))
(test "R7RS or.1" #t            (or (= 2 2) (< 2 1)))
(test "R7RS or.1" #f            (or #f #f #f))
                                ;; (/ 3 0) produce an error during compilation
                                ;; => test rewritten
(test "R7RS or.1" '(b c)        (let ((zero 0))
                                  (or (memq 'b '(a b c)) (/ 3 zero))))

(test "when" "12" (call-with-output-string (lambda(port)
                                             (when (= 1 1.0)
                                               (display "1" port)
                                               (display "2" port)))))
(test "unless" "" (call-with-output-string (lambda(port)
                                             (unless (= 1 1.0)
                                               (display "1" port)
                                               (display "2" port)))))

;;;
;;; 4.2.2 BINDING CONSTRUCTS
;;;
(test "let.1" 6 (let ((x 2) (y 3))
                  (* x y)))
(test "let.2" 35 (let ((x 2) (y 3))
                   (let ((x 7)
                         (z (+ x y)))
                     (* z x))))
(test "let.3" 10 (let () 10))
(test "let.4" 20 (let ((x (let ((y 20))
                            y)))
                   x))

(test/compile-error "ill-formed let.1"
                    (let 1 2))
(test/compile-error "ill-formed let.2"
                    (let "abc" 2))
(test/compile-error "ill-formed let.3"
                    (let #void 1))
(test/compile-error "ill-formed let.4"
                    (let))
(test/compile-error "ill-formed let.5"
                    (let ((a) 1)))
(test/compile-error "ill-formed let.6"
                    (let (() 1)))


(test "let*" 70 (let ((x 2) (y 3))
                  (let* ((x 7)
                         (z (+ x y)))
                    (* z x)))  )
(test/compile-error "ill-formed let*.1"
                    (let* 1 2))
(test/compile-error "ill-formed let*.2"
                    (let* "abc" 2))
(test/compile-error "ill-formed let*.3"
                    (let* #void 1))
(test/compile-error "ill-formed let*.4"
                    (let*))
(test/compile-error "ill-formed let*.5"
                    (let* ((a) 1)))
(test/compile-error "ill-formed let*.6"
                    (let* (() 1)))

(test "letrec" '(#t #f) (letrec ((even?
                                  (lambda (n)
                                    (if (zero? n)
                                        #t
                                        (odd? (- n 1)))))
                                 (odd?
                                  (lambda (n)
                                    (if (zero? n)
                                        #f
                                        (even? (- n 1))))))
                          (list (even? 88) (odd? 88))))
(test/compile-error "ill-formed letrec.1"
                    (letrec 1 2))
(test/compile-error "ill-formed letrec.2"
                    (letrec "abc" 2))
(test/compile-error "ill-formed letrec.3"
                    (letrec #void 1))
(test/compile-error "ill-formed letrec.4"
                    (letrec))
(test/compile-error "ill-formed letrec.5"
                    (letrec ((a) 1)))
(test/compile-error "ill-formed letrec.6"
                    (letrec (() 1)))

(test "letrec*" 5 (letrec* ((p
                             (lambda (x)
                               (+ 1 (q (- x 1)))))
                            (q
                             (lambda (y)
                               (if (zero? y)
                                   0
                                   (+ 1 (p (- y 1))))))
                            (x (p 5))
                            (y x))
                    y))
(test/compile-error "ill-formed letrec*.1"
                    (letrec* 1 2))
(test/compile-error "ill-formed letrec*.2"
                    (letrec* "abc" 2))
(test/compile-error "ill-formed letrec*.3"
                    (letrec* #void 1))
(test/compile-error "ill-formed letrec*.4"
                    (letrec*))
(test/compile-error "ill-formed letrec*.5"
                    (letrec* ((a) 1)))
(test/compile-error "ill-formed letrec*.6"
                    (letrec* (() 1)))

;;;
;;; let-values
;;;
(test "let-values.1" 35
      (let-values (((root rem) (exact-integer-sqrt 32)))
        (* root rem)))
(test "let-values.2" '(3 2 1)
      (let-values (((a b c) (values 1 2 3)))
        (list c b a)))
(test "let-values.3" '((3 4) 2 1)
      (let-values (((a b . c) (values 1 2 3 4)))
        (list c b a)))
(test "let-values.4" '(() 2 1)
      (let-values (((a b . c) (values 1 2)))
        (list c b a)))
(test "let-values.5"
      '(x y a b)
      (let ((a 'a) (b 'b) (x 'x) (y 'y))
        (let-values (((a b) (values x y))
                     ((x y) (values a b)))
          (list a b x y))))
(test "let-values.6"
      1
      (let-values () 1))
(test "let-values.7"   ;; Issue #257
      '(1 2 3)
      (let-values ((x (values 1 2 3)))
        x))
(test "let-values.8"
      '((1 2 3) 100)
      (let ((x 100))
        (let-values ((x (values 1 2 3))
                     (y x))
          (cons x y))))
;;;; ----------
(test "let*-values.1" 35
      (let*-values (((root rem) (exact-integer-sqrt 32)))
        (* root rem)))
(test "let*-values.2" '(3 2 1)
      (let*-values (((a b c) (values 1 2 3)))
        (list c b a)))
(test "let*-values.3" '((3 4) 2 1)
      (let*-values (((a b . c) (values 1 2 3 4)))
        (list c b a)))
(test "let*-values.4" '(() 2 1)
      (let*-values (((a b . c) (values 1 2)))
        (list c b a)))
(test "let*-values.5"
      '(x y x y)
      (let ((a 'a) (b 'b) (x 'x) (y 'y))
        (let*-values (((a b) (values x y))
                      ((x y) (values a b)))
          (list a b x y))))
(test "let*-values.6"
      1
      (let*-values () 1))
(test "let*-values.7" 'out
      (let ((x 'out))
        (let*-values ()
          (define x 'in)
          x)
        x))
(test "let*-values.8"
      '((1 2 3) 4 5 6)
      (let*-values ((x (values 1 2 3))
                    (y (values 4 5 6)))
        (cons x y)))
(test "let*-values.9"
      '(#0=(1 2 3) #0#)
      (let*-values ((x (values 1 2 3))
                    (y x))
        (cons x y)))



;;;
;;; 4.2.3 ITERATION
;;;
(test "do.1"
      #(0 1 2 3 4)
      (do ((vec (make-vector 5))
           (i 0 (+ i 1)))
          ((= i 5) vec)
        (vector-set! vec i i)))
(test "do.2"
      25
      (let ((x '(1 3 5 7 9)))
        (do ((x x (cdr x))
             (sum 0 (+ sum (car x))))
            ((null? x)
             sum))))
(test "named-let"
      '((6 1 3) (-5 -2))
      (let loop ((numbers '(3 -2 1 6 -5))
                 (nonneg '())
                 (neg '()))
        (cond ((null? numbers) (list nonneg neg))
              ((>= (car numbers) 0)
               (loop (cdr numbers)
                     (cons (car numbers) nonneg)
                     neg))
              ((< (car numbers) 0)
               (loop (cdr numbers)
                     nonneg
                     (cons (car numbers) neg))))))

;;;
;;; 4.2.5 DELAYED EVALUATION
;;;

(test "force.1" 3 (force (delay (+ 1 2))))
(test "force.2" '(3 3)
      (let ((p (delay (+ 1 2))))
        (list (force p) (force p))))

(let ()
  (define head (lambda (stream) (car (force stream))))
  (define tail (lambda (stream) (cdr (force stream))))
  (define integers
    (letrec ((next (lambda (n)
                     (delay (cons n (next (+ n 1)))))))
      (next 0)))

  (test "force.3"
        2
        (head (tail (tail integers))))

  (test "force.4"
        5
        (let ()
          (define (stream-filter p? s)
            (delay-force
             (if (null? (force s))
                 (delay '())
                 (let ((h (car (force s)))
                       (t (cdr (force s))))
                   (if (p? h)
                       (delay (cons h (stream-filter p? t)))
                       (stream-filter p? t))))))
          (head (tail (tail (stream-filter odd? integers)))))))

(let ()
  (define count 0)
  (define p (delay (begin (set! count (+ count 1))
                          (if (> count x)
                              count
                              (force p)))))
  (define x 5)
  (test "promise?.1" #t (promise? p))
  (test "force.5"   6  (force p))
  (test "force.6" 6 (begin (set! x 10) (force p))))

(test "force.7" 100 (force 100))

(test "promise?.2" #t (promise? (delay (sqrt 100))))
(test "promise?.3" #t (promise? (make-promise (+ 2 2))))
(test "promise?.4" #t (let ((x (delay (+ 2 2))))
                        (force x)
                        (promise? x)))
(test "promise?.5" #t (let ((x (make-promise (+ 2 2))))
                        (force x)
                        (promise? x)))
(test "promise?.6" #f (promise? 'foo))
(test "promise?.7" #f (promise? (force (delay 100))))

;; Tests from the SRFI-45

(test "memoization.1"
      "hello"
      (let ((out ""))
        (define s (delay (begin (set! out (string-append out "hello")) 1)))
        (force s)
        (force s)
        out))

(test "memoization.2"
      '(4 . "bonjour")
      (let ((out ""))
        (define s (delay (begin (set! out (string-append out "bonjour")) 2)))
        (cons (+ (force s) (force s)) out)))

(test  "memoization.3"
        '("hi" 1 #f 1 #f)
        (let ((out ""))
          (define r (delay (begin (set! out (string-append out "hi")) 1)))
          (define s (make-promise r))
          (define t (make-promise s))
          (let* ((x (force t))
                 (y (force r)))
            (list out x (promise? x) y (promise? y)))))


(test "memoization.4"
      '("hohohohoho" 1 1)
      (let ()
        (define out "")

        (define (stream-drop s index)
          (make-promise
           (if (zero? index)
               s
               (stream-drop (cdr (force s)) (- index 1)))))

        (define (ones)
          (delay (begin
                   (set! out (string-append out "ho"))
                   (cons 1 (ones)))))

        (define s (ones))

        (let* ((x (car (force (stream-drop s 4))))
               (y (car (force (stream-drop s 4)))))
          (list out x y))))


(test "reentrancy.2"
      'second
      (let ()
        (define f
          (let ((first? #t))
            (delay
              (if first?
                  (begin
                    (set! first? #f)
                    (force f))
                  'second))))
        (force f)))

(test "reentrancy.3"
  '(5 0 10)
  (let ()
    (define q
      (let ((count 5))
        (define (get-count) count)
        (define p (delay (if (<= count 0)
                             count
                             (begin (set! count (- count 1))
                                    (force p)
                                    (set! count (+ count 2))
                                    count))))
      (list get-count p)))

    (define get-count (car q))
    (define p (cadr q))
    (let* ((a (get-count))
           (b (force p))
           (c (get-count)))
      (list a b c))))

;;;
;;; 4.2.6 DYNAMIC BINDINGS
;;;
(test "make-parameter.1"
      '(1 . 2)
      (let ((x (make-parameter 1)))
        (let* ((a (x))
               (_ (x 2))
               (b (x)))
          (cons a b))))
(test "make-parameter.2"
      '(1 . 100)
      (let ((x (make-parameter 1
                               (lambda (val) (min val 100)))))
        (let* ((a (x))
               (_ (x 5000))
               (b (x)))
          (cons a b))))

(test "make-parameter.3"
      '(#f . 5000)
      (let ((x (make-parameter "NO"
                               (lambda (val)
                                 (and (integer? val) val)))))
        (let* ((a (x))
               (_ (x 5000))
               (b (x)))
          (cons a b))))

(let ()
  (define radix (make-parameter 10
                                (lambda (x)
                                  (if (and (exact-integer? x) (<= 2 x 16))
                                      x
                                      "invalid radix"))))
  (define (f n) (number->string n (radix)))



  (test "parameterize.1"
        '("12" "1100" "12")
        (let* ((a (f 12))
               (b (parameterize ((radix 2))
                    (f 12)))
               (c (f 12)))
          (list a b c)))

  (test "parameterize.2"
        *test-failed*
        (begin
          (radix 16)
          (let* ((a (radix))
                 (b (parameterize ((radix 0))
                      (f 12)))
                 (c (f 12)))
            (list a b c)))))

;;;
;;; 4.2.7 EXCEPTION HANDLING
;;;

;; all tests are in 6.11 (Exceptions)

;;;
;;; 4.2.8 QUASIQUOTATION
;;;
(test "qq.1"
      '(list 3 4)
      `(list ,(+ 1 2) 4))

(test "qq.2"
      '(list a (quote a))
      (let ((name 'a))
        `(list ,name ',name)))

(test "qq.3"
      '(a 3 4 5 6 b)
      `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))

(test "qq.4"
       '((foo 7) . cons)
       `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))

(test "qq.5"
       #(10 5 2 4 3 8)
       `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))

(test "qq.6"
      ' (list foo bar baz)
        (let ((foo '(foo bar))
              (@baz 'baz))
          `(list ,@foo , @baz)))

(test "qq.7"
      '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
      `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))

(test "qq.8"
      '(a `(b ,x ,'y d) e)
      (let ((name1 'x)
            (name2 'y))
        `(a `(b ,,name1 ,',name2 d) e)))

(test "qq.9"
      '(list 3 4)
      (quasiquote (list (unquote (+ 1 2)) 4)))

(test "qq.10"
       '`(list ,(+ 1 2) 4)
       '(quasiquote (list (unquote (+ 1 2)) 4)))

;;;
;;; 4.2.9 CASE-LAMBDA
;;;

(let ()
  (define range
    (case-lambda
     ((e) (range 0 e))
     ((b e) (do ((r '() (cons e r))
                 (e (- e 1) (- e 1)))
                ((< e b) r)))))

  (test "case-lambda.1"
        '(0 1 2)
        (range 3))
  (test "case-lambda.2"
        '(3 4)
        (range 3 5)))

(let ()
  (define plus
    (case-lambda
     (() 0)
     ((x) x)
     ((x y) (+ x y))
     ((x y z) (+ (+ x y) z))
     (args (apply + args))))

  (test "case-lambda.3"
        0
        (plus))
  (test "case-lambda.4"
        1
        (plus 1))
  (test "case-lambda.5"
        6
        (plus 1 2 3))
  (test "case-lambda.6"
        10
        (plus 1 2 3 4)))

(test "case-lambda.7"
      *test-failed*
      ( (case-lambda
         ((a) a)
         ((a b) (* a b)))
       1 2 3))
;; ======================================================================

(test-subsection "5.3 Multiple-values definitions")

(test "define-values.1"
      '(4 1)
      (let ()
        (define-values (x y) (exact-integer-sqrt 17))
        (list x y)))

(test "define-values.2"
      '(#void)
      (let ()
        (list (define-values () (values 1 2 3)))))

(test "define-values.3"
    1
    (let ()
      (define-values (x) (values 1))
      x))

(test "define-values.4"
      3
      (let ()
        (define-values x (values 1 2))
        (apply + x)))

(test "define-values.5"
      3
      (let ()
        (define-values (x y) (values 1 2))
        (+ x y)))

(test "define-values.6"
      10
      (let ()
        (define-values (x y . z) (values 1 2 3 4))
        (apply + x y z)))

(test "define-values.7"
      '(1 (2 3))
      (let ()
        (define-values (x . y) (values 1 2 3))
        (list x y)))

;; ======================================================================

(test-subsection "6.1 Equivalence Predicates")

(test "eqv?.1" #t (eqv? 'a 'a))
(test "eqv?.2" #f (eqv? 'a 'b))
(test "eqv?.3" #t (eqv? 2 2))
(test "eqv?.4" #f (eqv? 2 2.0))
(test "eqv?.5" #t (eqv? '() '()))
(test "eqv?.6" #t (eqv? 100000000 100000000))
(test "eqv?.7" #f (eqv? 0.0 +nan.0))
(test "eqv?.8" #f (eqv? (cons 1 2) (cons 1 2)))
(test "eqv?.9" #f (eqv? (lambda () 1)
                        (lambda () 2)))
(test "eqv?.10" #t (let ((p (lambda (x) x)))
                     (eqv? p p)))
(test "eqv?.11" #f (eqv? #f 'nil))

(let ()
  (define gen-counter
    (lambda ()
      (let ((n 0))
        (lambda () (set! n (+ n 1)) n))))

  (define gen-loser
    (lambda ()
      (let ((n 0))
        (lambda () (set! n (+ n 1)) 27))))

  (test "gen-counter.1"  #t
        (let ((g (gen-counter)))
          (eqv? g g)))
  (test "gen-counter.2"  #f
        (eqv? (gen-counter) (gen-counter)))

  (test "gen-loser" #t
        (let ((g (gen-loser)))
          (eqv? g g))))

(test "eqv?12" #f
      (letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
               (g (lambda () (if (eqv? f g) 'g 'both))))
        (eqv? f g)))

(test "eq?.1" #t (eq? 'a 'a))
(test "eq?.2" #t (boolean? (eq? '(a) '(a))))
(test "eq?.3" #f (eq? (list 'a) (list 'a)))
(test "eq?.4" #t (boolean? (eq? "a" "a")))
(test "eq?.5" #t (boolean? (eq? "" "")))
(test "eq?.6" #t (eq? '() '()))
(test "eq?.7" #t (eq? 2 2))
(test "eq?.8" #t (eq? #\A #\A))
(test "eq?.9" #t (eq? car car))
(test "eq?.10" #t (let ((n (+ 2 3)))
                    (eq? n n)))
(test "eq?.11" #t (let ((x '(a)))
                    (eq? x x)))
(test "eq?.12" #t (let ((x '#()))
                    (eq? x x)))
(test "eq?.13" #t (let ((p (lambda (x) x)))
                    (eq? p p)))

(test "equal?.1" #t (equal? '(a (b) c)
                            '(a (b) c)))
(test "equal?.2" #t (equal? (make-vector 5 'a)
                            (make-vector 5 'a)))

(test "equal?.3" #t (equal? '#0=(a b . #0#)
                            '#1=(a b a b . #1#)))

(test "equal?.4" #f (equal? '#0=(a b a . #0#)
                            '#1=(a b a b . #1#)))

;; ----------------------------------------------------------------
(test-subsection "6.2 Numbers")

(test "exact-integer?.1" #t (exact-integer? 32))
(test "exact-integer?.2" #t (exact-integer? #e3.0))
(test "exact-integer?.3" #f (exact-integer? 32/5))

(test "finite?.1" #t (finite? 3))
(test "finite?.2" #f (finite? +inf.0))
(test "finite?.3" #f (finite? -inf.0))
(test "finite?.4" #f (finite? +nan.0))
(test "finite?.5" #f (finite? (make-rectangular 3.0 +inf.0)))

(test "infinite?.1" #f (infinite? 3))
(test "infinite?.2" #t (infinite? +inf.0))
(test "infinite?.3" #f (infinite? +nan.0))
(test "infinite?.4" #t (infinite? (make-rectangular 3.0 +inf.0)))

(test "nan?.1" #t (nan? +nan.0))
(test "nan?.2" #f (nan? 32))
(test "nan?.3" #t (nan? (make-rectangular +nan.0 5.0)))
(test "nan?.4" #f (nan? 1+2i))

(test "floor/.1" '( 2 .  1) (call-with-values (lambda() (floor/  5  2)) cons))
(test "floor/.2" '(-3 .  1) (call-with-values (lambda() (floor/ -5  2)) cons))
(test "floor/.3" '(-3 . -1) (call-with-values (lambda() (floor/  5 -2)) cons))
(test "floor/.4" '( 2 . -1) (call-with-values (lambda() (floor/ -5 -2)) cons))

(test "truncate/.1" '(   2 .  1)   (call-with-values (lambda() (truncate/  5  2)) cons))
(test "truncate/.2" '(  -2 . -1)   (call-with-values (lambda() (truncate/ -5  2)) cons))
(test "truncate/.3" '(  -2 .  1)   (call-with-values (lambda() (truncate/  5 -2)) cons))
(test "truncate/.4" '( 2.0 . -1.0) (call-with-values (lambda() (truncate/ -5.0 -2)) cons))

(test "square.1" 1764 (square 42))
(test "square.2" 4.0  (square 2.0))
(test "square.2" -1   (square +i))

(test "exact-integer-sqrt.1" '(2 0)  (receive (q r) (exact-integer-sqrt 4) (list q r)))
(test "exact-integer-sqrt.2" '(2 1)  (receive (q r) (exact-integer-sqrt 5) (list q r)))
(test "exact-integer-sqrt.3" '(33333333333333333333
                               22222222222222222222)
                              (receive (q r)
                                  (exact-integer-sqrt 1111111111111111111111111111111111111111)
                                (list q r))
                              equal?)

;; The following test case was failing because of a small glitch in the isqrt internal
;; function:
(test "exact-integer-sqrt.4"
      '(9999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999
        .
        19999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999998)
      (receive (root rem)
          (exact-integer-sqrt 99999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999)
        (cons root rem)))

;; -----------------------------------------------------------------
(test-subsection "6.3 Booleans")

(test "boolean=?.1" #t (boolean=? #true #t #t (= 2 2)))
(test "boolean=?.2" #f (boolean=? #true #t #t (= 2 2) #false))
(test "boolean=?.3" #t (boolean=? #t))
(test "boolean=?.4" #t (boolean=? #f))


;;------------------------------------------------------------------
(test-subsection "6.4 Pairs and lists")

(test "member with 3d parameter.1"
      '("b" "c")
      (member "B" '("a" "b" "c") string-ci=?))

(test "member with 3d parameter.2"
      '(2.0 3.0)
      (member 1.99 '(1.0 2.0 3.0) (lambda (x y) (< (abs (- x y)) 0.1))))

(test "member with 3d parameter.3"
      10
      (let ((final 0))
        ;; R7RS doesn't state anything about the comparator arguments order
        ;; Anyway, fix it to the one used by SRFI-1 to ensure maximum
        ;; compatibility
        (member 2 '(1 2 3 4 5) (lambda (x y) (set! final (+ final x)) #f))
        final))

(test "assoc with 3d parameter.1"
      '(2 4)
      (assoc 2.0 '((1 1) (2 4) (3 9)) =))

(test "assoc with 3d parameter.2"
      '("b" 4)
      (assoc "B" '(("a" 1) ("b" 4) ("c" 9)) string-ci=?))

(test "assoc with 3d parameter.3"
      '(a b c d e)
      (let ((final '()))
        ;; R7RS doesn't state anything about the comparator arguments order
        ;; Anyway, fix it to the one used by SRFI-1 to ensure maximum
        ;; compatibility
        (assoc 2
               '((a . 1) (b . 2) (c . 3) (d . 4) (e  . 5))
               (lambda (x y) (set! final (append final (list y))) #f))
        final))

(test "list-set!.1"
      '("foo" 2 3)
      (let ((l (list 1 2 3)))
        (list-set! l 0 "foo")
        l))

(test "make-list.1"
      '(#void #void #void)
      (make-list 3))

(test "make-list.2"
      '(42 42 42 42)
      (make-list 4 42))

;;------------------------------------------------------------------
(test-subsection "6.5 Symbols")

(test "symbol=?.1" #t (symbol=? 'a 'a (string->symbol "a")))
(test "symbol=?.2" #t (symbol=? '|A| (string->symbol "A")))
(test "symbol=?.3" #f (symbol=? '|A| (string->symbol "a")))
(test "symbol=?.4" #f (symbol=? 'a 'a "a"))


;;-------------------------------------------------------------------
(test-subsection "6.6 Characters")

(test "Chibi char.1" #t  (char? #\a))
(test "Chibi char.2" #f (char? "a"))
(test "Chibi char.3" #f (char? 'a))
(test "Chibi char.4" #f (char? 0))

(test "Chibi charcmp.1" #t (char=? #\a #\a #\a))
(test "Chibi charcmp.2" #f (char=? #\a #\A))
(test "Chibi charcmp.3" #t (char<? #\a #\b #\c))
(test "Chibi charcmp.4" #f (char<? #\a #\a))
(test "Chibi charcmp.5" #f (char<? #\b #\a))
(test "Chibi charcmp.6" #f (char>? #\a #\b))
(test "Chibi charcmp.7" #f (char>? #\a #\a))
(test "Chibi charcmp.8" #t (char>? #\c #\b #\a))
(test "Chibi charcmp.9" #t (char<=? #\a #\b #\b))
(test "Chibi charcmp.10" #t (char<=? #\a #\a))
(test "Chibi charcmp.11" #f (char<=? #\b #\a))
(test "Chibi charcmp.12" #f (char>=? #\a #\b))
(test "Chibi charcmp.13" #t (char>=? #\a #\a))
(test "Chibi charcmp.14" #t (char>=? #\b #\b #\a))

(test "Chibi charcmpci.1" #t (char-ci=? #\a #\a))
(test "Chibi charcmpci.2" #t (char-ci=? #\a #\A #\a))
(test "Chibi charcmpci.3" #f (char-ci=? #\a #\b))
(test "Chibi charcmpci.4" #t (char-ci<? #\a #\B #\c))
(test "Chibi charcmpci.5" #f (char-ci<? #\A #\a))
(test "Chibi charcmpci.6" #f (char-ci<? #\b #\A))
(test "Chibi charcmpci.7" #f (char-ci>? #\A #\b))
(test "Chibi charcmpci.8" #f (char-ci>? #\a #\A))
(test "Chibi charcmpci.9" #t (char-ci>? #\c #\B #\a))
(test "Chibi charcmpci.10" #t (char-ci<=? #\a #\B #\b))
(test "Chibi charcmpci.11" #t (char-ci<=? #\A #\a))
(test "Chibi charcmpci.12" #f (char-ci<=? #\b #\A))
(test "Chibi charcmpci.13" #f (char-ci>=? #\A #\b))
(test "Chibi charcmpci.14" #t (char-ci>=? #\a #\A))
(test "Chibi charcmpci.15" #t (char-ci>=? #\b #\B #\a))

(test "Chibi char-alphabetic?.1" #t (char-alphabetic? #\a))
(test "Chibi char-alphabetic?.2" #f (char-alphabetic? #\space))
(test "Chibi char-alphabetic?.3" #t (char-alphabetic? #\Λ))
(test "Chibi char-alphabetic?.4" #f (char-alphabetic? #\x0E50))

(test "Chibi char-numeric?.1" #t (char-numeric? #\0))
(test "Chibi char-numeric?.2" #f (char-numeric? #\.))
(test "Chibi char-numeric?.3" #f (char-numeric? #\a))
(test "Chibi char-numeric?.4" #f (char-numeric? #\Λ))
(test "Chibi char-numeric?.5" #t (char-numeric? #\x0E50))

(test "Chibi char-whitespace?.1" #t (char-whitespace? #\space))
(test "Chibi char-whitespace?.2" #t (char-whitespace? #\tab))
(test "Chibi char-whitespace?.3" #t (char-whitespace? #\newline))
(test "Chibi char-whitespace?.4" #f (char-whitespace? #\_))
(test "Chibi char-whitespace?.5" #f (char-whitespace? #\a))
(test "Chibi char-whitespace?.6" #t (char-whitespace? #\x1680))

(test "Chibi char-upper-case?.1" #t (char-upper-case? #\A))
(test "Chibi char-upper-case?.2" #f (char-upper-case? #\a))
(test "Chibi char-upper-case?.3" #f (char-upper-case? #\3))
(test "Chibi char-upper-case?.4" #t (char-upper-case? #\Λ))
(test "Chibi char-upper-case?.5" #f (char-upper-case? #\λ))


(test "Chibi char-lower-case?.1" #t (char-lower-case? #\a))
(test "Chibi char-lower-case?.2" #f (char-lower-case? #\A))
(test "Chibi char-lower-case?.3" #f (char-lower-case? #\3))
(test "Chibi char-lower-case?.4" #f (char-lower-case? #\Λ))
(test "Chibi char-lower-case?.5" #t (char-lower-case? #\λ))


(test "Chibi digit-value.1" 0 (digit-value #\0))
(test "Chibi digit-value.2" 3 (digit-value #\3))
(test "Chibi digit-value.3" 9 (digit-value #\9))
(test "Chibi digit-value.4" 4 (digit-value #\x0664))
(test "Chibi digit-value.5" 0 (digit-value #\x0AE6))
(test "Chibi digit-value.6" #f (digit-value #\.))
(test "Chibi digit-value.7" #f (digit-value #\-))

(test "Chibi char->integer" 97 (char->integer #\a))
(test "Chibi integer->char" #\a (integer->char 97))

(test "Chibi char-upcase.1" #\A (char-upcase #\a))
(test "Chibi char-upcase.2" #\A (char-upcase #\A))
(test "Chibi char-upcase.3" #\Λ (char-upcase #\λ))
(test "Chibi char-upcase.4" #\Λ (char-upcase #\Λ))

(test "Chibi char-downcase.1" #\a (char-downcase #\a))
(test "Chibi char-downcase.2" #\a (char-downcase #\A))
(test "Chibi char-downcase.3" #\λ (char-downcase #\λ))
(test "Chibi char-downcase.4" #\λ (char-downcase #\Λ))

(test "Chibi char-foldcase.1" #\a (char-foldcase #\a))
(test "Chibi char-foldcase.2" #\a (char-foldcase #\A))
(test "Chibi char-foldcase.3" #\λ (char-foldcase #\λ))
(test "Chibi char-foldcase.4" #\λ (char-foldcase #\Λ))


;;------------------------------------------------------------------
(test-subsection "6.7 Strings")

(test "newline.1" "\n" "
")
(test "newline.2" "a\nbc" "a
bc")
(test "escaped newline in string.1" "abc" "a\
bc")
(test "escaped newline in string.2" "abc" "a\
                                           bc")
(test "escaped newline in string.3" "a" "a\
")
(test "escaped newline in string.3" "a" "\
a")
(test "escaped newline in string.4" "a" "\
                           a")
(test "escaped newline in string.5" "" "\
")
(test "escaped newline in string.6" "" "\
                                       ")

(test "escaped newline in string.7" "abc" "ab\
\
\
                                           c")
(test "escaped newline in string.8" "" "\
\
\
                                           ")
(test "escaped newline in string.9" "" "\
                    \
            \
                                           ")

(test "Extended string=?.1" #t (string=? "a"))
(test "Extended string=?.2" #t (string=? "a" "a" "a" "a"))
(test "Extended string=?.3" #f (string=? "a" "a" "A" "a"))

(test "Extended string-ci=?.1" #t (string-ci=? "a"))
(test "Extended string-ci=?.2" #t (string-ci=? "a" "a" "a" "a"))
(test "Extended string-ci=?.3" #t (string-ci=? "a" "a" "A" "a"))
(test "Extended string-ci=?.4" #f (string-ci=? "a" "a" "A" "b"))

(test "Extended string<?.1" #t (string<? "a"))
(test "Extended string<?.2" #t (string<? "a" "b" "c" "d"))
(test "Extended string<?.3" #f (string<? "a" "B" "c" "D"))
(test "Extended string<?.4" #f (string<? "a" "a" "A" "b"))

(test "Extended string-ci<?.1" #t (string-ci<? "a"))
(test "Extended string-ci<?.2" #t (string-ci<? "a" "b" "c" "d"))
(test "Extended string-ci<?.3" #t (string-ci<? "a" "B" "c" "D"))
(test "Extended string-ci<?.4" #f (string-ci<? "a" "a" "A" "b"))

(let ((str "abcdef"))
  (test "Extended string->list.1" '(#\a #\b #\c #\d #\e #\f) (string->list str))
  (test "Extended string->list.2" '(#\c #\d #\e #\f) (string->list str 2))
  (test "Extended string->list.3" '(#\c #\d #\e) (string->list str 2 5))
  (test "Extended string->list.4" *test-failed* (string->list str 2 100))

  (test "Extended string-copy.1" "abcdef" (string-copy str))
  (test "Extended string-copy.2" "cdef" (string-copy str 2))
  (test "Extended string-copy.3" "cde" (string-copy str 2 5))
  (test "Extended string-copy.4" *test-failed* (string-copy str 2 100)))


(test "string-copy!.1"
      "abc12f"
      (let ((s (string-copy "abcdef"))) (string-copy! s 3 "12") s))
(test "string-copy!.2"
      *test-failed*
      (let ((s (string-copy "abcdef"))) (string-copy! s 5 "12") s))
(test "string-copy!.3"
      "a23def"
      (let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 1) s))
(test "string-copy!.4"
      "a23def"
      (let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 1) s))
(test "string-copy!.5"
      "a3cdef"
      (let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 2) s))
(test "string-copy!.6"
      "abcdef"
      (let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 3) s))
(test "string-copy!.7"
      "a12def"
      (let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 0 2) s))
(test "string-copy!.8"
      "a123ef"
      (let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 0 3) s))
(test "string-copy!.9"
      *test-failed*
      (let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 0 4) s))

(test "string-copy! overlap.1"
      "ababcfg"
      (let ((s (string-copy "abcdefg")))   (string-copy! s 2 s 0 3) s))
(test "string-copy! overlap.2"
      "efcdefg"
      (let ((s (string-copy "abcdefg")))   (string-copy! s 0 s 4 6) s))

(test "string-fill!.1"
      "abcde"
      (let ((x (string-copy "abcde"))) (string-fill! x #\1 2 2) x))
(test "string-fill!.2"
      "ab11e"
      (let ((x (string-copy "abcde"))) (string-fill! x #\1 2 4) x))
(test "string-fill!.2"
      "ab111"
      (let ((x (string-copy "abcde"))) (string-fill! x #\1 2 5) x))
(test "string-fill!.3"
      *test-failed*
      (let ((x (string-copy "abcde"))) (string-fill! x #\1 2 6) x))

;;------------------------------------------------------------------
(test-subsection "6.8 Vectors")

(test "Extended vector->list.1" '(1 2 3)        (vector->list '#(1 2 3)))
(test "Extended vector->list.2" '(2 3)          (vector->list '#(1 2 3) 1))
(test "Extended vector->list.3" '(1 2)          (vector->list '#(1 2 3) 0 2))
(test "Extended vector->list.4" *test-failed*   (vector->list '#(1 2 3) 0 7))

(let ((v #(a b c d e f)))
  (test "Extended vector-copy.1" #(a b c d e f) (vector-copy v))
  (test "Extended vector-copy.2" #(c d e f)     (vector-copy v 2))
  (test "Extended vector-copy.3" #(c d e)       (vector-copy v 2 5))
  (test "Extended vector-copy.4" *test-failed*  (vector-copy v 2 100)))

(let ((vect #(a b c d e f)))
  (test "vector-copy!.1"
        #(a b c 1 2 f)
        (let ((v (vector-copy vect))) (vector-copy! v 3 #(1 2)) v))
  (test "vector-copy!.2"
        *test-failed*
        (let ((v (vector-copy vect))) (vector-copy! v 5 #(1 2)) v))
  (test "vector-copy!.3"
        #(a 2 3 d e f)
        (let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3)  1) v))
  (test "vector-copy!.4"
        #(a 2 3 d e f)
        (let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 1) v))
  (test "vector-copy!.5"
        #(a 3 c d e f)
        (let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 2) v))
  (test "vector-copy!.6"
        #(a b c d e f)
        (let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 3) v))
  (test "vector-copy!.7"
        #(a 1 2 d e f)
        (let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 0 2) v))
  (test "vector-copy!.8"
        #(a 1 2 3 e f)
        (let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 0 3) v))
  (test "vector-copy!.9"
        *test-failed*
        (let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 0 4) v))

  (test "vector-copy!overlap.1"
        #(a b a b c f g)
        (let ((v (vector 'a 'b 'c 'd 'e 'f 'g)))
          (vector-copy! v 2 v 0 3) v))
  (test "vector-copy!overlap.2"
        #(e f c d e f g)
        (let ((v (vector 'a 'b 'c 'd 'e 'f 'g)))
          (vector-copy! v 0 v 4 6) v)))


(test "vector->string.1" "" (vector->string #()))
(test "vector->string.2" "123" (vector->string #(#\1 #\2 #\3)))
(test "vector->string.3" "23" (vector->string #(#\1 #\2 #\3) 1))
(test "vector->string.4" "2" (vector->string #(#\1 #\2 #\3) 1 2))
(test "string->vector.1" #() (string->vector ""))
(test "string->vector.2" #(#\A #\B #\C) (string->vector "ABC"))
(test "string->vector.3" #(#\B #\C) (string->vector "ABC" 1))
(test "string->vector.4" #(#\B) (string->vector "ABC" 1 2))

(test "chibi vector-append.1" #() (vector-append #()))
(test "chibi vector-append.2" #() (vector-append #() #()))
(test "chibi vector-append.3" #(a b c) (vector-append #() #(a b c)))
(test "chibi vector-append.4" #(a b c) (vector-append #(a b c) #()))
(test "chibi vector-append.5" #(a b c d e) (vector-append #(a b c) #(d e)))
(test "chibi vector-append.6" #(a b c d e f) (vector-append #(a b c) #(d e) #(f)))


(test "chibi vector-fill!.1" #(1 2 smash smash 5)
    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'smash 2 4) vec))
(test "chibi vector-fill!.2" #(x x x x x)
    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x) vec))
(test "chibi vector-fill!.3" #(1 2 x x x)
    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2) vec))
(test "chibi vector-fill!.4" #(1 2 x 4 5)
    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 3) vec))
(test "vector-fill!.5" #(1 2 x x x)
    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 5) vec))
(test "vector-fill!.6" *test-failed*
    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 6) vec))
(test "vector-fill!.7" #(1 2 3 4 5)
    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 2) vec))

;;------------------------------------------------------------------
(test-subsection "6.9 Bytevectors")

(test "bytevector?.1" #t (bytevector? #u8()))
(test "bytevector?.2" #t (bytevector? #u8(0 1 2)))
(test "bytevector?.3" #f (bytevector? #()))
(test "bytevector?.4" #f (bytevector? #(0 1 2)))
(test "bytevector?.5" #f (bytevector? '()))
(test "bytevector?.6" #t (bytevector? (make-bytevector 0)))

(test "make-bytevector.1" #u8(0 0 0) (make-bytevector 3))
(test "make-bytevector.2" #u8(1 1 1) (make-bytevector 3 1))
(test "make-bytevector.3" *test-failed* (make-bytevector 3 2000))
(test "make-bytevector.3" *test-failed* (make-bytevector 3 #f))

(test "bytevector.1" #u8(1 2 3) (bytevector 1 2 3))
(test "bytevector.2" #u8() (bytevector))
(test "bytevector.3" *test-failed* (bytevector 1 2 300))
(test "bytevector.4" *test-failed* (bytevector 1 2 -1))
(test "bytevector.5" *test-failed* (bytevector 1 2 'a))

(test "bytevector-length.1" 5   (bytevector-length (bytevector 1 2 3 4 5)))
(test "bytevector-length.2" 0   (bytevector-length (make-bytevector 0)))
(test "bytevector-length.3" 100 (bytevector-length (make-bytevector 100)))
(test "bytevector-length.4" 100 (bytevector-length (make-bytevector 100 42)))

(test "bytevector-u8-ref.1" 0 (bytevector-u8-ref (bytevector 0 1 2) 0))
(test "bytevector-u8-ref.2" 1 (bytevector-u8-ref (bytevector 0 1 2) 1))
(test "bytevector-u8-ref.3" 2 (bytevector-u8-ref (bytevector 0 1 2) 2))
(test "bytevector-u8-ref.4" *test-failed* (bytevector-u8-ref (bytevector 0 1 2) 3))
(test "bytevector-u8-ref.5" *test-failed* (bytevector-u8-ref (vector 0 1 2) 0))

(test "bytevector-u8-set!.1" #u8(1 3 3 4)
      (let ((bv (bytevector 1 2 3 4)))  (bytevector-u8-set! bv 1 3) bv))
(test "bytevector-u8-set!.2" #u8(100 2 3 4)
      (let ((bv (bytevector 1 2 3 4)))  (bytevector-u8-set! bv 0 100) bv))
(test "bytevector-u8-set!.3" *test-failed*
      (let ((bv (bytevector)))  (bytevector-u8-set! bv 0 100) bv))
(test "bytevector-u8-set!.4" *test-failed*
      (let ((bv #u8(1 2 3)))  (bytevector-u8-set! bv 0 100) bv))

(test "bytevector-copy.1" #u8() (bytevector-copy #u8()))
(test "bytevector-copy.2" #u8(0 1 2 3 4 5) (bytevector-copy #u8(0 1 2 3 4 5)))
(test "bytevector-copy.3" #u8(2 3 4 5) (bytevector-copy #u8(0 1 2 3 4 5) 2))
(test "bytevector-copy.4" #u8(2 3) (bytevector-copy #u8(0 1 2 3 4 5) 2 4))

(let ((vect #u8(10 20 30 40 50 60)))
  (test "byvector-copy!.1"
        #u8(10 20 30 1 2 60)
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 3 #u8(1 2)) v))
  (test "bytevector-copy!.2"
        *test-failed*
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 5 #u8(1 2)) v))
  (test "bytevector-copy!.3"
        #u8(10 2 3 40 50 60)
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 1 #u8(1 2 3)  1) v))
  (test "bytevector-copy!.4"
        #u8(10 2 3 40 50 60)
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 1 #u8(1 2 3) 1) v))
  (test "bytevector-copy!.5"
        #u8(10 3 30 40 50 60)
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 1 #u8(1 2 3) 2) v))
  (test "bytevector-copy!.6"
        #u8(10 20 30 40 50 60)
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 1 #u8(1 2 3) 3) v))
  (test "bytevector-copy!.7"
        #u8(10 1 2 40 50 60)
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 1 #u8(1 2 3) 0 2) v))
  (test "bytevector-copy!.8"
        #u8(10 1 2 3 50 60)
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 1 #u8(1 2 3) 0 3) v))
  (test "bytevector-copy!.9"
        *test-failed*
        (let ((v (bytevector-copy vect))) (bytevector-copy! v 1 #u8(1 2 3) 0 4) v))

  (test "bytevector-copy!overlap.1"
        #u8(1 2 1 2 3 6 7 8 9)
        (let ((v (bytevector 01 2 3 4 5 6 7 8 9)))
          (bytevector-copy! v 2 v 0 3) v))
  (test "bytevector-copy!overlap.2"
        #u8(4 5 2 3 4 5 6 7 8 9)
        (let ((v (bytevector 0 1 2 3 4 5 6 7 8 9)))
          (bytevector-copy! v 0 v 4 6) v)))


(test "byte-vector-append.1" #u8() (bytevector-append))
(test "byte-vector-append.2" #u8() (bytevector-append #u8()))
(test "byte-vector-append.3" #u8() (bytevector-append #u8() #u8()))
(test "byte-vector-append.4" #u8(0 1 2 3) (bytevector-append #u8() #u8(0 1 2 3)))
(test "byte-vector-append.5" #u8(0 1 2 3) (bytevector-append #u8(0 1 2 3) #u8()))
(test "byte-vector-append.6" #u8(0 1 2 3) (bytevector-append #u8(0 1) #u8(2 3)))
(test "byte-vector-append.7" #u8(0 1 2 3) (bytevector-append #u8(0) #u8(1)
                                                             #u8() #u8(2) #u8(3)))

(test "chibi utf8->string.1" "ABC" (utf8->string #u8(#x41 #x42 #x43)))
(test "chibi utf8->string.2" "ABC" (utf8->string #u8(0 #x41 #x42 #x43) 1))
(test "chibi utf8->string.3""ABC" (utf8->string #u8(0 #x41  #x42 #x43 0) 1 4))
(test "chibi utf8->string.4" "λ" (utf8->string #u8(0 #xCE #xBB 0) 1 3))
(test "utf8->string.5" *test-failed*  (utf8->string #u8(0 #xCE)))

(test "chibi string->utf8.1" #u8(#x41 #x42 #x43) (string->utf8 "ABC"))
(test "chibi string->utf8.2" #u8(#x42 #x43) (string->utf8 "ABC" 1))
(test "chibi string->utf8.3" #u8(#x42) (string->utf8 "ABC" 1 2))
(test "chibi string->utf8.4" #u8(#xCE #xBB) (string->utf8 "λ"))

;;------------------------------------------------------------------
(test-subsection "6.10 Control features")

;;; SRFI-13 redefines R7RS string-map in an incompatible way. Redefine
;;; string-map here to the R7RS version
(define string-map (in-module SCHEME string-map))

(test "string-map 1"  "abdegh"  (string-map char-downcase "AbdEgH"))
(test "string-map 2"  "IBM"     (string-map (lambda (c)
                                              (integer->char (+ 1 (char->integer c))))
                                            "HAL"))
(test "string-map 3"  "StUdLyCaPs"  (string-map (lambda (c k)
                                                  (if (eqv? k #\u)
                                                      (char-upcase c)
                                                      (char-downcase c)))
                                                "studlycaps"
                                                "ululululul"))

;; **********
(test "vector-map 1"
      #(b e h)
      (vector-map cadr '#((a b) (d e) (g h))))

(test "vector-map 2" #(1 4 27 256 3125)
      (vector-map (lambda (n) (expt n n))
                  '#(1 2 3 4 5)))

(test "vector-map 3" #(5 7 9)
      (vector-map + '#(1 2 3) '#(4 5 6)))

(test "vector-map 4"  #(1 2)
      (let ((count 0))
        (vector-map (lambda (ignored)
                      (set! count (+ count 1))
                      count)
                    '#(a b))))

;; **********
(test "string-for-each"
      '(101 100 99 98 97)
      (let ((v (list)))
        (string-for-each (lambda (c) (set! v (cons (char->integer c) v)))
                         "abcde")
         v))

;; **********
(test "vector-for-each"
      '#(0 1 4 9 16)
      (let ((v (make-vector 5)))
        (vector-for-each (lambda (i) (vector-set! v i (* i i)))
                         '#(0 1 2 3 4))
        v))



;;======================================================================
(test-subsection "6.11 Exceptions")

(test "srfi-34.1"
      '("condition: an-error" exception)
      (let* ((out (open-output-string))
             (res (call-with-current-continuation
                   (lambda (k)
                     (with-exception-handler (lambda (x)
                                               (display "condition: " out)
                                               (write x out)
                                               (k 'exception))
                                             (lambda ()
                                               (+ 1 (raise 'an-error))))))))
        (list (get-output-string out) res)))

(test "srfi-34.2"
      "something went wrong"
      (call-with-output-string
       (lambda (p)
         (with-handler  ;; This handler is used to grab the error from R7RS
             void       ;; (whereas it was an unspecified behavior in SRFI-34)
             (with-exception-handler
                (lambda (x)
                  (display "something went wrong" p)
                  'dont-care)
                (lambda ()
                  (+ 1 (raise 'an-error))))))))


(test "srfi-34.3"
      '("condition: an-error" exception)
      (let* ((out (open-output-string))
             (res (guard (condition
                          (else
                           (display "condition: " out)
                           (write condition out)
                           'exception))
                         (+ 1 (raise 'an-error)))))
       (list (get-output-string out) res)))

(test "srfi-34.4"
      '("something went wrong" dont-care)
      (let* ((out (open-output-string))
             (res (guard (condition
                          (else
                           (display "something went wrong" out)
                           'dont-care))
                         (+ 1 (raise 'an-error)))))
        (list (get-output-string out) res)))

(test "srfi-34.5"
      '("" positive)
      (let* ((out (open-output-string))
             (res (call-with-current-continuation
                   (lambda (k)
                     (with-exception-handler (lambda (x)
                                               (display "reraised " out)
                                               (write x out)
                                               (k 'zero))
                                             (lambda ()
                                               (guard (condition
                                                       ((positive? condition)
                                                        'positive)
                                                       ((negative? condition)
                                                        'negative))
                                                      (raise 1))))))))
        (list (get-output-string out) res)))

(test "srfi-34.6"
      '("" negative)
      (let* ((out (open-output-string))
             (res (call-with-current-continuation
                   (lambda (k)
                     (with-exception-handler (lambda (x)
                                               (display "reraised " out)
                                               (write x out)
                                               (k 'zero))
                                             (lambda ()
                                               (guard (condition
                                                       ((positive? condition)
                                                        'positive)
                                                       ((negative? condition)
                                                        'negative))
                                                      (raise -1))))))))
        (list (get-output-string out) res)))

(test "srfi-34.7"
      '("reraised 0" zero)
      (let* ((out (open-output-string))
             (res (call-with-current-continuation
                   (lambda (k)
                     (with-exception-handler (lambda (x)
                                               (display "reraised " out)
                                               (write x out)
                                               (k 'zero))
                                             (lambda ()
                                               (guard (condition
                                                       ((positive? condition)
                                                        'positive)
                                                       ((negative? condition)
                                                        'negative))
                                                      (raise 0))))))))
        (list (get-output-string out) res)))

(test "srfi-34.8"
      42
      (guard (condition
              ((assq 'a condition) => cdr)
              ((assq 'b condition)))
             (raise (list (cons 'a 42)))))

(test "srfi-34.9"
      '(b . 23)
      (guard (condition
              ((assq 'a condition) => cdr)
              ((assq 'b condition)))
             (raise (list (cons 'b 23)))))

(test "raise-continuable.1"
      65
      (with-exception-handler
       (lambda (c) 42)
       (lambda ()
         (+ (raise-continuable "should be a number")
            23))))

(test "raise-continuable.2"
      '("should be a number" 65)
      (let* ((out (open-output-string))
             (res (with-exception-handler
                   (lambda (con)
                     (cond
                       ((not (list? con))
                        (raise con))
                       ((list? con)
                        (display (car con) out))
                       (else
                        (display "a warning has been issued" out)))
                     42)
                   (lambda ()
                     (+ (raise-continuable
                         (list "should be a number"))
                        23)))))
        (list (get-output-string out) res)))

(test "raise-continuable.3"
      62
      (with-exception-handler
       (lambda (x) (* x 2))
       (lambda () (+ 2 (raise-continuable 10) (raise-continuable 20)))))

(test "error-object?.1"
      #t
      (error-object? (guard (condition (else condition)) (error "BAD" 'foo :bar 42))))

(test "error-object?.2"
      #f
      (error-object? (guard (condition (else condition)) (raise 42))))

(test "error-object?.3"
      #f
      (error-object? (guard (condition (else condition)) 'normal)))

(test "error-object?.4"
      '(:cont #f :err #t)
      (let ((cont #f)
            (err #f))
        (call-with-current-continuation
            (lambda (k)
              (with-exception-handler
                  (lambda (c)
                    (if (error-object? c)
                        (begin
                          (set! err #t)
                          (k))
                        (set! cont #t)))
                  (lambda()
                    (error "BAD")
                    (raise-continuable 100)))))
        `(cont: ,cont err: ,err)))

(test "error-object?.5"
      '(:cont #t :err #t)
      (let ((cont #f)
            (err #f))
        (call-with-current-continuation
            (lambda (k)
              (with-exception-handler
                  (lambda (c)
                    (if (error-object? c)
                        (begin
                          (set! err #t)
                          (k))
                        (set! cont #t)))
                  (lambda()
                    (raise-continuable 100)
                    (error "BAD")))))
        `(cont: ,cont err: ,err)))


(test "error-object-message.1"
      "Oops"
      (guard (condition
              ((error-object? condition)
                  (error-object-message condition))
               (else
                  "Oops"))
             (raise 42)))

(test "error-object-message.2"
      "BAD"
      (error-object-message (guard (condition (else condition))
                                   (error "BAD" 'foo :bar 42))))

(test "error-object-irritants.1"
      '(foo :bar 42)
      (error-object-irritants (guard (condition (else condition))
                                     (error "BAD" 'foo :bar 42))))

(test "error-object-irritants.2"
      '()
      (error-object-irritants (guard (condition (else condition))
                                     (error "BAD"))))


(test "read-error?.1"
      #f
      (read-error? (guard (condition (else condition))
                          (error "BAD"))))

(test "read-error?.2"
      #t
      (read-error? (guard (condition (else condition))
                          (read-from-string "("))))

(test "read-error?.3"
      #t
      (read-error? (guard (condition (else condition))
                          (read-from-string "\"abc"))))
(test "read-error?.3"
      #t
      (read-error? (guard (condition (else condition))
                          (read-from-string "\"abc"))))
(test "read-error?.4"
      #t
      (read-error? (guard (condition (else condition))
                          (read-from-string "(a . )"))))


(test "file-error?.1"
      #t
      (file-error? (guard (condition (else condition))
                           (open-input-file "**This file doesn't exist**"))))

(test "file-error?.2"
      #f
      (file-error? (guard (condition (else condition))
                          (error "BAD"))))

(test "file-error?.3"
      #t
      (file-error?
       (guard (exn (else exn))
              (load "**This file doesn't exist**"))))


;;;
;;; Chibi tests
;;;

(define something-went-wrong #f)
(define (test-exception-handler-1 v)
  (call-with-current-continuation
   (lambda (k)
     (with-exception-handler
      (lambda (x)
        (set! something-went-wrong (list "condition: " x))
        (k 'exception))
      (lambda ()
        (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))))

(test "chibi-exception.1" 106 (test-exception-handler-1 5))
(test "chibi-exception.2" #f something-went-wrong)
(test "chibi-exception.3" 'exception (test-exception-handler-1 -1))
(test "chibi-exception.4" '("condition: " an-error) something-went-wrong)

(set! something-went-wrong #f)
(define (test-exception-handler-2 v)
  (guard (ex (else 'caught-another-exception))
    (with-exception-handler
     (lambda (x)
       (set! something-went-wrong #t)
       (list "exception:" x))
     (lambda ()
       (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))

(test "chibi-exception.5" 106 (test-exception-handler-2 5))
(test "chibi-exception.6" #f something-went-wrong)
(test "chibi-exception.7" 'caught-another-exception (test-exception-handler-2 -1))
(test "chibi-exception.8" #t something-went-wrong)

;; Based on an example from R6RS-lib section 7.1 Exceptions.
;; R7RS section 6.11 Exceptions has a simplified version.
(let* ((out (open-output-string))
       (value (with-exception-handler
               (lambda (con)
                 (cond
                  ((not (list? con))
                   (raise con))
                  ((list? con)
                   (display (car con) out))
                  (else
                   (display "a warning has been issued" out)))
                 42)
               (lambda ()
                 (+ (raise-continuable
                     (list "should be a number"))
                    23)))))

  (test "chibi-exception.9" "should be a number" (get-output-string out))
  (test "chibi-exception.10" 65 value))

;;
;; Some tests from @jpellegrini on raise-continuable (issue #67 @github)
;;
(test "bug.1"
      12
      (let ((res (guard (x (#t x))
                        (raise 12)
                        34)))
        res))

(test "bug.2"
      12
      (let ((res (guard (x (#t x))
                        (raise-continuable 12)
                        34)))
        res))

(test "bug.3"
      '(-5)
      (with-exception-handler (lambda (x) (- x))
                              (lambda ()
                                (guard (e ((symbol? e) (symbol->string e)))
                                       (list (raise-continuable 5))))))

;;
;; Some (adapted) Gauche tests
;;

(test "Gauche: guard" 'caught-error
       (guard (x
               ((symbol? x) (cons 'symbol x))
               ((error-object? x) 'caught-error))
         (car 'a)))


(test/error "Gauche: guard (uncaught error)"
       (guard (x
               ((symbol? x) (cons 'symbol x))
               ((error-object? x) 'caught-error))
         (raise 4)))

(test "Gauche: guard (uncaught error)" '(else . 4)
      (guard (x
              ((symbol? x) (cons 'symbol x))
              ((error-object? x) 'caught-error)
              (else (cons 'else x)))
          (raise 4)))

(test "Gauche: guard (subtype)" 'read-error
       (guard (x
               ((read-error? x)   'read-error)
               ((file-error? x)   'file-error)
               ((error-object? x) 'other-error)
               (else             '???))
              (read-from-string "(abc")))


(test "Gauche: guard (nested)" 'exn
      (call/cc (lambda (k)
                 (with-exception-handler
                  (lambda (x)
                    (k x))
                  (lambda ()
                    (guard (ball
                            (#f (display "Caught exception.")))
                           (guard (ball
                                   (#f (raise ball)))
                                  (raise 'exn))))))))

(let ()
  (define aaa '())
  (define (foo)
    (dynamic-wind
        (lambda () (set! aaa '()))
        (lambda ()
          (set! aaa (cons 'a aaa))
          (error "foo"))
        (lambda ()
          (set! aaa (cons 'b aaa)))))
  (test "Gauche: guard w/dynamic-wind" '((b a) (b a))
         (let ((x (guard (e (else aaa)) (foo))))
           (list x aaa))))


;;======================================================================
(test-subsection "6.12 Environments and evaluation")

(let ((scheme (find-module 'SCHEME)))
  (test "eval.scheme.1" -1   (eval -1 (scheme-report-environment 5)))
  (test "eval.scheme.2"
        (symbol-value 'display scheme)
        (eval 'display (scheme-report-environment 5)))
  (let ((display print))
    (test "eval.scheme.3"
          (symbol-value 'display scheme)
          (eval 'display (scheme-report-environment 5))))

  ;; -1 is -1, doesn't matter where it's evaluated
  (test "eval.null.1" -1 (eval -1 (null-environment 5)))

  ;; write is not available in the null environment!
  (test/error "eval.null.2" (eval 'write (null-environment 5))))

 (define-library (testing x y)
   (export x) ;; but not y!
   (begin (define x -1)
          (define y -2)))

 (define-module testing-d
   (export d)
   (define d "ddd"))

 (define-module testing-a-b-c-d
   (import testing-d)
   (export a b d)
   (define a "aaa")
   (define b "bbb")
   (define c "ccc"))

 ;; without name
 (define e (environment '(testing x y)    ; user lib
                        'testing-a-b-c-d  ; user module
                        '(scheme write))) ; system lib


 ;; All modules have names now...
 (test "environment.0" #f (module-name e))
 (test "environment.1" "aaa" (eval 'a e))
 (test "environment.2" "bbb" (eval 'b e))
 (test/error "environment.3" (eval 'c e))
 (test "environment.4" "ddd" (eval 'd e))
 (test "environment.5" -1 (eval 'x e))
 (test/error "environment.6" (eval 'y e))

;; null
(test "environment.null.1"
      #t
      (eq? (null-environment)
           (environment)))

(test/error "environment.null.2" (eval 'car (null-environment)))

;; bad arguments to environment
(test/error "environment.badargs.1" (environment 1))     ; 1 not module
(test/error "environment.badargs.2" (environment e 1))   ; 1 not module (2nd arg)
(test/error "environment.badargs.3" (environment e "n")) ; name should be first arg


;; less simpler import specs
(define e1 (environment '(only (scheme base) + -) '(only (scheme write) display)))
(define e2 (environment '(prefix (only (scheme base) + -) |foo:|)))

(test "environment only" 3 (length (module-symbols e1)))
(test "environment only+prefix"  #t (let ((symbs (module-symbols e2)))
                                      (or (equal? symbs '(foo:+ foo:-))
                                          (equal? symbs '(foo:- foo:+)))))


;;======================================================================
(test-subsection "6.13 Input and Output")

(test/error "bad escaped hex value"       (read-from-string "\"\\xg;\""))
(test/error "unterminated hex string"     (read-from-string "\"\\x01\""))
(test/error "bad line continuation"       (read-from-string "\"\\ 1\""))
(test       "read escaped hex"        "K" (guard (e (else 'wrong))
                                                 (read-from-string "\"\\x4b;\"")))


(test "call-with-port"
      '(123 . #t)
      (let* ((p (open-input-string "123 456"))
             (v (call-with-port p read)))
        (cons v (port-closed? p))))

(let ((p (open-input-string "ABCDE")))
  (test "read-string.1" "ABCD" (read-string 4 p))
  (test "read-string.2" "E"    (read-string 4 p))
  (test "read-string.3" #eof   (read-string 4 p)))

;; --------------------------------------------------
(let ((p (open-input-bytevector #u8(0 1 2 3))))
  (test "input bytevector.1"
        '(#eof 3 2 1 0)
        (let* ((c0 (read-byte p))
               (c1 (read-byte p))
               (c2 (read-byte p))
               (c3 (read-byte p))
               (c4 (read-byte p)))
          (list c4 c3 c2 c1 c0))))

(let ((p (open-input-bytevector #u8(0 1 2 3))))
  (test "input bytevector.2"
        '(#\x0 #\x1 #\x2 #\x3 . #eof)
        (let* ((c0 (read-chars 2 p))
               (c1 (read-chars 3 p))
               (c2 (read-chars 1 p)))
          (append (string->list c0)
                  (string->list c1)
                  c2))))

(let ((p (open-input-bytevector #u8())))
  (test "input bytevector.3"
        (make-list 5 #eof)
        (let* ((c0 (read-byte p))
               (c1 (read-byte p))
               (c2 (read-byte p))
               (c3 (read-byte p))
               (c4 (read-byte p)))
          (list c4 c3 c2 c1 c0))))

; --------------------------------------------------
(let ((p (open-output-bytevector)))
  (test "output bytevector.1"
        #u8()
        (get-output-bytevector p)))

(let ((p (open-output-bytevector)))
  (test "output bytevector.2"
        #u8(1 2)
        (begin
          (write-byte 1 p)
          (write-byte 2 p)
          (get-output-bytevector p)))

  (test "output bytevector.3"
        #u8(1 2 3 4)
        (begin
          (write-byte 3 p)
          (write-byte 4 p)
          (get-output-bytevector p)))

  (test "close bytevector port"
        '(#f #u8(1 2 3 4) #t)
        (let* ((closed? (port-closed? p))
               (val     (get-output-bytevector p)))
          (close-port p)
          (list closed? val (port-closed? p)))))

  (test/error "write text to binary port"
              (call-with-port (open-bytevector-port)
                              (lambda (out)
                                (write "should not work")
                                (get-output-bytevector out))))

; --------------------------------------------------
(let ((p (open-input-bytevector #u8(0 1 2 3))))
  (test "read-bytevector.1"
        '(#u8(0 1 2 3) . #eof)
        (let* ((c0 (read-bytevector 2 p))
               (c1 (read-bytevector 3 p))
               (c2 (read-bytevector 1 p)))
          (cons (bytevector-append c0 c1) c2))))

(test "read-bytevector.2"
      #t
      (eof-object? (read-bytevector 3 (open-input-bytevector #u8()))))
(test "read-bytevector.3"
      #t (u8-ready? (open-input-bytevector #u8(1))))
(test "read-bytevector.4"
      #u8(0)
      (read-bytevector 3 (open-input-bytevector #u8(0))))
(test "read-bytevector.4"
      #u8(0 1)
      (read-bytevector 3 (open-input-bytevector #u8(0 1))))
(test "read-bytevector.4"
      #u8(0 1 2)
      (read-bytevector 3 (open-input-bytevector #u8(0 1 2))))
(test "read-bytevector.5"
      #u8(0 1 2)
      (read-bytevector 3 (open-input-bytevector #u8(0 1 2 3))))
(test "read-bytevector.6"
      #u8(0 1 2)
      (read-bytevector 10 (open-input-bytevector #u8(0 1 2 ))))

; --------------------------------------------------
(test "read-bytevector!.1"
      #eof
      (let ((bv (make-bytevector 5 255)))
        (read-bytevector! bv (open-input-bytevector #u8()))))

(test "read-bytevector!.2"
      0
      (let ((bv (make-bytevector 5 255)))
        (read-bytevector! bv (open-input-bytevector #u8(1 2 3)) 0 0)))


(test "read-bytevector!.3"
      #u8(0 1 2 3 4)
      (let ((bv (make-bytevector 5 255)))
        (read-bytevector! bv (open-input-bytevector #u8(0 1 2 3 4)) 0 5)
        bv))

(test "read-bytevector!.4"
      #u8(0 1 2 3 255)
      (let ((bv (make-bytevector 5 255)))
        (read-bytevector! bv (open-input-bytevector #u8(0 1 2 3 4)) 0 4)
        bv))

(test "read-bytevector!.5"
      #u8(255 255 255 0 255)
  (let ((bv (make-bytevector 5 255)))
    (read-bytevector! bv (open-input-bytevector #u8(0 1 2 3 4)) 3 4)
    bv))

(test "read-bytevector!.6"
      '(5 . #u8(0 1 2 3 4 42 42 42 42 42))
      (let* ((bv (make-bytevector 10 42))
             (n  (read-bytevector! bv (open-input-bytevector #u8(0 1 2 3 4)))))
        (cons n bv)))

(test "read-bytevector!.7"
      '(2 . #u8(42 42 0 1 42 42 42 42 42 42))
      (let* ((bv (make-bytevector 10 42))
             (n  (read-bytevector! bv (open-input-bytevector #u8(0 1 2 3 4)) 2 4)))
        (cons n bv)))


;; --------------------------------------------------
(test "write-simple"
      "((a b c d) (a b c d))"
      (let* ((x '(a b c d))
             (y (list x x))
             (out (open-output-string)))
          (write-simple y out)
          (get-output-string out)))

(test "write-shared"
      "(#0=(a b c d) #0#)"
      (let* ((x '(a b c d))
             (y (list x x))
             (out (open-output-string)))
        (write-shared y out)
        (get-output-string out)))

(test "display (cyclic list).1"
      "(#0=(abc def A foo) #0#)"
      (let* ((x '("abc" "def" #\A foo))
             (y (list x x))
             (out (open-output-string)))
        (display y out)
        (get-output-string out)))

(test "display (cyclic list).2"
      "(#0=(abc def A foo) #0#)(abc def A foo)(\"abc\" \"def\" #\\A foo)"
      (let* ((x '("abc" "def" #\A foo))
             (y (list x x))
             (out (open-output-string)))
        (display y out)
        (display-simple x out)
        (write-simple   x out)
        (get-output-string out)))



(test "write-shared (cyclic list).1"
      "(#0=(\"abc\" \"def\" #\\A foo) #0#)"
      (let* ((x '("abc" "def" #\A foo))
             (y (list x x))
             (out (open-output-string)))
        (write-shared y out)
        (get-output-string out)))


;; --------------------------------------------------
(test "chibi write-string.1"
      "abc def"
      (let ((out (open-output-string)))
        (write-string "abc def" out)
        (get-output-string out)))

(test "chibi write-string.2"
      "def"
      (let ((out (open-output-string)))
        (write-string "abc def" out 4)
        (get-output-string out)))

(test "chibi write-string.3"
      "c d"
      (let ((out (open-output-string)))
        (write-string "abc def" out 2 5)
        (get-output-string out)))

;; --------------------------------------------------
(let ((p (open-output-bytevector)))
  (test "write-u8.1"
        #u8(1 2)
        (begin
          (write-u8 1 p)
          (write-u8 2 p)
          (get-output-bytevector p)))

  (test "write-u8.2"
        #u8(1 2 3 4)
        (begin
          (write-byte 3 p)
          (write-byte 4 p)
          (get-output-bytevector p))))

;; --------------------------------------------------
(test "write-bytevector!.1"
      #u8(0 1 2 3 4 5 6 7 8 9)
      (let ((p (open-output-bytevector)))
        (write-bytevector #u8(0 1 2 3 4 5 6 7 8 9) p)
        (get-output-bytevector p)))

(test "write-bytevector!.2"
      #u8(5 6 7 8 9)
      (let ((p (open-output-bytevector)))
        (write-bytevector #u8(0 1 2 3 4 5 6 7 8 9) p 5)
        (get-output-bytevector p)))

(test "write-bytevector!.3"
      #u8(5 6)
      (let ((p (open-output-bytevector)))
        (write-bytevector #u8(0 1 2 3 4 5 6 7 8 9) p 5 7)
        (get-output-bytevector p)))

;; --------------------------------------------------
(test "flush-output-port on binary port"
      #u8()
      (let ((p (open-output-bytevector)))
        (flush-output-port p)
        (get-output-bytevector p)))

; --------------------------------------------------
(test "current-input-port as parameter.1"
      '((a b) 10 #eof)
      (parameterize ((current-input-port (open-input-string "(a b) 10")))
        (let* ((a (read))
               (b (read))
               (c (read)))
          (list a b c))))

(test "current-input-port as parameter.2"
      '(1000 ((a b) 10 #eof) 2000 #eof)
      (parameterize ((current-input-port (open-input-string "1000 2000")))
        (let* ((a (read))
               (b (parameterize ((current-input-port (open-input-string "(a b) 10")))
                    (let* ((a (read))
                           (b (read))
                           (c (read)))
                      (list a b c))))
               (c (read))
               (d (read)))
          (list a b c d))))


(test "current-output-port as parameter"
      "piece by piece by piece.\n"
      (parameterize ((current-output-port (open-output-string)))
        (display "piece")
        (display " by piece ")
        (display "by piece.")
        (newline)
        (get-output-string (current-output-port))))


;;======================================================================
(test-subsection "6.14 System Interface")

(test "command-line"
      #t
      (pair? (command-line)))

(test "get-enviroment-variables"
      #t
      (pair? (get-environment-variables)))

(test "get-environment-variable"
      #t
      (let ((path (get-environment-variable "PATH")))
        (if path
            (equal? (cdr (assoc "PATH" (get-environment-variables)))
                    path)
            #t)))

(test "current-second" #t (real? (current-second)))
(test "current-jiffy"  #t (exact? (current-jiffy)))
(test "jiffies-per-second"  #t (exact? (jiffies-per-second)))


(test-section-end)
