code:
;;;; coverage.test --- Code coverage.    -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	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-coverage)
  #:use-module (test-suite lib)
  #:use-module (system vm coverage)
  #:use-module (system vm vm)
  #:use-module (system base compile)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11))

(define-syntax code
  (syntax-rules ()
    ((_ filename snippet)
     (let ((input (open-input-string snippet)))
       (set-port-filename! input filename)
       (read-enable 'positions)
       (compile (read input))))))

(define %test-vm (make-vm))

(with-test-prefix "instrumented/executed-lines"

  (pass-if "instr = exec"
    (let ((proc (code "foo.scm" "(lambda (x y)  ;; 0
                                   (+ x y))     ;; 1")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (proc 1 2)))))
        (and (coverage-data? data)
             (= 3 result)
             (let-values (((instr exec)
                           (instrumented/executed-lines data "foo.scm")))
               (and (= 2 instr) (= 2 exec)))))))

  (pass-if "instr >= exec"
    (let ((proc (code "foo.scm" "(lambda (x y)       ;; 0
                                   (if (> x y)       ;; 1
                                       (begin        ;; 2
                                         (display x) ;; 3
                                         (+ x y))))  ;; 4")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (proc 1 2)))))
        (and (coverage-data? data)
             (let-values (((instr exec)
                           (instrumented/executed-lines data "foo.scm")))
               (and (> instr 0) (>= instr exec))))))))

(with-test-prefix "line-execution-counts"

  (pass-if "once"
    (let ((proc (code "bar.scm" "(lambda (x y)   ;; 0
                                   (+ (/ x y)    ;; 1
                                      (* x y)))  ;; 2")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (proc 1 2)))))
        (let ((counts (line-execution-counts data "bar.scm")))
          (and (pair? counts)
               (every (lambda (line+count)
                        (let ((line  (car line+count))
                              (count (cdr line+count)))
                          (and (>= line 0)
                               (<= line 2)
                               (= count 1))))
                      counts))))))

  (pass-if "several times"
    (let ((proc (code "fooz.scm" "(lambda (x)                   ;; 0
                                    (format #f \"hello\")       ;; 1
                                    (let loop ((x x))           ;; 2
                                      (cond ((> x 0)            ;; 3
                                             (begin             ;; 4
                                               (format #f \"~a\" x)
                                               (loop (1- x))))  ;; 6
                                            ((= x 0) #t)        ;; 7
                                            ((< x 0) 'never))))")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (proc 77)))))
        (let ((counts (line-execution-counts data "fooz.scm")))
          (and (pair? counts)
               (every (lambda (line+count)
                        (let ((line  (car line+count))
                              (count (cdr line+count)))
                          (case line
                            ((0 1)   (= count 1))
                            ((2 3)   (= count 78))
                            ((4 5 6) (= count 77))
                            ((7)     (= count 1))
                            ((8)     (= count 0)))))
                      counts))))))

  (pass-if "some"
    (let ((proc (code "baz.scm" "(lambda (x y)       ;; 0
                                   (if (> x y)       ;; 1
                                       (begin        ;; 2
                                         (display x) ;; 3
                                         (+ x y))    ;; 4
                                       (+ x y)))     ;; 5")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (proc 1 2)))))
        (let ((counts (line-execution-counts data "baz.scm")))
          (and (pair? counts)
               (every (lambda (line+count)
                        (let ((line  (car line+count))
                              (count (cdr line+count)))
                          (case line
                            ((0 1 5) (= count 1))
                            ((2 3)   (= count 0))
                            ((4)     #t) ;; the start of the `else' branch is
                                         ;; attributed to line 4
                            (else    #f))))
                      counts))))))

  (pass-if "one proc hit, one proc unused"
    (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x)               ;; 0
                                                   (or (= x 0)             ;; 1
                                                       (not (odd? (1- x))))))
                                          (odd?  (lambda (x)               ;; 3
                                                   (not (even? (1- x)))))) ;; 4
                                   even?)")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (proc 0)))))
        (let ((counts (line-execution-counts data "baz.scm")))
          (and (pair? counts)
               (every (lambda (line+count)
                        (let ((line  (car line+count))
                              (count (cdr line+count)))
                          (case line
                            ((0 1)   (= count 1))
                            ((2 3 4) (= count 0))
                            ((5)     (= count 1))
                            (else    #f))))
                      counts))))))

  (pass-if "all code on one line"
    ;; There are several proc/IP pairs pointing to this source line, yet the hit
    ;; count for the line should be 1.
    (let ((proc (code "one-liner.scm"
            "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (proc 451 1884)))))
        (let ((counts (line-execution-counts data "one-liner.scm")))
          (equal? counts '((0 . 1))))))))

(with-test-prefix "procedure-execution-count"

  (pass-if "several times"
    (let ((proc (code "foo.scm" "(lambda (x y) x)")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (+ (proc 1 2) (proc 2 3))))))
        (and (coverage-data? data)
             (= 3 result)
             (= (procedure-execution-count data proc) 2)))))

  (pass-if "never"
    (let ((proc (code "foo.scm" "(lambda (x y) x)")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (+ 1 2)))))
        (and (coverage-data? data)
             (= 3 result)
             (not (procedure-execution-count data proc)))))))

(with-test-prefix "instrumented-source-files"

  (pass-if "source files are listed as expected"
    (let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda () (proc 1 2)))))

        (let ((files (map basename (instrumented-source-files data))))
          (and (member "boot-9.scm" files)
               (member "chbouib.scm" files)
               (not (member "foo.scm" files))))))))


code:
;;;; curried-definitions.test          -*- scheme -*-
;;;; 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-curried-definitions)
  #:use-module (test-suite lib)
  #:use-module (ice-9 curried-definitions))

(with-test-prefix "define"
  (pass-if "define works as usual"
    (equal? 34
            (primitive-eval '(let ()
                               (define (foo)
                                 34)
                               (foo)))))
  (pass-if "define works as usual (2)"
    (equal? 134
            (primitive-eval '(let ()
                               (define (foo x)
                                 (+ x 34))
                               (foo 100)))))
  (pass-if "currying once"
    (equal? 234
            (primitive-eval '(let ()
                               (define ((foo) x)
                                 (+ x 34))
                               ((foo) 200)))))
  (pass-if "currying twice"
    (equal? 334
            (primitive-eval '(let ()
                               (define (((foo)) x)
                                 (+ x 34))
                               (((foo)) 300)))))

  (pass-if "just a value"
    (equal? 444
            (primitive-eval '(let ()
                               (define foo 444)
                               foo)))))

(with-test-prefix "define*"
  (pass-if "define* works as usual"
    (equal? 34
            (primitive-eval '(let ()
                               (define* (foo)
                                 34)
                               (foo)))))
  (pass-if "define* works as usual (2)"
    (equal? 134
            (primitive-eval '(let ()
                               (define* (foo x)
                                 (+ x 34))
                               (foo 100)))))
  (pass-if "currying once"
    (equal? 234
            (primitive-eval '(let ()
                               (define* ((foo) x)
                                 (+ x 34))
                               ((foo) 200)))))
  (pass-if "currying twice"
    (equal? 334
            (primitive-eval '(let ()
                               (define* (((foo)) x)
                                 (+ x 34))
                               (((foo)) 300)))))

  (pass-if "just a value"
    (equal? 444
            (primitive-eval '(let ()
                               (define* foo 444)
                               foo)))))

license: mit


code:
;;;; ecmascript.test --- ECMAScript.      -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	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-ecmascript)
  #:use-module (test-suite lib)
  #:use-module (language ecmascript parse)
  #:use-module ((system base compile) #:select (compile)))

(define (eread str)
  (call-with-input-string str read-ecmascript))

(define-syntax parse
  (syntax-rules ()
    ((_ expression expected)
     (pass-if expression
       (equal? expected (eread expression))))))

(with-test-prefix "parser"

  (parse "true;" 'true)
  (parse "2 + 2;" '(+ (number 2) (number 2)))
  (parse "\"hello\";" '(string "hello"))
  (parse "function square(x) { return x * x; }"
         '(var (square (lambda (x) (return (* (ref x) (ref x)))))))
  (parse "document.write('Hello, world!');"
         '(call (pref (ref document) write) ((string "Hello, world!"))))
  (parse "var x = { foo: 12, bar: \"hello\" };"
         '(begin (var (x (object (foo (number 12))
                                 (bar (string "hello")))))
                 (begin))))

(define-syntax ecompile
  (syntax-rules ()
    ((_ expression expected)
     (pass-if expression
       (equal? expected
               (compile (call-with-input-string expression read-ecmascript)
                        #:from 'ecmascript
                        #:to 'value))))))

(with-test-prefix "compiler"

  (ecompile "true;" #t)
  (ecompile "2 + 2;" 4)
  (ecompile "\"hello\";" "hello")

  ;; FIXME: Broken!
  ;; (ecompile "[1,2,3,4].map(function(x) { return x * x; });"
  ;;           '(1 4 9 16))

  ;; Examples from
  ;; <http://wingolog.org/archives/2009/02/22/ecmascript-for-guile>.

  (ecompile "42 + \" good times!\";"
            "42 good times!")
  (ecompile "[0,1,2,3,4,5].length * 7;"
            42))


code:
;;;; elisp-compiler.test --- Test the compiler for Elisp.  -*- scheme -*-
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Daniel Kraft
;;;;
;;;; 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-elisp-compiler)
  :use-module (test-suite lib)
  :use-module (system base compile)
  :use-module (language elisp runtime))

; Macros to handle the compilation conveniently.

(define-syntax compile-test
  (syntax-rules (pass-if pass-if-equal pass-if-exception)
    ((_ (pass-if test-name exp))
     (pass-if test-name (compile 'exp #:from 'elisp #:to 'value)))
    ((_ (pass-if test-name exp #:opts opts))
     (pass-if test-name (compile 'exp #:from 'elisp #:to 'value #:opts opts)))
    ((_ (pass-if-equal test-name result exp))
     (pass-if test-name (equal? result
                                (compile 'exp #:from 'elisp #:to 'value))))
    ((_ (pass-if-exception test-name exc exp))
     (pass-if-exception test-name exc
                        (compile 'exp #:from 'elisp #:to 'value)))))

(define-syntax with-test-prefix/compile
  (syntax-rules ()
    ((_ section-name exp ...)
     (with-test-prefix section-name (compile-test exp) ...))))

; Test control structures.
; ========================

(with-test-prefix/compile "Sequencing"

  (pass-if-equal "progn" 1
    (progn (setq a 0)
           (setq a (1+ a))
           a))

  (pass-if "prog1"
    (progn (setq a 0)
           (setq b (prog1 a (setq a (1+ a))))
           (and (= a 1) (= b 0))))

  (pass-if "prog2"
    (progn (setq a 0)
           (setq b (prog2 (setq a (1+ a))
                          (setq a (1+ a))
                          (setq a (1+ a))))
           (and (= a 3) (= b 2)))))

(with-test-prefix/compile "Conditionals"

  (pass-if-equal "succeeding if" 1
    (if t 1 2))
  (pass-if "failing if"
    (and (= (if nil
              1
              (setq a 2) (setq a (1+ a)) a)
            3)
         (equal (if nil 1) nil)))

  (pass-if-equal "failing when" nil-value
    (when nil 1 2 3))
  (pass-if-equal "succeeding when" 42
    (progn (setq a 0)
           (when t (setq a 42) a)))

  (pass-if-equal "failing unless" nil-value
    (unless t 1 2 3))
  (pass-if-equal "succeeding unless" 42
    (progn (setq a 0)
           (unless nil (setq a 42) a)))

  (pass-if-equal "empty cond" nil-value
    (cond))
  (pass-if-equal "all failing cond" nil-value
    (cond (nil) (nil)))
  (pass-if-equal "only condition" 5
    (cond (nil) (5)))
  (pass-if-equal "succeeding cond value" 42
    (cond (nil) (t 42) (t 0)))
  (pass-if-equal "succeeding cond side-effect" 42
    (progn (setq a 0)
           (cond (nil) (t (setq a 42) 1) (t (setq a 0)))
           a)))

(with-test-prefix/compile "Combining Conditions"

  (pass-if-equal "empty and" t-value (and))
  (pass-if-equal "failing and" nil-value (and 1 2 nil 3))
  (pass-if-equal "succeeding and" 3 (and 1 2 3))

  (pass-if-equal "empty or" nil-value (or))
  (pass-if-equal "failing or" nil-value (or nil nil nil))
  (pass-if-equal "succeeding or" 1 (or nil 1 nil 2 nil 3))

  (pass-if-equal "not true" nil-value (not 1))
  (pass-if-equal "not false" t-value (not nil)))

(with-test-prefix/compile "Iteration"

  (pass-if-equal "failing while" 0
    (progn (setq a 0)
           (while nil (setq a 1))
           a))
  (pass-if-equal "running while" 120
    (progn (setq prod 1
                 i 1)
           (while (<= i 5)
             (setq prod (* i prod))
             (setq i (1+ i)))
           prod))

  (pass-if "dotimes"
    (progn (setq a 0)
           (setq count 100)
           (setq b (dotimes (i count)
                     (setq j (1+ i))
                     (setq a (+ a j))))
           (setq c (dotimes (i 10 42) nil))
           (and (= a 5050) (equal b nil) (= c 42))))

  (pass-if "dolist"
    (let ((mylist '(7 2 5)))
      (setq sum 0)
      (setq a (dolist (i mylist)
                (setq sum (+ sum i))))
      (setq b (dolist (i mylist 5) 0))
      (and (= sum (+ 7 2 5))
           (equal a nil)
           (equal mylist '(7 2 5))
           (equal b 5)))))

(with-test-prefix/compile "Exceptions"

  (pass-if "catch without exception"
    (and (setq a 0)
         (= (catch 'foobar
                   (setq a (1+ a))
                   (setq a (1+ a))
                   a)
            2)
         (= (catch (+ 1 2) a) 2)))

  ; FIXME: Figure out how to do this...
  ;(pass-if-exception "uncaught exception" 'elisp-exception
  ;  (throw 'abc 1))

  (pass-if "catch and throw"
    (and (setq mylist '(1 2))
         (= (catch 'abc (throw 'abc 2) 1) 2)
         (= (catch 'abc (catch 'def (throw 'abc (1+ 0)) 2) 3) 1)
         (= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3)
         (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1)))

  (pass-if "unwind-protect"
    (progn (setq a 0 b 1 c 1)
           (catch 'exc
                  (unwind-protect (progn (setq a 1)
                                         (throw 'exc 0))
                                  (setq a 0)
                                  (setq b 0)))
           (unwind-protect nil (setq c 0))
           (and (= a 0) (= b 0) (= c 0)
                (= (unwind-protect 42 1 2 3) 42)))))

(with-test-prefix/compile "Eval"

  (pass-if-equal "basic eval" 3
    (progn (setq code '(+ 1 2))
           (eval code)))

  (pass-if "real dynamic code"
    (and (setq a 1 b 1 c 1)
         (defun set-code (var val)
           (list 'setq var val))
         (= a 1) (= b 1) (= c 1)
         (eval (set-code 'a '(+ 2 3)))
         (eval (set-code 'c 42))
         (= a 5) (= b 1) (= c 42)))

  ; Build code that recursively again and again calls eval.  What we want is
  ; something like:
  ; (eval '(1+ (eval '(1+ (eval 1)))))
  (pass-if "recursive eval"
    (progn (setq depth 10 i depth)
           (setq code '(eval 0))
           (while (not (zerop i))
             (setq code (#{`}# (eval (quote (1+ (#{,}# code))))))
             (setq i (1- i)))
           (= (eval code) depth))))

; Test handling of variables.
; ===========================

(with-test-prefix/compile "Variable Setting/Referencing"

  ; TODO: Check for variable-void error

  (pass-if-equal "setq and reference" 6
    (progn (setq a 1 b 2 c 3)
           (+ a b c)))
  (pass-if-equal "setq evaluation order" 1
    (progn (setq a 0 b 0)
           (setq a 1 b a)))
  (pass-if-equal "setq value" 2
    (progn (setq a 1 b 2)))

  (pass-if "set and symbol-value"
    (progn (setq myvar 'a)
           (and (= (set myvar 42) 42)
                (= a 42)
                (= (symbol-value myvar) 42))))
  (pass-if "void variables"
    (progn (setq a 1 b 2)
           (and (eq (makunbound 'b) 'b)
                (boundp 'a)
                (not (boundp 'b))))))

(with-test-prefix/compile "Let and Let*"

  (pass-if-equal "let without value" nil-value
    (let (a (b 5)) a))
  (pass-if-equal "basic let" 0
    (progn (setq a 0)
           (let ((a 1)
                 (b a))
             b)))

  (pass-if "let*"
    (progn (setq a 0)
           (and (let* ((a 1)
                       (b a))
                  (= b 1))
                (let* (a b)
                  (setq a 1 b 2)
                  (and (= a 1) (= b 2)))
                (= a 0)
                (not (boundp 'b)))))

  (pass-if "local scope"
    (progn (setq a 0)
           (setq b (let (a)
                     (setq a 1)
                     a))
           (and (= a 0)
                (= b 1)))))

(with-test-prefix/compile "Lexical Scoping"

  (pass-if "basic let semantics"
    (and (setq a 1)
         (lexical-let ((a 2) (b a))
           (and (= a 2) (= b 1)))
         (lexical-let* ((a 2) (b a))
           (and (= a 2) (= b 2) (setq a 42) (= a 42)))
         (= a 1)))

  (pass-if "lexical scope with lexical-let's"
    (and (setq a 1)
         (defun dyna () a)
         (lexical-let (a)
           (setq a 2)
           (and (= a 2) (= (dyna) 1)))
         (= a 1)
         (lexical-let* (a)
           (setq a 2)
           (and (= a 2) (= (dyna) 1)))
         (= a 1)))

  (pass-if "lexical scoping vs. symbol-value / set"
    (and (setq a 1)
         (lexical-let ((a 2))
           (and (= a 2)
                (= (symbol-value 'a) 1)
                (set 'a 3)
                (= a 2)
                (= (symbol-value 'a) 3)))
         (= a 3)))

  (pass-if "let inside lexical-let"
    (and (setq a 1 b 1)
         (defun dynvals () (cons a b))
         (lexical-let ((a 2))
           (and (= a 2) (equal (dynvals) '(1 . 1))
                (let ((a 3) (b a))
                  (and (= a 3) (= b 2)
                       (equal (dynvals) '(1 . 2))))
                (let* ((a 4) (b a))
                  (and (= a 4) (= b 4)
                       (equal (dynvals) '(1 . 4))))
                (= a 2)))
         (= a 1)))

  (pass-if "lambda args inside lexical-let"
    (and (setq a 1)
         (defun dyna () a)
         (lexical-let ((a 2) (b 42))
           (and (= a 2) (= (dyna) 1)
                ((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3)
                ((lambda () (let ((a 3))
                              (and (= a 3) (= (dyna) 1)))))
                (= a 2) (= (dyna) 1)))
         (= a 1)))

  (pass-if "closures"
    (and (defun make-counter ()
           (lexical-let ((cnt 0))
             (lambda ()
               (setq cnt (1+ cnt)))))
         (setq c1 (make-counter) c2 (make-counter))
         (= (funcall c1) 1)
         (= (funcall c1) 2)
         (= (funcall c1) 3)
         (= (funcall c2) 1)
         (= (funcall c2) 2)
         (= (funcall c1) 4)
         (= (funcall c2) 3)))

  (pass-if "always lexical option (all)"
    (progn (setq a 0)
           (defun dyna () a)
           (let ((a 1))
             (and (= a 1) (= (dyna) 0))))
    #:opts '(#:always-lexical all))
  (pass-if "always lexical option (list)"
    (progn (setq a 0 b 0)
           (defun dyna () a)
           (defun dynb () b)
           (let ((a 1)
                 (b 1))
             (and (= a 1) (= (dyna) 0)
                  (= b 1) (= (dynb) 1))))
    #:opts '(#:always-lexical (a)))
  (pass-if "with-always-lexical"
    (progn (setq a 0)
           (defun dyna () a)
           (with-always-lexical (a)
             (let ((a 1))
               (and (= a 1) (= (dyna) 0))))))

  (pass-if "lexical lambda args"
    (progn (setq a 1 b 1)
           (defun dyna () a)
           (defun dynb () b)
           (with-always-lexical (a c)
             ((lambda (a b &optional c)
                (and (= a 3) (= (dyna) 1)
                     (= b 2) (= (dynb) 2)
                     (= c 1)))
              3 2 1))))

  ; Check if a lambda without dynamically bound arguments
  ; is tail-optimized by doing a deep recursion that would otherwise overflow
  ; the stack.
  (pass-if "lexical lambda tail-recursion"
    (with-always-lexical (i)
      (setq to 1000000)
      (defun iteration-1 (i)
        (if (< i to)
          (iteration-1 (1+ i))))
      (iteration-1 0)
      (setq x 0)
      (defun iteration-2 ()
        (if (< x to)
          (setq x (1+ x))
          (iteration-2)))
      (iteration-2)
      t)))

(with-test-prefix/compile "defconst and defvar"

  (pass-if-equal "defconst without docstring" 3.141
    (progn (setq pi 3)
           (defconst pi 3.141)
           pi))
  (pass-if-equal "defconst value" 'pi
    (defconst pi 3.141 "Pi"))

  (pass-if-equal "defvar without value" 42
    (progn (setq a 42)
           (defvar a)
           a))
  (pass-if-equal "defvar on already defined variable" 42
    (progn (setq a 42)
           (defvar a 1 "Some docstring is also ok")
           a))
  (pass-if-equal "defvar on undefined variable" 1
    (progn (makunbound 'a)
           (defvar a 1)
           a))
  (pass-if-equal "defvar value" 'a
    (defvar a)))

; Functions and lambda expressions.
; =================================

(with-test-prefix/compile "Lambda Expressions"

  (pass-if-equal "required arguments" 3
    ((lambda (a b c) c) 1 2 3))

  (pass-if-equal "optional argument" 3
    ((function (lambda (a &optional b c) c)) 1 2 3))
  (pass-if-equal "optional missing" nil-value
    ((lambda (&optional a) a)))

  (pass-if-equal "rest argument" '(3 4 5)
    ((lambda (a b &rest c) c) 1 2 3 4 5))
  (pass-if-equal "rest missing" nil-value
    ((lambda (a b &rest c) c) 1 2)))

(with-test-prefix/compile "Function Definitions"

  (pass-if-equal "defun" 3
    (progn (defun test (a b) (+ a b))
           (test 1 2)))
  (pass-if-equal "defun value" 'test
    (defun test (a b) (+ a b)))

  (pass-if "fset and symbol-function"
    (progn (setq myfunc 'x x 5)
           (and (= (fset myfunc 42) 42)
                (= (symbol-function myfunc) 42)
                (= x 5))))
  (pass-if "void function values"
    (progn (setq a 1)
           (defun test (a b) (+ a b))
           (fmakunbound 'a)
           (fset 'b 5)
           (and (fboundp 'b) (fboundp 'test)
                (not (fboundp 'a))
                (= a 1))))

  (pass-if "flet and flet*"
    (progn (defun foobar () 42)
           (defun test () (foobar))
           (and (= (test) 42)
                (flet ((foobar (lambda () 0))
                       (myfoo (symbol-function 'foobar)))
                  (and (= (myfoo) 42)
                       (= (test) 42)))
                (flet* ((foobar (lambda () 0))
                        (myfoo (symbol-function 'foobar)))
                  (= (myfoo) 42))
                (flet (foobar)
                  (defun foobar () 0)
                  (= (test) 42))
                (= (test) 42)))))

(with-test-prefix/compile "Calling Functions"

  (pass-if-equal "recursion" 120
    (progn (defun factorial (n prod)
             (if (zerop n)
               prod
               (factorial (1- n) (* prod n))))
           (factorial 5 1)))

  (pass-if "dynamic scoping"
    (progn (setq a 0)
           (defun foo ()
             (setq a (1+ a))
             a)
           (defun bar (a)
             (foo))
           (and (= 43 (bar 42))
                (zerop a))))

  (pass-if "funcall and apply argument handling"
    (and (defun allid (&rest args) args)
         (setq allid-var (symbol-function 'allid))
         (equal (funcall allid-var 1 2 3) '(1 2 3))
         (equal (funcall allid-var) nil)
         (equal (funcall allid-var 1 2 '(3 4)) '(1 2 (3 4)))
         (equal (funcall allid-var '()) '(()))
         (equal (apply allid-var 1 2 '(3 4)) '(1 2 3 4))
         (equal (apply allid-var '(1 2)) '(1 2))
         (equal (apply allid-var '()) nil)))

  (pass-if "raw functions with funcall"
    (and (= (funcall '+ 1 2) 3)
         (= (funcall (lambda (a b) (+ a b)) 1 2) 3)
         (= (funcall '(lambda (a b) (+ a b)) 1 2) 3))))

; Quoting and Backquotation.
; ==========================

(with-test-prefix/compile "Quotation"

  (pass-if "quote"
    (and (equal '42 42) (equal '"abc" "abc")
         (equal '(1 2 (3 (4) x)) '(1 2 (3 (4) x)))
         (not (equal '(1 2 (3 4 (x))) '(1 2 3 4 x)))
         (equal '(1 2 . 3) '(1 2 . 3))))

  (pass-if "simple backquote"
    (and (equal (#{`}# 42) 42)
         (equal (#{`}# (1 (a))) '(1 (a)))
         (equal (#{`}# (1 . 2)) '(1 . 2))))
  (pass-if "unquote"
    (progn (setq a 42 l '(18 12))
           (and (equal (#{`}# (#{,}# a)) 42)
                (equal (#{`}# (1 a ((#{,}# l)) . (#{,}# a))) '(1 a ((18 12)) . 42)))))
  (pass-if "unquote splicing"
    (progn (setq l '(18 12) empty '())
           (and (equal (#{`}# (#{,@}# l)) '(18 12))
                (equal (#{`}# (l 2 (3 (#{,@}# l)) ((#{,@}# l)) (#{,@}# l)))
                       '(l 2 (3 18 12) (18 12) 18 12))
                (equal (#{`}# (1 2 (#{,@}# empty) 3)) '(1 2 3))))))

; Macros.
; =======

(with-test-prefix/compile "Macros"

  (pass-if-equal "defmacro value" 'magic-number
    (defmacro magic-number () 42))

  (pass-if-equal "macro expansion" 1
    (progn (defmacro take-first (a b) a)
           (take-first 1 (/ 1 0)))))

; Test the built-ins.
; ===================

(with-test-prefix/compile "Equivalence Predicates"

  (pass-if "equal"
    (and (equal 2 2) (not (equal 1 2))
         (equal "abc" "abc") (not (equal "abc" "ABC"))
         (equal 'abc 'abc) (not (equal 'abc 'def))
         (equal '(1 2 (3 4) 5) '(1 2 (3 4) 5))
         (not (equal '(1 2 3 4 5) '(1 2 (3 4) 5)))))

  (pass-if "eq"
    (progn (setq some-list '(1 2))
           (setq some-string "abc")
           (and (eq 2 2) (not (eq 1 2))
                (eq 'abc 'abc) (not (eq 'abc 'def))
                (eq some-string some-string) (not (eq some-string "abc"))
                (eq some-list some-list) (not (eq some-list '(1 2)))))))

(with-test-prefix/compile "Number Built-Ins"

  (pass-if "floatp"
    (and (floatp 1.0) (not (floatp 1)) (not (floatp 'a))))
  (pass-if "integerp"
    (and (integerp 42) (integerp -2) (not (integerp 1.0))))
  (pass-if "numberp"
    (and (numberp 1.0) (numberp -2) (not (numberp 'a))))
  (pass-if "wholenump"
    (and (wholenump 0) (not (wholenump -2)) (not (wholenump 1.0))))
  (pass-if "zerop"
    (and (zerop 0) (zerop 0.0) (not (zerop 1))))

  (pass-if "comparisons"
    (and (= 1 1.0) (/= 0 1)
         (< 1 2) (> 2 1) (>= 1 1) (<= 1 1)
         (not (< 1 1)) (not (<= 2 1))))

  (pass-if "max and min"
    (and (= (max -5 2 4.0 1) 4.0) (= (min -5 2 4.0 1) -5)
         (= (max 1) 1) (= (min 1) 1)))
  (pass-if "abs"
    (and (= (abs 1.0) 1.0) (= (abs -5) 5)))

  (pass-if "float"
    (and (= (float 1) 1) (= (float 5.5) 5.5)
         (floatp (float 1))))

  (pass-if-equal "basic arithmetic operators" -8.5
    (+ (1+ 0) (1- 0) (- 5.5) (* 2 -2) (- 2 1)))
  (pass-if "modulo"
    (= (% 5 3) 2))

  (pass-if "floating point rounding"
    (and (= (ffloor 1.7) 1.0) (= (ffloor -1.2) -2.0) (= (ffloor 1.0) 1.0)
         (= (fceiling 1.2) 2.0) (= (fceiling -1.7) -1.0) (= (fceiling 1.0) 1.0)
         (= (ftruncate 1.6) 1.0) (= (ftruncate -1.7) -1.0)
         (= (fround 1.2) 1.0) (= (fround 1.7) 2.0) (= (fround -1.7) -2.0))))

(with-test-prefix/compile "List Built-Ins"

  (pass-if "consp and atomp"
    (and (consp '(1 2 3)) (consp '(1 2 . 3)) (consp '(a . b))
         (not (consp '())) (not (consp 1)) (not (consp "abc"))
         (atomp 'a) (atomp '()) (atomp -1.5) (atomp "abc")
         (not (atomp '(1 . 2))) (not (atomp '(1)))))
  (pass-if "listp and nlistp"
    (and (listp '(1 2 3)) (listp '(1)) (listp '()) (listp '(1 . 2))
         (not (listp 'a)) (not (listp 42)) (nlistp 42)
         (not (nlistp '())) (not (nlistp '(1 2 3))) (not (nlistp '(1 . 2)))))
  (pass-if "null"
    (and (null '()) (not (null 1)) (not (null '(1 2))) (not (null '(1 . 2)))))

  (pass-if "car and cdr"
    (and (equal (car '(1 2 3)) 1) (equal (cdr '(1 2 3)) '(2 3))
         (equal (car '()) nil) (equal (cdr '()) nil)
         (equal (car '(1 . 2)) 1) (equal (cdr '(1 . 2)) 2)
         (null (cdr '(1)))))
  (pass-if "car-safe and cdr-safe"
    (and (equal (car-safe '(1 2)) 1) (equal (cdr-safe '(1 2)) '(2))
         (equal (car-safe 5) nil) (equal (cdr-safe 5) nil)))

  (pass-if "pop"
    (progn (setq mylist '(a b c))
           (setq value (pop mylist))
           (and (equal value 'a)
                (equal mylist '(b c)))))
  (pass-if-equal "push" '(a b c)
    (progn (setq mylist '(b c))
           (push 'a mylist)))

  (pass-if "nth and nthcdr"
    (and (equal (nth -5 '(1 2 3)) 1) (equal (nth 3 '(1 2 3)) nil)
         (equal (nth 0 '(1 2 3)) 1) (equal (nth 2 '(1 2 3)) 3)
         (equal (nthcdr -5 '(1 2 3)) '(1 2 3))
         (equal (nthcdr 4 '(1 2 3)) nil)
         (equal (nthcdr 1 '(1 2 3)) '(2 3))
         (equal (nthcdr 2 '(1 2 3)) '(3))))

  (pass-if "length"
    (and (= (length '()) 0)
         (= (length '(1 2 3 4 5)) 5)
         (= (length '(1 2 (3 4 (5)) 6)) 4)))

  (pass-if "cons, list and make-list"
    (and (equal (cons 1 2) '(1 . 2)) (equal (cons 1 '(2 3)) '(1 2 3))
         (equal (cons 1 '()) '(1))
         (equal (list 'a) '(a)) (equal (list) '()) (equal (list 1 2) '(1 2))
         (equal (make-list 3 42) '(42 42 42))
         (equal (make-list 0 1) '())))
  (pass-if "append"
    (and (equal (append '(1 2) '(3 4) '(5)) '(1 2 3 4 5))
         (equal (append '(1 2) 3) '(1 2 . 3))))
  (pass-if "reverse"
    (and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5))
         (equal (reverse '()) '())))
  (pass-if "copy-tree"
    (progn (setq mylist '(1 2 (3 4)))
           (and (not (eq mylist (copy-tree mylist)))
                (equal mylist (copy-tree mylist)))))

  (pass-if "number-sequence"
    (and (equal (number-sequence 5) '(5))
         (equal (number-sequence 5 9) '(5 6 7 8 9))
         (equal (number-sequence 5 9 3) '(5 8))
         (equal (number-sequence 5 1 -2) '(5 3 1))
         (equal (number-sequence 5 8 -1) '())
         (equal (number-sequence 5 1) '())
         (equal (number-sequence 5 5 0) '(5))))

  (pass-if "setcar and setcdr"
    (progn (setq pair '(1 . 2))
           (setq copy pair)
           (setq a (setcar copy 3))
           (setq b (setcdr copy 4))
           (and (= a 3) (= b 4)
                (equal pair '(3 . 4))))))


code:
;;;; elisp-reader.test --- Test the reader used by the Elisp compiler.
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Daniel Kraft
;;;;
;;;; 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-elisp-reader)
  :use-module (test-suite lib)
  :use-module (language elisp lexer)
  :use-module (language elisp parser))

; ==============================================================================
; Test the lexer.

(define (get-string-lexer str)
  (call-with-input-string str get-lexer))

(define (lex-all lexer)
  (let iterate ((result '()))
    (let ((token (lexer)))
      (if (eq? (car token) 'eof)
        (reverse result)
        (iterate (cons token result))))))

(define (lex-string str)
  (lex-all (get-string-lexer str)))

(with-test-prefix "Lexer"

  (let ((lexer (get-string-lexer "")))
    (pass-if "end-of-input"
      (and (eq? (car (lexer)) 'eof)
           (eq? (car (lexer)) 'eof)
           (eq? (car (lexer)) 'eof))))

  (pass-if "single character tokens"
    (equal? (lex-string "()[]'`,,@ . ")
      '((paren-open . #f) (paren-close . #f)
        (square-open . #f) (square-close . #f)
        (quote . #f) (backquote . #f)
        (unquote . #f) (unquote-splicing . #f) (dot . #f))))

  (pass-if "whitespace and comments"
    (equal? (lex-string "   (\n\t) ; this is a comment\n.   ; until eof")
      '((paren-open . #f) (paren-close . #f) (dot . #f))))

  (pass-if "source properties"
    (let ((x (car (lex-string "\n\n  \n  .  \n"))))
      (and (= (source-property x 'line) 4)
           (= (source-property x 'column) 3))))

  (pass-if "symbols"
    (equal? (lex-string "foo FOO char-to-string 1+ \\+1
                         \\(*\\ 1\\ 2\\)
                         +-*/_~!@$%^&=:<>{}
                         abc(def)ghi .e5")
            `((symbol . foo) (symbol . FOO) (symbol . char-to-string)
              (symbol . 1+) (symbol . ,(string->symbol "+1"))
              (symbol . ,(string->symbol "(* 1 2)"))
              (symbol . +-*/_~!@$%^&=:<>{})
              (symbol . abc) (paren-open . #f) (symbol . def)
              (paren-close . #f) (symbol . ghi) (symbol . .e5))))

  ; Here we make use of the property that exact/inexact numbers are not equal?
  ; even when they have the same numeric value!
  (pass-if "integers"
    (equal? (lex-string "-1 1 1. +1 01234")
            '((integer . -1) (integer . 1) (integer . 1) (integer . 1)
              (integer . 1234))))
  (pass-if "floats"
    (equal? (lex-string "1500.0 15e2 15.e2 1.5e3 .15e4 -.345e-2")
            '((float . 1500.0) (float . 1500.0) (float . 1500.0)
              (float . 1500.0) (float . 1500.0)
              (float . -0.00345))))

  ; Check string lexing, this also checks basic character escape sequences
  ; that are then (hopefully) also correct for character literals.
  (pass-if "strings"
    (equal? (lex-string "\"foo\\nbar
test\\
\\\"ab\\\"\\\\ ab\\ cd
\\418\\0415\\u0041\\U0000000A\\Xab\\x0000000000000004fG.\"  ")
            '((string . "foo\nbar
test\"ab\"\\ abcd
!8!5A\nXabOG."))))
  (pass-if "ASCII control characters and meta in strings"
    (equal? (lex-string "\"\\^?\\C-a\\C-A\\^z\\M-B\\M-\\^@\\M-\\C-a\"")
            '((string . "\x7F\x01\x01\x1A\xC2\x80\x81"))))

  ; Character literals, taking into account that some escape sequences were
  ; already checked in the strings.
  (pass-if "characters"
    (equal? (lex-string "?A?\\z ? ?\\x21 ?\\^j ?\\\\?\\n?\\\n")
            `((character . 65) (character . ,(char->integer #\z))
              (character . 32) (character . ,(char->integer #\!))
              (character . 10) (character . ,(char->integer #\\))
              (character . 10) (character . 10))))
  (pass-if "meta characters"
    (equal? (map cdr (lex-string "?\\C-[?\\M-\\S-Z?\\^X?\\A-\\s-\\H-\\s"))
            `(,(+ (expt 2 26) (char->integer #\[))
              ,(+ (expt 2 27) (expt 2 25) (char->integer #\Z))
              ,(- (char->integer #\X) (char->integer #\@))
              ,(+ (expt 2 22) (expt 2 23) (expt 2 24) 32))))

  (pass-if "circular markers"
    (equal? (lex-string "#0342= #1#")
            '((circular-def . 342) (circular-ref . 1))))

  (let* ((lex1-string "#1='((1 2) [2 [3]] 5)")
         (lexer (call-with-input-string (string-append lex1-string " 1 2")
                                        get-lexer/1)))
    (pass-if "lexer/1"
      (and (equal? (lex-all lexer) (lex-string lex1-string))
           (eq? (car (lexer)) 'eof)
           (eq? (car (lexer)) 'eof)))))

; ==============================================================================
; Test the parser.

(define (parse-str str)
  (call-with-input-string str read-elisp))

(with-test-prefix "Parser"

  (pass-if "only next expression"
    (equal? (parse-str "1 2 3") 1))

  (pass-if "source properties"
    (let* ((list1 (parse-str "\n\n   (\n(7)  (42))"))
           (list2 (car list1))
           (list3 (cadr list1)))
      (and (= (source-property list1 'line) 3)
           (= (source-property list1 'column) 4)
           (= (source-property list2 'line) 4)
           (= (source-property list2 'column) 1)
           (= (source-property list3 'line) 4)
           (= (source-property list3 'column) 6))))

  (pass-if "constants"
    (and (equal? (parse-str "-12") -12)
         (equal? (parse-str ".123") 0.123)
         (equal? (parse-str "foobar") 'foobar)
         (equal? (parse-str "\"abc\"") "abc")
         (equal? (parse-str "?A") 65)
         (equal? (parse-str "?\\C-@") 0)))

  (pass-if "quotation"
    (and (equal? (parse-str "'(1 2 3 '4)")
                 '(quote (1 2 3 (quote 4))))
         (equal? (parse-str "`(1 2 ,3 ,@a)")
                 '(#{`}# (1 2 (#{,}# 3) (#{,@}# a))))))

  (pass-if "lists"
    (equal? (parse-str "(1 2 (3) () 4 (. 5) (1 2 . (3 4)) (1 . 2) . 42)")
            '(1 2 (3) () 4 5 (1 2 3 4) (1 . 2) . 42)))

  (pass-if "vectors"
    (equal? (parse-str "[1 2 [] (3 4) \"abc\" d]")
            #(1 2 #() (3 4) "abc" d)))

  (pass-if "circular structures"
    (and (equal? (parse-str "(#1=a #2=b #1# (#1=c #1# #2#) #1#)")
                 '(a b a (c c b) c))
         (let ((eqpair (parse-str "(#1=\"foobar\" . #1#)")))
           (eq? (car eqpair) (cdr eqpair)))
         (let ((circlst (parse-str "#1=(42 #1# #1=5 #1#)")))
           (and (eq? circlst (cadr circlst))
                (equal? (cddr circlst) '(5 5))))
         (let ((circvec (parse-str "#1=[a #1# b]")))
           (eq? circvec (vector-ref circvec 1))))))


code:
;;;; elisp.test --- tests guile's elisp support     -*- scheme -*-
;;;; Copyright (C) 2002, 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-suite test-elisp)
  #:use-module (test-suite lib)
  #:use-module (system base compile)
  #:use-module (ice-9 weak-vector))

(with-test-prefix "scheme"

  (with-test-prefix "nil value is a boolean"

    (pass-if "boolean?"
      (boolean? #nil)))

  (with-test-prefix "nil value is false"

    (pass-if "not"
      (eq? (not #nil) #t))

    (pass-if "if"
      (if #nil #f #t))

    (pass-if "and"
      (eq? (and #nil #t) #f))

    (pass-if "or"
      (eq? (or #nil #f) #f))

    (pass-if "cond"
      (cond (#nil #f) (else #t)))

    (pass-if "do"
      (call-with-current-continuation
       (lambda (exit)
         (do ((i 0 (+ i 1)))
             (#nil (exit #f))
           (if (> i 10)
               (exit #t)))))))

  (with-test-prefix "nil value as an empty list"

    (pass-if "list?"
      (list? #nil))

    (pass-if "null?"
      (null? #nil))

    (pass-if "sort"
      (eq? (sort #nil <) #nil)))

  (with-test-prefix "lists formed using nil value"

    (pass-if "list?"
      (list? (cons 'a #nil)))

    (pass-if "length of #nil"
      (= (length #nil) 0))

    (pass-if "length"
      (= (length (cons 'a (cons 'b (cons 'c #nil)))) 3))

    (pass-if "length (with backquoted list)"
      (= (length '(a b c . #nil)) 3))

    (pass-if "write (#nil)"
      (string=? (with-output-to-string
                  (lambda () (write #nil)))
                "#nil"))		; Hmmm... should be "()" ?

    (pass-if "display (#nil)"
      (string=? (with-output-to-string
                  (lambda () (display #nil)))
                "#nil"))		; Ditto.

    (pass-if "write (list)"
      (string=? (with-output-to-string
                  (lambda () (write (cons 'a #nil))))
                "(a)"))

    (pass-if "display (list)"
      (string=? (with-output-to-string
                  (lambda () (display (cons 'a #nil))))
                "(a)"))

    (pass-if "assq"
      (and (equal? (assq 1 '((1 one) (2 two) . #nil))
                   '(1 one))
           (equal? (assq 3 '((1 one) (2 two) . #nil))
                   #f)))

    (pass-if "assv"
      (and (equal? (assv 1 '((1 one) (2 two) . #nil))
                   '(1 one))
           (equal? (assv 3 '((1 one) (2 two) . #nil))
                   #f)))

    (pass-if "assoc"
      (and (equal? (assoc 1 '((1 one) (2 two) . #nil))
                   '(1 one))
           (equal? (assoc 3 '((1 one) (2 two) . #nil))
                   #f)))

    (pass-if "with-fluids*"
      (let ((f (make-fluid))
            (g (make-fluid)))
        (with-fluids* (cons f (cons g #nil))
                      '(3 4)
                      (lambda ()
                        (and (eq? (fluid-ref f) 3)
                             (eq? (fluid-ref g) 4))))))

    (pass-if "append!"
      (let ((a (copy-tree '(1 2 3)))
            (b (copy-tree '(4 5 6 . #nil)))
            (c (copy-tree '(7 8 9)))
            (d (copy-tree '(a b c . #nil))))
        (equal? (append! a b c d)
                '(1 2 3 4 5 6 7 8 9 a b c . #nil))))

    (pass-if "last-pair"
      (equal? (last-pair '(1 2 3 4 5 . #nil))
              (cons 5 #nil)))

    (pass-if "reverse"
      (equal? (reverse '(1 2 3 4 5 . #nil))
              '(5 4 3 2 1)))            ; Hmmm... is this OK, or
					; should it be
					; '(5 4 3 2 1 . #nil) ?

    (pass-if "reverse!"
      (equal? (reverse! (copy-tree '(1 2 3 4 5 . #nil)))
              '(5 4 3 2 1)))            ; Ditto.

    (pass-if "list-ref"
      (eq? (list-ref '(0 1 2 3 4 . #nil) 4) 4))

    (pass-if-exception "list-ref"
                       exception:out-of-range
                       (eq? (list-ref '(0 1 2 3 4 . #nil) 6) 6))

    (pass-if "list-set!"
      (let ((l (copy-tree '(0 1 2 3 4 . #nil))))
        (list-set! l 4 44)
        (= (list-ref l 4) 44)))

    (pass-if-exception "list-set!"
                       exception:out-of-range
                       (let ((l (copy-tree '(0 1 2 3 4 . #nil))))
                         (list-set! l 6 44)
                         (= (list-ref l 6) 44)))

    (pass-if "list-cdr-set!"
      (let ((l (copy-tree '(0 1 2 3 4 . #nil))))
        (and (begin
               (list-cdr-set! l 4 44)
               (equal? l '(0 1 2 3 4 . 44)))
             (begin
               (list-cdr-set! l 3 '(new . #nil))
               (equal? l '(0 1 2 3 new . #nil))))))

    (pass-if-exception "list-cdr-set!"
                       exception:out-of-range
                       (let ((l (copy-tree '(0 1 2 3 4 . #nil))))
                         (list-cdr-set! l 6 44)))

    (pass-if "memq"
      (equal? (memq 'c '(a b c d . #nil)) '(c d . #nil)))

    (pass-if "memv"
      (equal? (memv 'c '(a b c d . #nil)) '(c d . #nil)))

    (pass-if "member"
      (equal? (member "c" '("a" "b" "c" "d" . #nil)) '("c" "d" . #nil)))

    (pass-if "list->vector"
      (equal? '#(1 2 3) (list->vector '(1 2 3 . #nil))))

    (pass-if "list->vector"
      (equal? '#(1 2 3) (list->vector '(1 2 3 . #nil))))

    (pass-if "list->weak-vector"
      (equal? (weak-vector 1 2 3) (list->weak-vector '(1 2 3 . #nil))))

    (pass-if "sorted?"
      (and (sorted? '(1 2 3 . #nil) <)
           (not (sorted? '(1 6 3 . #nil) <))))

    (pass-if "merge"
      (equal? (merge '(1 4 7 10)
                     (merge '(2 5 8 11 . #nil)
                            '(3 6 9 12 . #nil)
                            <)
                     <)
              '(1 2 3 4 5 6 7 8 9 10 11 12 . #nil)))

    (pass-if "merge!"
      (equal? (merge! (copy-tree '(1 4 7 10))
                      (merge! (copy-tree '(2 5 8 11 . #nil))
                              (copy-tree '(3 6 9 12 . #nil))
                              <)
                      <)
              '(1 2 3 4 5 6 7 8 9 10 11 12 . #nil)))

    (pass-if "sort"
      (equal? (sort '(1 5 3 8 4 . #nil) <) '(1 3 4 5 8)))

    (pass-if "stable-sort"
      (equal? (stable-sort '(1 5 3 8 4 . #nil) <) '(1 3 4 5 8)))

    (pass-if "sort!"
      (equal? (sort! (copy-tree '(1 5 3 8 4 . #nil)) <)
              '(1 3 4 5 8)))

    (pass-if "stable-sort!"
      (equal? (stable-sort! (copy-tree '(1 5 3 8 4 . #nil)) <)
              '(1 3 4 5 8))))

  (with-test-prefix "value preservation"

    (pass-if "car"
      (eq? (car (cons #nil 'a)) #nil))

    (pass-if "cdr"
      (eq? (cdr (cons 'a #nil)) #nil))

    (pass-if "vector-ref"
      (eq? (vector-ref (vector #nil) 0) #nil))))

;;;
;;; elisp
;;;

(with-test-prefix "elisp"

  (define (elisp-pass-if expr expected)
    (pass-if (with-output-to-string
               (lambda ()
                 (write expr)))
      (let ((calc (with-output-to-string
                    (lambda ()
                      (write (compile expr #:from 'elisp #:to 'value))))))
        (string=? calc expected))))

  (define (elisp-pass-if/maybe-error key expr expected)
    (pass-if (with-output-to-string (lambda () (write expr)))
      (string=?
       (catch key
         (lambda ()
           (with-output-to-string
             (lambda () (write (eval-elisp expr)))))
         (lambda (k . args)
           (format (current-error-port)
                   "warning: caught ~a: ~a\n" k args)
           (throw 'unresolved)))
       expected)))

  (elisp-pass-if '(and #f) "#f")
  (elisp-pass-if '(and #t) "#t")
  (elisp-pass-if '(and nil) "#nil")
  (elisp-pass-if '(and t) "#t")
  (elisp-pass-if '(and) "#t")
  (elisp-pass-if '(cond (nil t) (t 3)) "3")
  (elisp-pass-if '(cond (nil t) (t)) "#t")
  (elisp-pass-if '(cond (nil)) "#nil")
  (elisp-pass-if '(cond) "#nil")
  (elisp-pass-if '(if #f 'a 'b) "b")
  (elisp-pass-if '(if #t 'a 'b) "a")
  (elisp-pass-if '(if nil 'a 'b) "b")
  (elisp-pass-if '(if nil 1 2 3 4) "4")
  (elisp-pass-if '(if nil 1 2) "2")
  (elisp-pass-if '(if nil 1) "#nil")
  (elisp-pass-if '(if t 1 2) "1")
  (elisp-pass-if '(if t 1) "1")
  (elisp-pass-if '(let (a) a) "#nil")
  (elisp-pass-if '(let* (a) a) "#nil")
  (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2")
  (elisp-pass-if '(null nil) "#t")
  (elisp-pass-if '(or 1 2 3) "1")
  (elisp-pass-if '(or nil t nil) "#t")
  (elisp-pass-if '(or nil) "#nil")
  (elisp-pass-if '(or t nil t) "#t")
  (elisp-pass-if '(or t) "#t")
  (elisp-pass-if '(or) "#nil")
  (elisp-pass-if '(prog1 1 2 3) "1")
  (elisp-pass-if '(prog2 1 2 3) "2")
  (elisp-pass-if '(progn 1 2 3) "3")
  (elisp-pass-if '(while nil 1) "#nil")

  (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r)) "testf")
  (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)")
  (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))")
  ;; NB `lambda' in Emacs is self-quoting, but that's only after
  ;; loading the macro definition of lambda in subr.el.
  (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))")

  (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil)
                 "(1 2 3 #nil)")

  (elisp-pass-if '(setq x 3) "3")
  (elisp-pass-if '(defvar x 4) "x")
  (elisp-pass-if 'x "3")

  ;; wingo 9 april 2010: the following 10 tests are currently failing. the if &
  ;; null tests are good, but I think some of the memq tests are bogus, given
  ;; our current thoughts on equalty and nil; though they should succeed with
  ;; memv and member in the elisp case. Also I think the function test is bogus.
  #;
  (elisp-pass-if '(if '() 'a 'b) "b")
  #;
  (elisp-pass-if '(null '#f) "#t")
  #;
  (elisp-pass-if '(null '()) "#t")
  #;
  (elisp-pass-if '(null 'nil) "#t")
  #;
  (elisp-pass-if '(memq '() '(())) "(())")
  #;
  (elisp-pass-if '(memq '() '(nil)) "(#nil)")
  #;
  (elisp-pass-if '(memq '() '(t)) "#nil")
  #;
  (elisp-pass-if '(memq nil '(())) "(())")
  #;
  (elisp-pass-if '(memq nil '(nil)) "(#nil)")
  #;
  (elisp-pass-if '(memq nil (list nil)) "(#nil)")
  #;
  (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))")
  )

;;; elisp.test ends here


code:
;;;; encoding-escapes.test --- test suite for Guile's string encodings -*- mode: scheme; coding: utf-8 -*-
;;;;
;;;; Copyright (C) 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-strings)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-1))

;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
  (apply string (map integer->char args)))

(define s1 "última")
(define s2 "cédula")
(define s3 "años")
(define s4 "羅生門")

(with-test-prefix "internal encoding"

  (pass-if "ultima"
	   (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61)))

  (pass-if "cedula"
	   (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61)))

  (pass-if "anos"
	   (string=? s3 (string-ints #x61 #xf1 #x6f #x73)))

  (pass-if "Rashomon"
	   (string=? s4 (string-ints #x7f85 #x751f #x9580))))

(with-test-prefix "chars"

  (pass-if "ultima"
	   (list= eqv? (string->list s1)
		  (list #\372 #\l #\t #\i #\m #\a)))

  (pass-if "cedula"
	   (list= eqv? (string->list s2)
		  (list #\c #\351 #\d #\u #\l #\a)))

  (pass-if "anos"
	   (list= eqv? (string->list s3)
		  (list #\a #\361 #\o #\s)))

  (pass-if "Rashomon"
	   (list= eqv? (string->list s4)
		  (list #\77605 #\72437 #\112600))))

;; Check that an error is flagged on display output when the output
;; error strategy is 'error

(with-test-prefix "display output errors"

  (pass-if-exception "ultima"
		     exception:encoding-error
		     (let ((pt (open-output-string)))
		       (set-port-encoding! pt "ASCII")
		       (set-port-conversion-strategy! pt 'error)
		       (display s1 pt)))

  (pass-if-exception "Rashomon"
		     exception:encoding-error
		     (let ((pt (open-output-string)))
		       (set-port-encoding! pt "ASCII")
		       (set-port-conversion-strategy! pt 'error)
		       (display s4 pt))))

;; Check that questions marks or substitutions appear when the conversion
;; mode is substitute
(with-test-prefix "display output substitutions"

  (pass-if "ultima"
	   (let ((pt (open-output-string)))
	     (set-port-encoding! pt "ASCII")
	     (set-port-conversion-strategy! pt 'substitute)
	     (display s1 pt)
	     (string=? "?ltima"
		       (get-output-string pt))))

  (pass-if "Rashomon"
	   (let ((pt (open-output-string)))
	     (set-port-encoding! pt "ASCII")
	     (set-port-conversion-strategy! pt 'substitute)
	     (display s4 pt)
	     (string=? "???"
		       (get-output-string pt)))))

;; Check that hex escapes appear in the write output and that no error
;; is thrown.  The output error strategy should be irrelevant here.
(with-test-prefix "display output escapes"

  (pass-if "ultima"
	   (let ((pt (open-output-string)))
	     (set-port-encoding! pt "ASCII")
	     (set-port-conversion-strategy! pt 'escape)
	     (display s1 pt)
	     (string=? "\\xfaltima"
		       (get-output-string pt))))
  (pass-if "Rashomon"
    (let ((pt (open-output-string)))
      (set-port-encoding! pt "ASCII")
      (set-port-conversion-strategy! pt 'escape)
      (display s4 pt)
      (string=? "\\u7F85\\u751F\\u9580"
                (get-output-string pt)))))

(with-test-prefix "input escapes"

  (pass-if "última"
    (with-locale "en_US.utf8"
                 (string=? "última"
                           (with-input-from-string "\"\\xfaltima\"" read))))

  (pass-if "羅生門"
    (with-locale "en_US.utf8"
                 (string=? "羅生門"
                           (with-input-from-string
                               "\"\\u7F85\\u751F\\u9580\"" read)))))


code:
;;;; encoding-iso88591.test --- test suite for Guile's string encodings    -*- mode: scheme; coding: iso-8859-1 -*-
;;;;
;;;; Copyright (C) 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-strings)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-1))

;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
  (apply string (map integer->char args)))

;; Set locale to the environment's locale, so that the prints look OK.
(define oldlocale #f)
(if (defined? 'setlocale)
    (set! oldlocale (setlocale LC_ALL "")))

(define ascii-a (integer->char 65))     ; LATIN CAPITAL LETTER A
(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
(define alpha (integer->char #x03b1))   ; GREEK SMALL LETTER ALPHA
(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A

(with-test-prefix "characters"
  (pass-if "input A"
    (char=? ascii-a #\A))

  (pass-if "input A acute"
    (char=? a-acute #\�))

  (pass-if "display A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-1")
             (set-port-conversion-strategy! pt 'escape)
             (display ascii-a pt)
             (string=? "A"
                       (get-output-string pt))))

  (pass-if "display A acute"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-1")
             (set-port-conversion-strategy! pt 'escape)
             (display a-acute pt)
             (string=? "�"
                       (get-output-string pt))))

  (pass-if "display alpha"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-1")
             (set-port-conversion-strategy! pt 'escape)
             (display alpha pt)
             (string-ci=? "\\u03b1"
                       (get-output-string pt))))

  (pass-if "display Cherokee a"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-1")
             (set-port-conversion-strategy! pt 'escape)
             (display cherokee-a pt)
             (string-ci=? "\\u13a0"
                       (get-output-string pt))))

  (pass-if "write A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-1")
             (set-port-conversion-strategy! pt 'escape)
             (write ascii-a pt)
             (string=? "#\\A"
                       (get-output-string pt))))

  (pass-if "write A acute"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-1")
             (set-port-conversion-strategy! pt 'escape)
             (write a-acute pt)
             (string=? "#\\�"
                       (get-output-string pt)))))

(define s1 "�ltima")
(define s2 "c�dula")
(define s3 "a�os")
(define s4 "�C�mo?")

(with-test-prefix "string length"

  (pass-if "�ltima"
	   (eq? (string-length s1) 6))

  (pass-if "c�dula"
	   (eq? (string-length s2) 6))

  (pass-if "a�os"
	   (eq? (string-length s3) 4))

  (pass-if "�C�mo?"
	   (eq? (string-length s4) 6)))

(with-test-prefix "internal encoding"

  (pass-if "�ltima"
	   (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61)))

  (pass-if "c�dula"
	   (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61)))

  (pass-if "a�os"
	   (string=? s3 (string-ints #x61 #xf1 #x6f #x73)))

  (pass-if "�C�mo?"
	   (string=? s4 (string-ints #xbf #x43 #xf3 #x6d #x6f #x3f))))

(with-test-prefix "chars"

  (pass-if "�ltima"
	   (list= eqv? (string->list s1)
		  (list #\� #\l #\t #\i #\m #\a)))

  (pass-if "c�dula"
	   (list= eqv? (string->list s2)
		  (list #\c #\� #\d #\u #\l #\a)))

  (pass-if "a�os"
	   (list= eqv? (string->list s3)
		  (list #\a #\� #\o #\s)))

  (pass-if "�C�mo?"
	   (list= eqv? (string->list s4)
		  (list #\� #\C #\� #\m #\o #\?))))

(with-test-prefix "symbols == strings"

  (pass-if "�ltima"
	   (eq? (string->symbol s1) '�ltima))

  (pass-if "c�dula"
	   (eq? (string->symbol s2) 'c�dula))

  (pass-if "a�os"
	   (eq? (string->symbol s3) 'a�os))

  (pass-if "�C�mo?"
	   (eq? (string->symbol s4) '�C�mo?)))

(with-test-prefix "non-ascii variable names"

  (pass-if "1"
	   (let ((� 1)
		 (� 2))
	     (eq? (+ � �) 3))))

(with-test-prefix "output errors"

  (pass-if-exception "char 256" exception:encoding-error
		     (let ((pt (open-output-string)))
		       (set-port-encoding! pt "ISO-8859-1")
		       (set-port-conversion-strategy! pt 'error)
		       (display (string-ints 256) pt))))

;; Reset locales
(if (defined? 'setlocale)
    (setlocale LC_ALL oldlocale))


code:
;;;; encoding-iso88697.test --- test suite for Guile's string encodings    -*- mode: scheme; coding: iso-8859-7 -*-
;;;;
;;;; Copyright (C) 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-strings)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-1))

;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
  (apply string (map integer->char args)))

(define oldlocale #f)
(if (defined? 'setlocale)
    (set! oldlocale (setlocale LC_ALL "")))
(define ascii-a (integer->char 65))     ; LATIN CAPITAL LETTER A
(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
(define alpha (integer->char #x03b1))   ; GREEK SMALL LETTER ALPHA
(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A

(with-test-prefix "characters"
  (pass-if "input A"
    (char=? ascii-a #\A))

  (pass-if "input alpha"
    (char=? alpha #\�))

  (pass-if "display A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-7")
             (set-port-conversion-strategy! pt 'escape)
             (display ascii-a pt)
             (string=? "A"
                       (get-output-string pt))))

  (pass-if "display A acute"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-7")
             (set-port-conversion-strategy! pt 'escape)
             (display a-acute pt)
             (string-ci=? "\\xc1"
                       (get-output-string pt))))

  (pass-if "display alpha"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-7")
             (set-port-conversion-strategy! pt 'escape)
             (display alpha pt)
             (string-ci=? "�"
                       (get-output-string pt))))

  (pass-if "display Cherokee A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-7")
             (set-port-conversion-strategy! pt 'escape)
             (display cherokee-a pt)
             (string-ci=? "\\u13a0"
                       (get-output-string pt))))

  (pass-if "write A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-7")
             (set-port-conversion-strategy! pt 'escape)
             (write ascii-a pt)
             (string=? "#\\A"
                       (get-output-string pt))))

  (pass-if "write alpha"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "ISO-8859-7")
             (set-port-conversion-strategy! pt 'escape)
             (write alpha pt)
             (string=? "#\\�"
                       (get-output-string pt)))))

(define s1 "����")
(define s2 "���")
(define s3 "��������")
(define s4 "���")

(with-test-prefix "string length"

  (pass-if "s1"
	   (eq? (string-length s1) 4))

  (pass-if "s2"
	   (eq? (string-length s2) 3))

  (pass-if "s3"
	   (eq? (string-length s3) 8))

  (pass-if "s4"
	   (eq? (string-length s4) 3)))

(with-test-prefix "internal encoding"

  (pass-if "s1"
	   (string=? s1 (string-ints #x03a0 #x03b5 #x03c1 #x03af)))

  (pass-if "s2"
	   (string=? s2 (string-ints #x03c4 #x03b7 #x03c2)))

  (pass-if "s3"
	   (string=? s3 (string-ints #x03ba #x03c1 #x03b9 #x03c4 #x03b9 #x03ba #x03ae #x03c2)))

  (pass-if "s4"
	   (string=? s4 (string-ints #x03ba #x03b1 #x03b9))))

(with-test-prefix "chars"

  (pass-if "s1"
	   (list= eqv? (string->list s1)
		  (list #\� #\� #\� #\�)))

  (pass-if "s2"
	   (list= eqv? (string->list s2)
		  (list #\� #\� #\�)))

  (pass-if "s3"
	   (list= eqv? (string->list s3)
		  (list #\� #\� #\� #\� #\� #\� #\� #\�)))

  (pass-if "s4"
	   (list= eqv? (string->list s4)
		  (list #\� #\� #\�))))

(with-test-prefix "symbols == strings"

  (pass-if "����"
	   (eq? (string->symbol s1) '����))

  (pass-if "���"
	   (eq? (string->symbol s2) '���))

  (pass-if "��������"
	   (eq? (string->symbol s3) '��������))

  (pass-if "���"
	   (eq? (string->symbol s4) '���)))

(with-test-prefix "non-ascii variable names"

  (pass-if "1"
	   (let ((� 1)
		 (� 2))
	     (eq? (+ � �) 3))))

(with-test-prefix "output errors"

  (pass-if-exception "char #x0400"
		     exception:encoding-error
		     (let ((pt (open-output-string)))
		       (set-port-encoding! pt "ISO-8859-7")
		       (set-port-conversion-strategy! pt 'error)
		       (display (string-ints #x0400) pt))))

;; Reset locale
(if (defined? 'setlocale)
    (setlocale LC_ALL oldlocale))


code:
;;;; encoding-utf8.test --- test suite for Guile's string encodings    -*- mode: scheme; coding: utf-8 -*-
;;;;
;;;; Copyright (C) 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-strings)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-1))

;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
  (apply string (map integer->char args)))

(define oldlocale #f)
(if (defined? 'setlocale)
    (set! oldlocale (setlocale LC_ALL "")))

(define ascii-a (integer->char 65))     ; LATIN CAPITAL LETTER A
(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
(define alpha (integer->char #x03b1))   ; GREEK SMALL LETTER ALPHA
(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A

(with-test-prefix "characters"
  (pass-if "input A"
    (char=? ascii-a #\A))

  (pass-if "input A acute"
    (char=? a-acute #\Á))

  (pass-if "input alpha"
    (char=? alpha #\α))

  (pass-if "input Cherokee A"
    (char=? cherokee-a #\Ꭰ))

 (pass-if "display A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "UTF-8")
             (set-port-conversion-strategy! pt 'substitute)
             (display ascii-a pt)
             (string=? "A"
                       (get-output-string pt))))

  (pass-if "display A acute"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "UTF-8")
             (set-port-conversion-strategy! pt 'substitute)
             (display a-acute pt)
             (string=? "Á"
                       (get-output-string pt))))

  (pass-if "display alpha"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "UTF-8")
             (set-port-conversion-strategy! pt 'substitute)
             (display alpha pt)
             (string-ci=? "α"
                       (get-output-string pt))))

  (pass-if "display Cherokee A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "UTF-8")
             (set-port-conversion-strategy! pt 'substitute)
             (display cherokee-a pt)
             (string-ci=? "Ꭰ"
                       (get-output-string pt))))

  (pass-if "write A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "UTF-8")
             (set-port-conversion-strategy! pt 'escape)
             (write ascii-a pt)
             (string=? "#\\A"
                       (get-output-string pt))))

  (pass-if "write A acute"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "UTF-8")
             (set-port-conversion-strategy! pt 'escape)
             (write a-acute pt)
             (string=? "#\\Á"
                       (get-output-string pt))))

  (pass-if "write alpha"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "UTF-8")
             (set-port-conversion-strategy! pt 'escape)
             (write alpha pt)
             (string=? "#\\α"
                       (get-output-string pt))))

  (pass-if "write Cherokee A"
           (let ((pt (open-output-string)))
             (set-port-encoding! pt "UTF-8")
             (set-port-conversion-strategy! pt 'escape)
             (write cherokee-a pt)
             (string=? "#\\Ꭰ"
                       (get-output-string pt)))))

(define s1 "última")
(define s2 "cédula")
(define s3 "años")
(define s4 "羅生門")

(with-test-prefix "string length"

  (pass-if "última"
	   (eq? (string-length s1) 6))

  (pass-if "cédula"
	   (eq? (string-length s2) 6))

  (pass-if "años"
	   (eq? (string-length s3) 4))

  (pass-if "羅生門"
	   (eq? (string-length s4) 3)))

(with-test-prefix "internal encoding"

  (pass-if "última"
	   (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61)))

  (pass-if "cédula"
	   (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61)))

  (pass-if "años"
	   (string=? s3 (string-ints #x61 #xf1 #x6f #x73)))

  (pass-if "羅生門"
	   (string=? s4 (string-ints #x7f85 #x751f #x9580))))

(with-test-prefix "chars"

  (pass-if "última"
	   (list= eqv? (string->list s1)
		  (list #\ú #\l #\t #\i #\m #\a)))

  (pass-if "cédula"
	   (list= eqv? (string->list s2)
		  (list #\c #\é #\d #\u #\l #\a)))

  (pass-if "años"
	   (list= eqv? (string->list s3)
		  (list #\a #\ñ #\o #\s)))

  (pass-if "羅生門"
	   (list= eqv? (string->list s4)
		  (list #\羅 #\生 #\門))))

(with-test-prefix "symbols == strings"

  (pass-if "última"
	   (eq? (string->symbol s1) 'última))

  (pass-if "cédula"
	   (eq? (string->symbol s2) 'cédula))

  (pass-if "años"
	   (eq? (string->symbol s3) 'años))

  (pass-if "羅生門"
	   (eq? (string->symbol s4) '羅生門)))

(with-test-prefix "non-ascii variable names"

  (pass-if "1"
	   (let ((芥川龍之介  1)
		 (ñ 2))
	     (eq? (+  芥川龍之介 ñ) 3))))

(if (defined? 'setlocale)
    (setlocale LC_ALL oldlocale))


code:
;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2006, 2007, 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-eval)
  :use-module (test-suite lib)
  :use-module ((srfi srfi-1) :select (unfold count))
  :use-module ((system vm vm) :select (make-vm vm-apply))
  :use-module (ice-9 documentation))

(define exception:bad-expression
  (cons 'syntax-error "Bad expression"))

(define exception:failed-match
  (cons 'syntax-error "failed to match any pattern"))

;;;
;;; miscellaneous
;;;

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

;;;
;;; memoization
;;;

(with-test-prefix "memoization"

  (with-test-prefix "copy-tree"

    (pass-if "(#t . #(#t))"
      (let* ((foo (cons #t (vector #t)))
             (bar (copy-tree foo)))
        (vector-set! (cdr foo) 0 #f)
        (equal? bar '(#t . #(#t)))))

    (pass-if-exception "circular lists in forms"
      exception:wrong-type-arg
      (let ((foo (list #f)))
        (set-cdr! foo foo)
        (copy-tree foo))))

  (pass-if "transparency"
    (let ((x '(begin 1)))
      (eval x (current-module))
      (equal? '(begin 1) x))))

;;;
;;; eval
;;;

(with-test-prefix "evaluator"

  (with-test-prefix "symbol lookup"

    (with-test-prefix "top level"

      (with-test-prefix "unbound"

	(pass-if-exception "variable reference"
	  exception:unbound-var
	  x)

	(pass-if-exception "procedure"
	  exception:unbound-var
	  (x)))))

  (with-test-prefix "parameter error"

    ;; This is currently a bug in guile:
    ;; Macros are accepted as function parameters.
    ;; Functions that 'apply' macros are rewritten!!!

    (pass-if-exception "macro as argument"
      exception:failed-match
      (primitive-eval
       '(let ((f (lambda (p a b) (p a b))))
          (f and #t #t))))

    (pass-if-exception "passing macro as parameter"
      exception:failed-match
      (primitive-eval
       '(let* ((f (lambda (p a b) (p a b)))
               (foo (procedure-source f)))
          (f and #t #t)
          (equal? (procedure-source f) foo))))

    ))

;;;
;;; call
;;;

(with-test-prefix "call"

  (with-test-prefix "wrong number of arguments"

    (pass-if-exception "((lambda () #f) 1)"
      exception:wrong-num-args
      ((lambda () #f) 1))

    (pass-if-exception "((lambda (x) #f))"
      exception:wrong-num-args
      ((lambda (x) #f)))

    (pass-if-exception "((lambda (x) #f) 1 2)"
      exception:wrong-num-args
      ((lambda (x) #f) 1 2))

    (pass-if-exception "((lambda (x y) #f))"
      exception:wrong-num-args
      ((lambda (x y) #f)))

    (pass-if-exception "((lambda (x y) #f) 1)"
      exception:wrong-num-args
      ((lambda (x y) #f) 1))

    (pass-if-exception "((lambda (x y) #f) 1 2 3)"
      exception:wrong-num-args
      ((lambda (x y) #f) 1 2 3))

    (pass-if-exception "((lambda (x . rest) #f))"
      exception:wrong-num-args
      ((lambda (x . rest) #f)))

    (pass-if-exception "((lambda (x y . rest) #f))"
      exception:wrong-num-args
      ((lambda (x y . rest) #f)))

    (pass-if-exception "((lambda (x y . rest) #f) 1)"
      exception:wrong-num-args
      ((lambda (x y . rest) #f) 1))))

;;;
;;; apply
;;;

(with-test-prefix "apply"

  (with-test-prefix "scm_tc7_subr_2o"

    ;; prior to guile 1.6.9 and 1.8.1 this called the function with
    ;; SCM_UNDEFINED, which in the case of make-vector resulted in
    ;; wrong-type-arg, instead of the intended wrong-num-args
    (pass-if-exception "0 args" exception:wrong-num-args
      (apply make-vector '()))

    (pass-if "1 arg"
      (vector? (apply make-vector '(1))))

    (pass-if "2 args"
      (vector? (apply make-vector '(1 2))))

    ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected
    (pass-if-exception "3 args" exception:wrong-num-args
      (apply make-vector '(1 2 3)))))

;;;
;;; map
;;;

(with-test-prefix "map"

  ;; Is documentation available?

  (expect-fail "documented?"
    (documented? map))

  (with-test-prefix "argument error"

    (with-test-prefix "non list argument"
      #t)

    (with-test-prefix "different length lists"

      (pass-if-exception "first list empty"
	exception:out-of-range
	(map + '() '(1)))

      (pass-if-exception "second list empty"
	exception:out-of-range
	(map + '(1) '()))

      (pass-if-exception "first list shorter"
	exception:out-of-range
	(map + '(1) '(2 3)))

      (pass-if-exception "second list shorter"
	exception:out-of-range
	(map + '(1 2) '(3)))
    )))

;;;
;;; define with procedure-name
;;;

(define old-procnames-flag (memq 'procnames (debug-options)))
(debug-enable 'procnames)

;; names are only set on top-level procedures (currently), so these can't be
;; hidden in a let
;;
(define foo-closure (lambda () "hello"))
(define bar-closure foo-closure)
;; make sure that make-procedure-with-setter returns an anonymous
;; procedure-with-setter by passing it an anonymous getter.
(define foo-pws (make-procedure-with-setter
                 (lambda (x) (car x))
                 (lambda (x y) (set-car! x y))))
(define bar-pws foo-pws)

(with-test-prefix "define set procedure-name"

  (expect-fail "closure"
    (eq? 'foo-closure (procedure-name bar-closure)))

  (expect-fail "procedure-with-setter"
    (eq? 'foo-pws (procedure-name bar-pws))))

(if old-procnames-flag
    (debug-enable 'procnames)
    (debug-disable 'procnames))

;;;
;;; promises
;;;

(with-test-prefix "promises"

  (with-test-prefix "basic promise behaviour"

    (pass-if "delay gives a promise"
      (promise? (delay 1)))

    (pass-if "force evaluates a promise"
      (eqv? (force (delay (+ 1 2))) 3))

    (pass-if "a forced promise is a promise"
      (let ((p (delay (+ 1 2))))
	(force p)
	(promise? p)))

    (pass-if "forcing a forced promise works"
      (let ((p (delay (+ 1 2))))
	(force p)
	(eqv? (force p) 3)))

    (pass-if "a promise is evaluated once"
      (let* ((x 1)
	     (p (delay (+ x 1))))
	(force p)
	(set! x (+ x 1))
	(eqv? (force p) 2)))

    (pass-if "a promise may call itself"
      (define p
	(let ((x 0))
	  (delay
	    (begin
	      (set! x (+ x 1))
	      (if (> x 1) x (force p))))))
      (eqv? (force p) 2))

    (pass-if "a promise carries its environment"
      (let* ((x 1) (p #f))
	(let* ((x 2))
	  (set! p (delay (+ x 1))))
	(eqv? (force p) 3)))

    (pass-if "a forced promise does not reference its environment"
      (let* ((g (make-guardian))
	     (p #f))
	(let* ((x (cons #f #f)))
	  (g x)
	  (set! p (delay (car x))))
	(force p)
	(gc)
	(if (not (equal? (g) (cons #f #f)))
	    (throw 'unresolved)
	    #t))))

  (with-test-prefix "extended promise behaviour"

    (pass-if-exception "forcing a non-promise object is not supported"
      exception:wrong-type-arg
      (force 1))

    (pass-if "unmemoizing a promise"
      (display-backtrace
       (let ((stack #f))
         (false-if-exception
          (with-throw-handler #t
                              (lambda ()
                                (let ((f (lambda (g) (delay (g)))))
                                  (force (f error))))
                              (lambda _
                                (set! stack (make-stack #t)))))
         stack)
       (%make-void-port "w"))
      #t)))

;;;
;;; stacks
;;;

(define (stack->frames stack)
  ;; Return the list of frames comprising STACK.
  (unfold (lambda (i)
            (>= i (stack-length stack)))
          (lambda (i)
            (stack-ref stack i))
          1+
          0))

(with-test-prefix "stacks"
  (with-debugging-evaluator

    (pass-if "stack involving a subr"
      ;; The subr involving the error must appear exactly once on the stack.
      (catch 'result
        (lambda ()
          (throw 'unresolved)
          (start-stack 'foo
            (lazy-catch 'wrong-type-arg
              (lambda ()
                ;; Trigger a `wrong-type-arg' exception.
                (fluid-ref 'not-a-fluid))
              (lambda _
                (let* ((stack  (make-stack #t))
                       (frames (stack->frames stack)))
                  (throw 'result
                         (count (lambda (frame)
                                  (and (frame-procedure? frame)
                                       (eq? (frame-procedure frame)
                                            fluid-ref)))
                                frames)))))))
        (lambda (key result)
          (= 1 result))))

    (pass-if "stack involving a gsubr"
      ;; The gsubr involving the error must appear exactly once on the stack.
      ;; This is less obvious since gsubr application may require an
      ;; additional `SCM_APPLY ()' call, which should not be visible to the
      ;; application.
      (catch 'result
        (lambda ()
          (throw 'unresolved)
          (start-stack 'foo
            (lazy-catch 'wrong-type-arg
              (lambda ()
                ;; Trigger a `wrong-type-arg' exception.
                (hashq-ref 'wrong 'type 'arg))
              (lambda _
                (let* ((stack  (make-stack #t))
                       (frames (stack->frames stack)))
                  (throw 'result
                         (count (lambda (frame)
                                  (and (frame-procedure? frame)
                                       (eq? (frame-procedure frame)
                                            hashq-ref)))
                                frames)))))))
        (lambda (key result)
          (= 1 result))))

    (pass-if "arguments of a gsubr stack frame"
      ;; Create a stack with two gsubr frames and make sure the arguments are
      ;; correct.
      (catch 'result
        (lambda ()
          (throw 'unresolved)
          (start-stack 'foo
            (lazy-catch 'wrong-type-arg
              (lambda ()
                ;; Trigger a `wrong-type-arg' exception.
                (substring 'wrong 'type 'arg))
              (lambda _
                (let* ((stack  (make-stack #t))
                       (frames (stack->frames stack)))
                  (throw 'result
                         (map (lambda (frame)
                                (cons (frame-procedure frame)
                                      (frame-arguments frame)))
                              frames)))))))
        (lambda (key result)
          (and (equal? (car result) `(,make-stack #t))
               (pair? (member `(,substring  wrong type arg)
                              (cdr result)))))))))

;;;
;;; letrec init evaluation
;;;

(with-test-prefix "letrec init evaluation"

  (pass-if "lots of inits calculated in correct order"
    (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
		     (e 'e) (f 'f) (g 'g) (h 'h)
		     (i 'i) (j 'j) (k 'k) (l 'l)
		     (m 'm) (n 'n) (o 'o) (p 'p)
		     (q 'q) (r 'r) (s 's) (t 't)
		     (u 'u) (v 'v) (w 'w) (x 'x)
		     (y 'y) (z 'z))
	      (list a b c d e f g h i j k l m
		    n o p q r s t u v w x y z))
	    '(a b c d e f g h i j k l m
	      n o p q r s t u v w x y z))))

;;;
;;; values
;;;

(with-test-prefix "values"

  (pass-if "single value"
    (equal? 1 (values 1)))

  (pass-if "call-with-values"
    (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
            '(1 2 3 4)))

  (pass-if "equal?"
    (equal? (values 1 2 3 4) (values 1 2 3 4))))

;;;
;;; stack overflow handling
;;;

(with-test-prefix "stack overflow"

  (pass-if-exception "exception raised"
    exception:vm-error
    (let ((vm    (make-vm))
          (thunk (let loop () (cons 's (loop)))))
      (vm-apply vm thunk))))

;;; eval.test ends here


code:
;;;; exceptions.test --- tests for Guile's exception handling  -*- scheme -*-
;;;; Copyright (C) 2001, 2003, 2004, 2006, 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

(use-modules (test-suite lib))

(define-macro (throw-test title result . exprs)
  `(pass-if ,title
     (equal? ,result
	     (letrec ((stack '())
		      (push (lambda (val)
			      (set! stack (cons val stack)))))
	       (begin ,@exprs)
	       ;;(display ,title)
	       ;;(display ": ")
	       ;;(write (reverse stack))
	       ;;(newline)
	       (reverse stack)))))

(with-test-prefix "throw/catch"

  (with-test-prefix "wrong type argument"

    (pass-if-exception "(throw 1)"
      exception:wrong-type-arg
      (throw 1)))

  (with-test-prefix "wrong number of arguments"

    (pass-if-exception "(throw)"
      exception:wrong-num-args
      (throw))

    (pass-if-exception "throw 1 / catch 0"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda () #f)))

    (pass-if-exception "throw 2 / catch 1"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a 2))
	(lambda (x) #f)))

    (pass-if-exception "throw 1 / catch 2"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda (x y) #f)))

    (pass-if-exception "throw 3 / catch 2"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a 2 3))
	(lambda (y x) #f)))

    (pass-if-exception "throw 1 / catch 2+"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda (x y . rest) #f))))

  (with-test-prefix "with pre-unwind handler"

    (pass-if "pre-unwind fluid state"
      (equal? '(inner outer arg)
       (let ((fluid-parm (make-fluid))
	     (inner-val #f))
	 (fluid-set! fluid-parm 'outer)
	 (catch 'misc-exc
	   (lambda ()
	     (with-fluids ((fluid-parm 'inner))
	       (throw 'misc-exc 'arg)))
	   (lambda (key . args)
	     (list inner-val
		   (fluid-ref fluid-parm)
		   (car args)))
	   (lambda (key . args)
	     (set! inner-val (fluid-ref fluid-parm))))))))

  (throw-test "normal catch"
	      '(1 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))))

  (throw-test "catch and with-throw-handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler
                        'a
                        (lambda ()
                          (push 2)
                          (throw 'a))
                        (lambda (key . args)
                          (push 3))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with rethrowing throw-handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler
                        'a
                        (lambda ()
                          (push 2)
                          (throw 'a))
                        (lambda (key . args)
                          (push 3)
                          (apply throw key args))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with pre-unwind handler"
	      '(1 3 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))
		     (lambda (key . args)
		       (push 3))))

  (throw-test "catch with rethrowing pre-unwind handler"
	      '(1 3 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))
		     (lambda (key . args)
		       (push 3)
		       (apply throw key args))))

  (throw-test "catch with throw handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'a
					   (lambda ()
					     (push 2)
					     (throw 'a))
					   (lambda (key . args)
					     (push 3))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with rethrowing throw handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'a
					   (lambda ()
					     (push 2)
					     (throw 'a))
					   (lambda (key . args)
					     (push 3)
					     (apply throw key args))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
	      '(1 2 3 5 4 6)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'b
				   (lambda ()
				     (push 2)
				     (catch 'a
					    (lambda ()
					      (push 3)
					      (throw 'b))
					    (lambda (key . args)
					      (push 4))))
				   (lambda (key . args)
				     (push 5)
				     (throw 'a)))
		       (push 6))
		     (lambda (key . args)
		       (push 7))))

  (throw-test "with-throw-handler chaining"
	      '(1 2 3 4 6 8)
	      (catch 'a
	        (lambda ()
		  (push 1)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 2)
		      (with-throw-handler 'a
                        (lambda ()
			  (push 3)
			  (throw 'a))
			(lambda (key . args)
			  (push 4)))
		      (push 5))
		    (lambda (key . args)
		      (push 6)))
		  (push 7))
		(lambda (key . args)
		  (push 8))))

  (throw-test "throw handlers throwing to each other recursively"
	      '(1 2 3 4 8 6 10 12)
	      (catch #t
                (lambda ()
		  (push 1)
		  (with-throw-handler 'a
                    (lambda ()
		      (push 2)
		      (with-throw-handler 'b
		        (lambda ()
			  (push 3)
			  (with-throw-handler 'c
			    (lambda ()
			      (push 4)
			      (throw 'b)
			      (push 5))
			    (lambda (key . args)
			      (push 6)
			      (throw 'a)))
			  (push 7))
			(lambda (key . args)
			  (push 8)
			  (throw 'c)))
		      (push 9))
		    (lambda (key . args)
		      (push 10)
		      (throw 'b)))
		  (push 11))
		(lambda (key . args)
		  (push 12))))

  (throw-test "throw handler throwing to lexically inside catch"
	      '(1 2 7 5 4 6 9)
	      (with-throw-handler 'a
				  (lambda ()
				    (push 1)
				    (catch 'b
					   (lambda ()
					     (push 2)
					     (throw 'a)
					     (push 3))
					   (lambda (key . args)
					     (push 4))
					   (lambda (key . args)
					     (push 5)))
				    (push 6))
				  (lambda (key . args)
				    (push 7)
				    (throw 'b)
				    (push 8)))
	      (push 9))

  (throw-test "reuse of same throw handler after lexically inside catch"
	      '(0 1 2 7 5 4 6 7 10)
	      (catch 'b
	        (lambda ()
		  (push 0)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 1)
		      (catch 'b
		        (lambda ()
			  (push 2)
			  (throw 'a)
			  (push 3))
			(lambda (key . args)
			  (push 4))
			(lambda (key . args)
			  (push 5)))
		      (push 6)
		      (throw 'a))
		    (lambda (key . args)
		      (push 7)
		      (throw 'b)
		      (push 8)))
		  (push 9))
		(lambda (key . args)
		  (push 10))))

  (throw-test "again but with two chained throw handlers"
	      '(0 1 11 2 13 7 5 4 12 13 7 10)
	      (catch 'b
	        (lambda ()
		  (push 0)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 1)
		      (with-throw-handler 'a
		        (lambda ()
			  (push 11)
			  (catch 'b
			    (lambda ()
			      (push 2)
			      (throw 'a)
			      (push 3))
			    (lambda (key . args)
			      (push 4))
			    (lambda (key . args)
			      (push 5)))
			  (push 12)
			  (throw 'a))
			(lambda (key . args)
			  (push 13)))
		      (push 6))
		    (lambda (key . args)
		      (push 7)
		      (throw 'b)))
		  (push 9))
		(lambda (key . args)
		  (push 10))))

  )

(with-test-prefix "false-if-exception"

  (pass-if (false-if-exception #t))
  (pass-if (not (false-if-exception #f)))
  (pass-if (not (false-if-exception (error "xxx"))))

  ;; Not yet working.
  ;;
  ;; (with-test-prefix "in empty environment"
  ;;   ;; an environment with no bindings at all
  ;;   (define empty-environment
  ;;     (make-module 1))
  ;;
  ;;   (pass-if "#t"
  ;;     (eval `(,false-if-exception #t)
  ;; 	    empty-environment))
  ;;   (pass-if "#f"
  ;;     (not (eval `(,false-if-exception #f)
  ;; 		 empty-environment)))
  ;;   (pass-if "exception"
  ;;     (not (eval `(,false-if-exception (,error "xxx"))
  ;;                empty-environment))))
  )


code:
;;;; filesys.test --- test file system functions -*- scheme -*-
;;;;
;;;; Copyright (C) 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-filesys)
  #:use-module (test-suite lib)
  #:use-module (test-suite guile-test))

(define (test-file)
  (data-file-name "filesys-test.tmp"))
(define (test-symlink)
  (data-file-name "filesys-test-link.tmp"))

;;;
;;; copy-file
;;;

(with-test-prefix "copy-file"

  ;; return next prospective file descriptor number
  (define (next-fd)
    (let ((fd (dup 0)))
      (close fd)
      fd))

  ;; in guile 1.6.4 and earlier, copy-file didn't close the input fd when
  ;; the output could not be opened
  (pass-if "fd leak when dest unwritable"
    (let ((old-next (next-fd)))
      (false-if-exception (copy-file "/dev/null" "no/such/dir/foo"))
      (= old-next (next-fd)))))

;;;
;;; lstat
;;;

(with-test-prefix "lstat"

  (pass-if "normal file"
    (call-with-output-file (test-file)
      (lambda (port)
	(display "hello" port)))
    (eqv? 5 (stat:size (lstat (test-file)))))

  (call-with-output-file (test-file)
    (lambda (port)
      (display "hello" port)))
  (false-if-exception (delete-file (test-symlink)))
  (if (not (false-if-exception
	    (begin (symlink (test-file) (test-symlink)) #t)))
      (display "cannot create symlink, lstat test skipped\n")
      (pass-if "symlink"
	;; not much to test, except that it works
	(->bool (lstat (test-symlink))))))

;;;
;;; opendir and friends
;;;

(with-test-prefix "opendir"

  (with-test-prefix "root directory"
    (let ((d (opendir "/")))
      (pass-if "not empty"
	(string? (readdir d)))
      (pass-if "all entries are strings"
	(let more ()
	  (let ((f (readdir d)))
	    (cond ((string? f)
		   (more))
		  ((eof-object? f)
		   #t)
		  (else
		   #f)))))
      (closedir d))))

;;;
;;; stat
;;;

(with-test-prefix "stat"

  (with-test-prefix "filename"

    (pass-if "size"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (eqv? 5 (stat:size (stat (test-file))))))

  (with-test-prefix "file descriptor"

    (pass-if "size"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (let* ((fd (open-fdes (test-file) O_RDONLY))
	     (st (stat fd)))
	(close-fdes fd)
	(eqv? 5 (stat:size st)))))

  (with-test-prefix "port"

    (pass-if "size"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (let* ((port (open-file (test-file) "r+"))
	     (st   (stat port)))
	(close-port port)
	(eqv? 5 (stat:size st))))))

(delete-file (test-file))
(delete-file (test-symlink))