code:
;;;; texinfo.serialize.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

;;; Commentary:
;;
;; Unit tests for (texinfo serialize).
;;
;;; Code:

(define-module (test-suite texinfo-serialize)
  #:use-module (test-suite lib)
  #:use-module (texinfo serialize))

(with-test-prefix "test-serialize"
  (define (assert-serialize stexi str)
    (pass-if str (equal? str (stexi->texi stexi))))

  (assert-serialize '(para)
                    "

")

  (assert-serialize '(para "foo")
                    "foo

")

  (assert-serialize '(var "foo")
                    "@var{foo}")

  ;; i don't remember why braces exists, but as long as it does, a test
  ;; is in order
  (assert-serialize '(*braces* "foo")
                    "@{foo@}")

  (assert-serialize '(value (% (key "foo")))
                    "@value{foo}")

  (assert-serialize '(ref (% (node "foo")))
                    "@ref{foo}")
  (assert-serialize '(ref (% (node "foo") (name "bar")))
                    "@ref{foo,bar}")
  (assert-serialize '(ref (% (node "foo") (name "bar")
                             (section "qux") (info-file "xyzzy")
                             (manual "zarg")))
                    "@ref{foo,bar,qux,xyzzy,zarg}")
  (assert-serialize '(ref (% (section "qux") (info-file "xyzzy")
                             (node "foo") (name "bar")
                             (manual "zarg")))
                    "@ref{foo,bar,qux,xyzzy,zarg}")
  (assert-serialize '(ref (% (node "foo")
                             (manual "zarg")))
                    "@ref{foo,,,,zarg}")

  (assert-serialize '(dots) "@dots{}")

  (assert-serialize '(node (% (name "foo")))
                    "@node foo
")

  (assert-serialize '(node (% (name "foo bar")))
                    "@node foo bar
")
  (assert-serialize '(node (% (name "foo bar") (next "baz")))
                    "@node foo bar, baz
")

  (assert-serialize '(title "Foo")
                    "@title Foo
")
  (assert-serialize '(title "Foo is a " (var "bar"))
                    "@title Foo is a @var{bar}
")

  (assert-serialize '(title "Foo is a " (var "bar") " baz")
                    "@title Foo is a @var{bar} baz
")

  (assert-serialize '(cindex (% (entry "Bar baz, foo")))
                    "@cindex Bar baz, foo
")

  ;; there is a space after @iftex, doesn't matter tho
  (assert-serialize '(iftex
                      (para "This is only for tex.")
                      (para "Note. Foo."))
                    "@iftex
This is only for tex.

Note. Foo.

@end iftex

")

  (assert-serialize '(defun (% (name "frob"))
                       (para "foo?"))
                    "@defun frob
foo?

@end defun

")

  (assert-serialize '(defun (% (name "frob") (arguments "bar"))
                       (para "foo?"))
                    "@defun frob bar
foo?

@end defun

")

  (assert-serialize '(defun (% (name "frob") (arguments "bar" " " "baz"))
                       (para "foo?"))
                    "@defun frob bar baz
foo?

@end defun

")

  (assert-serialize '(defun (% (name "frob") (arguments (var "bar")))
                       (para "foo?"))
                    "@defun frob @var{bar}
foo?

@end defun

")

  (assert-serialize '(defunx (% (name "frob") (arguments (var "bar"))))
                    "@defunx frob @var{bar}
")

  (assert-serialize '(table (% (formatter (var)))
                            (entry (% (heading "Foo bar " (code "baz")))
                                   (para "Frobate")
                                   (para "zzzzz")))
                    "@table @var
@item Foo bar @code{baz}
Frobate

zzzzz

@end table

")

  (assert-serialize '(verbatim "foo")
                    "@verbatim
foo
@end verbatim

")

  (assert-serialize '(deffnx (% (name "foo") (category "bar")))
                    "@deffnx bar foo
")

  (assert-serialize '(deffnx (% (name "foo") (category "bar") (arguments "x" " " "y")))
                    "@deffnx bar foo x y
")

  (assert-serialize '(deffnx (% (name "foo") (category "bar") (arguments "(" "x" " " (code "int") ")")))
                    "@deffnx bar foo (x @code{int})
")

  )


code:
;;;; texinfo.string-utils.test                 -*- scheme -*-
;;;;
;;;; Copyright (C) 2003, 2009, 2010  Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License as
;;;; published by the Free Software Foundation; either version 3 of the
;;;; License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this 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-string-utils)
  #:use-module (test-suite lib)
  #:use-module (texinfo string-utils))

;; **********************************************************************
;; Test for expand-tabs
;; **********************************************************************
(with-test-prefix "test-beginning-expansion"
  (pass-if (equal? "        Hello"
                   (expand-tabs "\tHello")))
  (pass-if (equal? "                Hello"
                   (expand-tabs "\t\tHello"))))

(with-test-prefix "test-ending-expansion"
  (pass-if (equal? "Hello        "
                   (expand-tabs "Hello\t")))
  (pass-if (equal? "Hello                "
                   (expand-tabs "Hello\t\t"))))

(with-test-prefix "test-middle-expansion"
  (pass-if (equal? "Hello        there" (expand-tabs "Hello\tthere")))
  (pass-if (equal? "Hello                there" (expand-tabs "Hello\t\tthere"))))

(with-test-prefix "test-alternate-tab-size"
  (pass-if (equal? "Hello   there"
                   (expand-tabs "Hello\tthere" 3)))
  (pass-if (equal? "Hello    there"
                   (expand-tabs "Hello\tthere" 4)))
  (pass-if (equal? "Hello     there"
                   (expand-tabs "Hello\tthere" 5))))

;; **********************************************************************
;; tests for escape-special-chars
;; **********************************************************************
(with-test-prefix "test-single-escape-char"
  (pass-if (equal? "HeElElo"
                   (escape-special-chars "Hello" #\l #\E))))

(with-test-prefix "test-multiple-escape-chars"
  (pass-if (equal? "HEeElElo"
                   (escape-special-chars "Hello" "el" #\E))))

;; **********************************************************************
;; tests for collapsing-multiple-chars
;; **********************************************************************
(with-test-prefix "collapse-repeated-chars"
  (define test-string
    "H e  l   l    o     t      h       e        r         e")

  (with-test-prefix "test-basic-collapse"
    (pass-if (equal? "H e l l o t h e r e"
                     (collapse-repeated-chars test-string))))

  (with-test-prefix "test-choose-other-char"
    (pass-if (equal? "H-e-l-l-o-t-h-e-r-e"
                     (collapse-repeated-chars (transform-string test-string #\space #\-)
                                              #\-))))

  (with-test-prefix "test-choose-maximum-repeats"
    (pass-if (equal? "H e  l  l  o  t  h  e  r  e"
                     (collapse-repeated-chars test-string #\space 2)))
    (pass-if (equal? "H e  l   l   o   t   h   e   r   e"
                     (collapse-repeated-chars test-string #\space 3)))))

;; **********************************************************************
;; Test of the object itself...
;; **********************************************************************
(with-test-prefix "text wrapping"
  (define test-string "
The last language environment specified with
`set-language-environment'.   This variable should be
set only with M-x customize, which is equivalent
to using the function `set-language-environment'.
")

  (with-test-prefix "runs-without-exception"
    (pass-if (->bool (fill-string test-string)))
    (pass-if (->bool (fill-string test-string #:line-width 20)))
    (pass-if (->bool (fill-string test-string #:initial-indent " * " #:tab-width 3))))

  (with-test-prefix "test-fill-equivalent-to-joined-lines"
    (pass-if (equal? (fill-string test-string)
                     (string-join (string->wrapped-lines test-string) "\n" 'infix))))

  (with-test-prefix "test-no-collapse-ws"
    (pass-if (equal? (fill-string test-string #:collapse-whitespace? #f)
                     "The last language environment specified with  `set-language-environment'.   This
variable should be  set only with M-x customize, which is equivalent to using
the function `set-language-environment'.")))

  (with-test-prefix "test-no-word-break"
    (pass-if (equal? "thisisalongword
blah
blah"
                     (fill-string "thisisalongword blah blah"
                                  #:line-width 8
                                  #:break-long-words? #f)))))

license: mit


code:
;;;; texinfo.test                 -*- scheme -*-
;;;;
;;;; Copyright (C) 2010  Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
;;;;
;;;; 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

;;; Commentary:
;;
;; Unit tests for (sxml texinfo). Adapted from xml.ssax.scm.
;;
;;; Code:

(define-module (test-suite texinfo)
  #:use-module (test-suite lib)
  #:use-module (texinfo))

(define exception:eof-while-reading-token
  '(parser-error . "^EOF while reading a token"))
(define exception:wrong-character
  '(parser-error . "^Wrong character"))
(define exception:eof-while-reading-char-data
  '(parser-error . "^EOF while reading char data"))
(define exception:no-settitle
  '(parser-error . "^No \\\\n@settitle  found"))
(define exception:unexpected-arg
  '(parser-error . "^@-command didn't expect more arguments"))
(define exception:bad-enumerate
  '(parser-error . "^Invalid"))

(define nl (string #\newline))

(define texinfo:read-verbatim-body
  (@@ (texinfo) read-verbatim-body))
(with-test-prefix "test-read-verbatim-body"
  (define (read-verbatim-body-from-string str)
    (define (consumer fragment foll-fragment seed)
      (cons* (if (equal? foll-fragment (string #\newline))
                 (string-append " NL" nl)
                 foll-fragment)
             fragment seed))
    (reverse
     (call-with-input-string
      str
      (lambda (port) (texinfo:read-verbatim-body port consumer '())))))

  (pass-if (equal? '()
                   (read-verbatim-body-from-string "@end verbatim\n")))

  ;; after @verbatim, the current position will always directly after
  ;; the newline.
  (pass-if-exception "@end verbatim needs a newline"
                     exception:eof-while-reading-token
                     (read-verbatim-body-from-string "@end verbatim"))

  (pass-if (equal? '("@@end verbatim" " NL\n")
                   (read-verbatim-body-from-string "@@end verbatim\n@end verbatim\n")))

  (pass-if (equal? '("@@@@faosfasf adsfas " " NL\n" " asf @foo{asdf}" " NL\n")
                   (read-verbatim-body-from-string
                    "@@@@faosfasf adsfas \n asf @foo{asdf}\n@end verbatim\n")))

  (pass-if (equal? '("@end verbatim " " NL\n")
                   (read-verbatim-body-from-string "@end verbatim \n@end verbatim\n"))))

(define texinfo:read-arguments
  (@@ (texinfo) read-arguments))
(with-test-prefix "test-read-arguments"
  (define (read-arguments-from-string str)
    (call-with-input-string
     str
     (lambda (port) (texinfo:read-arguments port #\}))))

  (define (test str expected-res)
    (pass-if (equal? expected-res
                     (read-arguments-from-string str))))

  (test "}" '())
  (test "foo}" '("foo"))
  (test "foo,bar}" '("foo" "bar"))
  (test "    foo     ,    bar  }" '("foo" "bar"))
  (test " foo ,   , bar }" '("foo" #f "bar"))
  (test "foo,,bar}" '("foo" #f "bar"))
  (pass-if-exception "need a } when reading arguments"
                     exception:eof-while-reading-token
                     (call-with-input-string
                      "foo,,bar"
                      (lambda (port) (texinfo:read-arguments port #\})))))

(define texinfo:complete-start-command
  (@@ (texinfo) complete-start-command))
(with-test-prefix "test-complete-start-command"
  (define (test command str)
    (call-with-input-string
     str
     (lambda (port)
       (call-with-values
           (lambda ()
             (texinfo:complete-start-command command port))
         list))))

  (pass-if (equal? '(section () EOL-TEXT)
                   (test 'section "foo bar baz bonzerts")))
  (pass-if (equal? '(deffnx ((category "Function") (name "foo") (arguments)) EOL-TEXT-ARGS)
                   (test 'deffnx "Function foo")))
  (pass-if-exception "@emph missing a start brace"
                     exception:wrong-character
                     (test 'emph "no brace here"))
  (pass-if (equal? '(emph () INLINE-TEXT)
                   (test 'emph "{foo bar baz bonzerts")))
  (pass-if (equal? '(ref ((node "foo bar") (section "baz") (info-file "bonzerts"))
                         INLINE-ARGS)
                   (test 'ref "{ foo bar ,,  baz, bonzerts}")))
  (pass-if (equal? '(node ((name "referenced node")) EOL-ARGS)
                   (test 'node " referenced node\n"))))

(define texinfo:read-char-data
  (@@ (texinfo) read-char-data))
(define make-texinfo-token cons)
(with-test-prefix "test-read-char-data"
  (let* ((code (make-texinfo-token 'START 'code))
         (ref (make-texinfo-token 'EMPTY 'ref))
         (title (make-texinfo-token 'LINE 'title))
         (node (make-texinfo-token 'EMPTY 'node))
         (eof-object (with-input-from-string "" read))
         (str-handler (lambda (fragment foll-fragment seed)
                        (if (string-null? foll-fragment)
                            (cons fragment seed)
                            (cons* foll-fragment fragment seed)))))
    (define (test str expect-eof? preserve-ws? expected-data expected-token)
      (call-with-values
          (lambda ()
            (call-with-input-string
             str
             (lambda (port)
               (texinfo:read-char-data
                port expect-eof? preserve-ws? str-handler '()))))
        (lambda (seed token)
          (let ((result (reverse seed)))
            (pass-if (equal? expected-data result))
            (pass-if (equal? expected-token token))))))

    ;; add some newline-related tests here
    (test "" #t #f '() eof-object)
    (test "foo bar baz" #t #f '("foo bar baz") eof-object)
    (pass-if-exception "eof reading char data"
                       exception:eof-while-reading-token
                       (test "" #f #f '() eof-object))
    (test "  " #t #f '("  ") eof-object)
    (test " @code{foo} " #f #f '(" ") code)
    (test " @code" #f #f '(" ") code)
    (test " {text here} asda" #f #f '(" ") (make-texinfo-token 'START '*braces*))
    (test " blah blah} asda" #f #f '(" blah blah") (make-texinfo-token 'END #f))))

(with-test-prefix "test-texinfo->stexinfo"
  (define (test str expected-res)
    (pass-if (equal? expected-res
                     (call-with-input-string str texi->stexi))))
  (define (try-with-title title str)
    (call-with-input-string
     (string-append "foo bar baz\n@settitle " title "\n" str)
     texi->stexi))
  (define (test-with-title title str expected-res)
    (test (string-append "foo bar baz\n@settitle " title "\n" str)
          expected-res))
  (define (test-body str expected-res)
    (pass-if (equal? expected-res
                     (cddr (try-with-title "zog" str)))))

  (define (list-intersperse src-l elem)
    (if (null? src-l) src-l
        (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
          (if (null? l) (reverse dest)
              (loop (cdr l) (cons (car l) (cons elem dest)))))))
  (define (join-lines . lines)
    (apply string-append (list-intersperse lines "\n")))

  (pass-if-exception "missing @settitle"
                     exception:no-settitle
                     (call-with-input-string "@dots{}\n" texi->stexi))

  (test "\\input texinfo\n@settitle my title\n@dots{}\n"
        '(texinfo (% (title "my title")) (para (dots))))
  (test-with-title "my title" "@dots{}\n"
                   '(texinfo (% (title "my title")) (para (dots))))
  (test-with-title "my title" "@dots{}"
                   '(texinfo (% (title "my title")) (para (dots))))

  (pass-if-exception "arg to @dots{}"
                     exception:unexpected-arg
                     (call-with-input-string
                      "foo bar baz\n@settitle my title\n@dots{arg}"
                      texi->stexi))

  (test-body "@code{arg}"
             '((para (code "arg"))))
  (test-body "@code{     }"
             '((para (code))))
  (test-body "@code{ @code{}    }"
             '((para (code (code)))))
  (test-body "@code{  abc    @code{}    }"
             '((para (code "abc " (code)))))
  (test-body "@code{ arg               }"
             '((para (code "arg"))))
  (test-body "@example\n foo asdf  asd  sadf asd  \n@end example\n"
             '((example " foo asdf  asd  sadf asd  ")))
  (test-body (join-lines
              "@quotation"
              "@example"
              " foo asdf  asd  sadf asd  "
              "@end example"
              "@end quotation"
              "")
             '((quotation (example " foo asdf  asd  sadf asd  "))))
  (test-body (join-lines
              "@quotation"
              "@example"
              " foo asdf  @var{asd}  sadf asd  "
              "@end example"
              "@end quotation"
              "")
             '((quotation (example " foo asdf  " (var "asd") "  sadf asd  "))))
  (test-body (join-lines
              "@quotation"
              "@example"
              " foo asdf  @var{asd}  sadf asd  "
              ""
              "not in new para, this is an example"
              "@end example"
              "@end quotation"
              "")
             '((quotation
                (example
                 " foo asdf  " (var "asd")
                 "  sadf asd  \n\nnot in new para, this is an example"))))
  (test-body (join-lines
              "@titlepage"
              "@quotation"
              " foo asdf  @var{asd}  sadf asd  "
              ""
              "should be in new para"
              "@end quotation"
              "@end titlepage"
              "")
             '((titlepage
                (quotation (para "foo asdf " (var "asd") " sadf asd")
                           (para "should be in new para")))))
  (test-body (join-lines
              ""
              "@titlepage"
              ""
              "@quotation"
              " foo asdf  @var{asd}  sadf asd  "
              ""
              "should be in new para"
              ""
              ""
              "@end quotation"
              "@end titlepage"
              ""
              "@bye"
              ""
              "@foo random crap at the end"
              "")
             '((titlepage
                (quotation (para "foo asdf " (var "asd") " sadf asd")
                           (para "should be in new para")))))
  (test-body (join-lines
              ""
              "random notes"
              "@quotation"
              " foo asdf  @var{asd}  sadf asd  "
              ""
              "should be in new para"
              ""
              ""
              "@end quotation"
              ""
              " hi mom"
              "")
             '((para "random notes")
               (quotation (para "foo asdf " (var "asd") " sadf asd")
                          (para "should be in new para"))
               (para "hi mom")))
  (test-body (join-lines
              "@enumerate"
              "@item one"
              "@item two"
              "@item three"
              "@end enumerate"
              )
             '((enumerate (item (para "one"))
                          (item (para "two"))
                          (item (para "three")))))
  (test-body (join-lines
              "@enumerate 44"
              "@item one"
              "@item two"
              "@item three"
              "@end enumerate"
              )
             '((enumerate (% (start "44"))
                          (item (para "one"))
                          (item (para "two"))
                          (item (para "three")))))
  (pass-if-exception "bad enumerate formatter"
                     exception:bad-enumerate
                     (try-with-title "foo" (join-lines
                                            "@enumerate string"
                                            "@item one"
                                            "@item two"
                                            "@item three"
                                            "@end enumerate"
                                            )))
  (pass-if-exception "bad itemize formatter"
                     exception:bad-enumerate
                     (try-with-title "foo" (join-lines
                                            "@itemize string"
                                            "@item one"
                                            "@item two"
                                            "@item three"
                                            "@end itemize"
                                            )))
  (test-body (join-lines
              "@itemize" ;; no formatter, should default to bullet
              "@item one"
              "@item two"
              "@item three"
              "@end itemize"
              )
             '((itemize (% (bullet (bullet)))
                        (item (para "one"))
                        (item (para "two"))
                        (item (para "three")))))
  (test-body (join-lines
              "@itemize @bullet"
              "@item one"
              "@item two"
              "@item three"
              "@end itemize"
              )
             '((itemize (% (bullet (bullet)))
                        (item (para "one"))
                        (item (para "two"))
                        (item (para "three")))))
  (test-body (join-lines
              "@itemize -"
              "@item one"
              "@item two"
              "@item three"
              "@end itemize"
              )
             '((itemize (% (bullet "-"))
                        (item (para "one"))
                        (item (para "two"))
                        (item (para "three")))))
  (test-body (join-lines
              "@table @code"
              "preliminary text -- should go in a pre-item para"
              "@item one"
              "item one text"
              "@item two"
              "item two text"
              ""
              "includes a paragraph"
              "@item three"
              "@end itemize"
              )
             '((table (% (formatter (code)))
                      (para "preliminary text -- should go in a pre-item para")
                      (entry (% (heading "one"))
                             (para "item one text"))
                      (entry (% (heading "two"))
                             (para "item two text")
                             (para "includes a paragraph"))
                      (entry (% (heading "three"))))))
  (test-body (join-lines
              "@chapter @code{foo} bar"
              "text that should be in a para"
              )
             '((chapter (code "foo") " bar")
               (para "text that should be in a para")))
  (test-body (join-lines
              "@deffnx Method foo bar @code{baz}"
              "text that should be in a para"
              )
             '((deffnx (% (category "Method")
                          (name "foo")
                          (arguments "bar " (code "baz"))))
               (para "text that should be in a para")))
  )


code:
;;;; threads.test --- Tests for Guile threading.    -*- scheme -*-
;;;;
;;;; Copyright 2003, 2006, 2007, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-threads)
  :use-module (ice-9 threads)
  :use-module (test-suite lib))

(define (asyncs-still-working?)
  (let ((a #f))
    (system-async-mark (lambda ()
			 (set! a #t)))
    ;; The point of the following (equal? ...) is to go through
    ;; primitive code (scm_equal_p) that includes a SCM_TICK call and
    ;; hence gives system asyncs a chance to run.  Of course the
    ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the
    ;; near future we may be using the VM instead of the traditional
    ;; compiler, and then we will still want asyncs-still-working? to
    ;; work.  (The VM should probably have SCM_TICK calls too, but
    ;; let's not rely on that here.)
    (equal? '(a b c) '(a b c))
    a))

(if (provided? 'threads)
    (begin

      (with-test-prefix "parallel"
	(pass-if "no forms"
	  (call-with-values
	      (lambda ()
		(parallel))
	    (lambda ()
	      #t)))

	(pass-if "1"
	  (call-with-values
	      (lambda ()
		(parallel 1))
	    (lambda (x)
	      (equal? x 1))))

	(pass-if "1 2"
	  (call-with-values
	      (lambda ()
		(parallel 1 2))
	    (lambda (x y)
	      (and (equal? x 1)
		   (equal? y 2)))))

	(pass-if "1 2 3"
	  (call-with-values
	      (lambda ()
		(parallel 1 2 3))
	    (lambda (x y z)
	      (and (equal? x 1)
		   (equal? y 2)
		   (equal? z 3))))))

      ;;
      ;; n-par-for-each
      ;;

      (with-test-prefix "n-par-for-each"

	(pass-if "0 in limit 10"
	  (n-par-for-each 10 noop '())
	  #t)

	(pass-if "6 in limit 10"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 10 (lambda (n)
				 (vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 1"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 1 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 2"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 2 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 3"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 3 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t)))))

      ;;
      ;; n-for-each-par-map
      ;;

      (with-test-prefix "n-for-each-par-map"

	(pass-if "asyncs are still working 2"
	  (asyncs-still-working?))

	(pass-if "0 in limit 10"
	  (n-for-each-par-map 10 noop noop '())
	  #t)

	(pass-if "6 in limit 10"
	  (let ((result '()))
	    (n-for-each-par-map 10
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 1"
	  (let ((result '()))
	    (n-for-each-par-map 1
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 2"
	  (let ((result '()))
	    (n-for-each-par-map 2
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 3"
	  (let ((result '()))
	    (n-for-each-par-map 3
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0)))))

      ;;
      ;; timed mutex locking
      ;;

      (with-test-prefix "lock-mutex"

	(pass-if "asyncs are still working 3"
	  (asyncs-still-working?))

	(pass-if "timed locking fails if timeout exceeded"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
	      (not (join-thread t)))))

	(pass-if "asyncs are still working 6"
	  (asyncs-still-working?))

        (pass-if "timed locking succeeds if mutex unlocked within timeout"
	  (let* ((m (make-mutex))
		 (c (make-condition-variable))
		 (cm (make-mutex)))
	    (lock-mutex cm)
	    (let ((t (begin-thread (begin (lock-mutex cm)
					  (signal-condition-variable c)
					  (unlock-mutex cm)
					  (lock-mutex m
						      (+ (current-time) 2))))))
	      (lock-mutex m)
	      (wait-condition-variable c cm)
	      (unlock-mutex cm)
	      (sleep 1)
	      (unlock-mutex m)
	      (join-thread t))))

	(pass-if "asyncs are still working 7"
	  (asyncs-still-working?))

	)

      ;;
      ;; timed mutex unlocking
      ;;

      (with-test-prefix "unlock-mutex"

	(pass-if "asyncs are still working 5"
	  (asyncs-still-working?))

        (pass-if "timed unlocking returns #f if timeout exceeded"
          (let ((m (make-mutex))
		(c (make-condition-variable)))
	    (lock-mutex m)
	    (not (unlock-mutex m c (current-time)))))

	(pass-if "asyncs are still working 4"
	  (asyncs-still-working?))

        (pass-if "timed unlocking returns #t if condition signaled"
	  (let ((m1 (make-mutex))
		(m2 (make-mutex))
		(c1 (make-condition-variable))
		(c2 (make-condition-variable)))
	    (lock-mutex m1)
	    (let ((t (begin-thread (begin (lock-mutex m1)
					  (signal-condition-variable c1)
					  (lock-mutex m2)
					  (unlock-mutex m1)
					  (unlock-mutex m2
							c2
							(+ (current-time)
							   2))))))
	      (wait-condition-variable c1 m1)
	      (unlock-mutex m1)
	      (lock-mutex m2)
	      (signal-condition-variable c2)
	      (unlock-mutex m2)
	      (join-thread t)))))

      ;;
      ;; timed joining
      ;;

      (with-test-prefix "join-thread"

	(pass-if "timed joining fails if timeout exceeded"
	  (let* ((m (make-mutex))
		 (c (make-condition-variable))
		 (t (begin-thread (begin (lock-mutex m)
					 (wait-condition-variable c m))))
		 (r (join-thread t (current-time))))
	    (cancel-thread t)
	    (not r)))

        (pass-if "join-thread returns timeoutval on timeout"
          (let* ((m (make-mutex))
		 (c (make-condition-variable))
		 (t (begin-thread (begin (lock-mutex m)
					 (wait-condition-variable c m))))
		 (r (join-thread t (current-time) 'foo)))
	    (cancel-thread t)
	    (eq? r 'foo)))

	(pass-if "timed joining succeeds if thread exits within timeout"
          (let ((t (begin-thread (begin (sleep 1) #t))))
	    (join-thread t (+ (current-time) 2))))

	(pass-if "asyncs are still working 1"
	  (asyncs-still-working?))

	;; scm_join_thread_timed has a SCM_TICK in the middle of it,
	;; to allow asyncs to run (including signal delivery).  We
	;; used to have a bug whereby if the joined thread terminated
	;; at the same time as the joining thread is in this SCM_TICK,
	;; scm_join_thread_timed would not notice and would hang
	;; forever.  So in this test we are setting up the following
	;; sequence of events.
        ;;   T=0  other thread is created and starts running
	;;   T=2  main thread sets up an async that will sleep for 10 seconds
        ;;   T=2  main thread calls join-thread, which will...
        ;;   T=2  ...call the async, which starts sleeping
        ;;   T=5  other thread finishes its work and terminates
        ;;   T=7  async completes, main thread continues inside join-thread.
	(pass-if "don't hang when joined thread terminates in SCM_TICK"
	  (let ((other-thread (make-thread sleep 5)))
	    (letrec ((delay-count 10)
		     (aproc (lambda ()
			      (set! delay-count (- delay-count 1))
			      (if (zero? delay-count)
				  (sleep 5)
				  (system-async-mark aproc)))))
	      (sleep 2)
	      (system-async-mark aproc)
	      (join-thread other-thread)))
	  #t))

      ;;
      ;; thread cancellation
      ;;

      (with-test-prefix "cancel-thread"

        (pass-if "cancel succeeds"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (begin (lock-mutex m) 'foo))))
	      (cancel-thread t)
	      (join-thread t)
	      #t)))

	(pass-if "handler result passed to join"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (lock-mutex m))))
	      (set-thread-cleanup! t (lambda () 'foo))
	      (cancel-thread t)
	      (eq? (join-thread t) 'foo))))

	(pass-if "can cancel self"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (begin
				     (set-thread-cleanup! (current-thread)
							  (lambda () 'foo))
				     (cancel-thread (current-thread))
				     (lock-mutex m)))))
	      (eq? (join-thread t) 'foo))))

	(pass-if "handler supplants final expr"
	  (let ((t (begin-thread (begin (set-thread-cleanup! (current-thread)
							     (lambda () 'bar))
					'foo))))
	    (eq? (join-thread t) 'bar)))

	(pass-if "remove handler by setting false"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (lock-mutex m) 'bar)))
	      (set-thread-cleanup! t (lambda () 'foo))
	      (set-thread-cleanup! t #f)
	      (unlock-mutex m)
	      (eq? (join-thread t) 'bar))))

	(pass-if "initial handler is false"
	  (not (thread-cleanup (current-thread)))))

      ;;
      ;; mutex ownership
      ;;

      (with-test-prefix "mutex-ownership"
	(pass-if "mutex ownership for locked mutex"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (eq? (mutex-owner m) (current-thread))))

	(pass-if "mutex ownership for unlocked mutex"
	  (let ((m (make-mutex)))
	    (not (mutex-owner m))))

	(pass-if "locking mutex on behalf of other thread"
	  (let* ((m (make-mutex))
		 (t (begin-thread 'foo)))
	    (lock-mutex m #f t)
	    (eq? (mutex-owner m) t)))

        (pass-if "locking mutex with no owner"
	  (let ((m (make-mutex)))
	    (lock-mutex m #f #f)
	    (not (mutex-owner m))))

        (pass-if "mutex with owner not retained (bug #27450)"
          (let ((g (make-guardian)))
            (g (let ((m (make-mutex))) (lock-mutex m) m))

            ;; Avoid false references to M on the stack.
            (let cleanup ((i 20))
              (and (> i 0)
                   (begin (cleanup (1- i)) i)))

            (gc) (gc)
            (let ((m (g)))
              (and (mutex? m)
                   (eq? (mutex-owner m) (current-thread)))))))

      ;;
      ;; mutex lock levels
      ;;

      (with-test-prefix "mutex-lock-levels"

        (pass-if "unlocked level is 0"
	  (let ((m (make-mutex)))
	    (and (not (mutex-locked? m)) (eqv? (mutex-level m) 0))))

        (pass-if "non-recursive lock level is 1"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (and (mutex-locked? m) (eqv? (mutex-level m) 1))))

	(pass-if "recursive lock level is >1"
	  (let ((m (make-mutex 'recursive)))
	    (lock-mutex m)
	    (lock-mutex m)
	    (and (mutex-locked? m) (eqv? (mutex-level m) 2)))))

      ;;
      ;; mutex behavior
      ;;

      (with-test-prefix "mutex-behavior"

        (pass-if "unchecked unlock"
          (let* ((m (make-mutex 'unchecked-unlock)))
	    (unlock-mutex m)))

	(pass-if "allow external unlock"
	  (let* ((m (make-mutex 'allow-external-unlock))
		 (t (begin-thread (lock-mutex m))))
	    (join-thread t)
	    (unlock-mutex m)))

	(pass-if "recursive mutexes"
	  (let* ((m (make-mutex 'recursive)))
	    (lock-mutex m)
	    (lock-mutex m)))

	(pass-if "locking abandoned mutex throws exception"
          (let* ((m (make-mutex))
		 (t (begin-thread (lock-mutex m)))
		 (success #f))
	    (join-thread t)
	    (catch 'abandoned-mutex-error
		   (lambda () (lock-mutex m))
		   (lambda key (set! success #t)))
	    success)))))


code:
;;;; time.test --- test suite for Guile's time functions     -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- June 1999, 2004
;;;;
;;;; 	Copyright (C) 1999, 2004, 2006, 2007, 2008 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-time)
  #:use-module (test-suite lib)
  #:use-module (ice-9 threads))

;;;
;;; gmtime
;;;

(with-test-prefix "gmtime"

  (for-each (lambda (t)
	      (pass-if (list "in another thread after error" t)
		(or (provided? 'threads) (throw 'unsupported))

		(alarm 5)
		(false-if-exception (gmtime t))
		(join-thread (begin-thread (catch #t
					     (lambda () (gmtime t))
					     (lambda args #f))))
		(alarm 0)
		#t))

	    ;; time values that might provoke an error from libc
	    ;; on 32-bit glibc all values (which fit) are fine
	    ;; on 64-bit glibc apparently 2^63 can overflow a 32-bit tm_year
	    (list (1- (ash 1 31)) (1- (ash 1 63))
		  -1 (- (ash 1 31)) (- (ash 1 63)))))

;;;
;;; internal-time-units-per-second
;;;

(with-test-prefix "internal-time-units-per-second"

  ;; Check that sleep 1 gives about internal-time-units-per-second worth of
  ;; elapsed time from times:clock.  This mainly ensures
  ;; internal-time-units-per-second correctly indicates CLK_TCK units.
  ;;
  (pass-if "versus times and sleep"
    (or (defined? 'times) (throw 'unsupported))

    (let ((old (times)))
      (sleep 1)
      (let* ((new (times))
	     (elapsed (- (tms:clock new) (tms:clock old))))
	(<= (* 0.5 internal-time-units-per-second)
	    elapsed
	    (* 2 internal-time-units-per-second))))))

;;;
;;; localtime
;;;

(with-test-prefix "localtime"

  ;; gmtoff is calculated with some explicit code, try to exercise that
  ;; here, looking at cases where the localtime and gmtime are within the same
  ;; day, or crossing midnight, or crossing new year

  (pass-if "gmtoff of EST+5 at GMT 10:00am on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 10)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "EST+5")))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing forward over day boundary
  (pass-if "gmtoff of EST+5 at GMT 3am on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 3)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "EST+5")))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing backward over day boundary
  (pass-if "gmtoff of AST-10 at GMT 10pm on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 22)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "AST-10")))
	(eqv? (* -10 3600) (tm:gmtoff tm)))))

  ;; crossing forward over year boundary
  (pass-if "gmtoff of EST+5 at GMT 3am on 1 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 3)
      (set-tm:mday tm 1)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "EST+5")))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing backward over day boundary
  (pass-if "gmtoff of AST-10 at GMT 10pm on 31 Dec 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 22)
      (set-tm:mday tm 31)
      (set-tm:mon  tm 11)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "AST-10")))
	(eqv? (* -10 3600) (tm:gmtoff tm))))))

;;;
;;; mktime
;;;

(with-test-prefix "mktime"

  ;; gmtoff is calculated with some explicit code, try to exercise that
  ;; here, looking at cases where the mktime and gmtime are within the same
  ;; day, or crossing midnight, or crossing new year

  (pass-if "gmtoff of EST+5 at 10:00am on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 10)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "EST+5"))))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing forward over day boundary
  (pass-if "gmtoff of EST+5 at 10:00pm on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 22)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "EST+5"))))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing backward over day boundary
  (pass-if "gmtoff of AST-10 at 3:00am on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 3)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "AST-10"))))
	(eqv? (* -10 3600) (tm:gmtoff tm)))))

  ;; crossing forward over year boundary
  (pass-if "gmtoff of EST+5 at 10:00pm on 31 Dec 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 22)
      (set-tm:mday tm 31)
      (set-tm:mon  tm 11)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "EST+5"))))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing backward over day boundary
  (pass-if "gmtoff of AST-10 at 3:00am on 1 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 3)
      (set-tm:mday tm 1)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "AST-10"))))
	(eqv? (* -10 3600) (tm:gmtoff tm))))))

;;;
;;; strftime
;;;

(with-test-prefix "strftime"

  (pass-if "strftime %Z doesn't return garbage"
    (let ((t (localtime (current-time))))
      (set-tm:zone t "ZOW")
      (set-tm:isdst t 0)
      (string=? (strftime "%Z" t)
                "ZOW")))

  (pass-if "strftime passes wide characters"
    (let ((t (localtime (current-time))))
      (string=? (substring (strftime "\u0100%Z" t) 0 1)
                "\u0100")))

  (with-test-prefix "C99 %z format"

    ;; %z here is quite possibly affected by the same tm:gmtoff vs current
    ;; zone as %Z above is, so in the following tests we make them the same.

    (pass-if "GMT"
      (putenv "TZ=GMT+0")
      (tzset)
      (let ((tm (localtime 86400)))
	(string=? "+0000" (strftime "%z" tm))))

    ;; prior to guile 1.6.9 and 1.8.1 this test failed, getting "+0500",
    ;; because we didn't adjust for tm:gmtoff being west of Greenwich versus
    ;; tm_gmtoff being east of Greenwich
    (pass-if "EST+5"
      (putenv "TZ=EST+5")
      (tzset)
      (let ((tm (localtime 86400)))
	(string=? "-0500" (strftime "%z" tm))))))

;;;
;;; strptime
;;;

(with-test-prefix "strptime"

  (pass-if "in another thread after error"
    (or (defined? 'strptime) (throw 'unsupported))
    (or (provided? 'threads) (throw 'unsupported))

    (alarm 5)
    (false-if-exception
     (strptime "%a" "nosuchday"))
    (join-thread (begin-thread (strptime "%d" "1")))
    (alarm 0)
    #t)

  (with-test-prefix "GNU %s format"

    ;; "%s" to parse a count of seconds since 1970 is a GNU extension
    (define have-strptime-%s
      (false-if-exception (strptime "%s" "0")))

    (pass-if "gmtoff on GMT"
      (or have-strptime-%s (throw 'unsupported))
      (putenv "TZ=GMT+0")
      (tzset)
      (let ((tm (car (strptime "%s" "86400"))))
	(eqv? 0 (tm:gmtoff tm))))

    ;; prior to guile 1.6.9 and 1.8.1 we didn't pass tm_gmtoff back from
    ;; strptime
    (pass-if "gmtoff on EST+5"
      (or have-strptime-%s (throw 'unsupported))
      (putenv "TZ=EST+5")
      (tzset)
      (let ((tm (car (strptime "%s" "86400"))))
	(eqv? (* 5 3600) (tm:gmtoff tm))))))


code:
;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
;;;; 	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-suite tree-il)
  #:use-module (test-suite lib)
  #:use-module (system base compile)
  #:use-module (system base pmatch)
  #:use-module (system base message)
  #:use-module (language tree-il)
  #:use-module (language glil)
  #:use-module (srfi srfi-13))

;; Of course, the GLIL that is emitted depends on the source info of the
;; input. Here we're not concerned about that, so we strip source
;; information from the incoming tree-il.

(define (strip-source x)
  (post-order! (lambda (x) (set! (tree-il-src x) #f))
               x))

(define-syntax assert-scheme->glil
  (syntax-rules ()
    ((_ in out)
     (let ((tree-il (strip-source
                     (compile 'in #:from 'scheme #:to 'tree-il))))
       (pass-if 'in
                (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
                        'out))))))

(define-syntax assert-tree-il->glil
  (syntax-rules ()
    ((_ in pat test ...)
     (let ((exp 'in))
       (pass-if 'in
         (let ((glil (unparse-glil
                      (compile (strip-source (parse-tree-il exp))
                               #:from 'tree-il #:to 'glil))))
           (pmatch glil
             (pat (guard test ...) #t)
             (else #f))))))))

(with-test-prefix "void"
  (assert-tree-il->glil
   (void)
   (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
  (assert-tree-il->glil
   (begin (void) (const 1))
   (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
  (assert-tree-il->glil
   (apply (primitive +) (void) (const 1))
   (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))

(with-test-prefix "application"
  (assert-tree-il->glil
   (apply (toplevel foo) (const 1))
   (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
  (assert-tree-il->glil
   (begin (apply (toplevel foo) (const 1)) (void))
   (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
            (call drop 1) (branch br ,l2)
            (label ,l3) (mv-bind 0 #f)
            (label ,l4)
            (void) (call return 1))
   (and (eq? l1 l3) (eq? l2 l4)))
  (assert-tree-il->glil
   (apply (toplevel foo) (apply (toplevel bar)))
   (program ()  (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
            (call tail-call 1))))

(with-test-prefix "conditional"
  (assert-tree-il->glil
   (if (toplevel foo) (const 1) (const 2))
   (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
            (const 1) (call return 1)
            (label ,l2) (const 2) (call return 1))
   (eq? l1 l2))

  (assert-tree-il->glil
   (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
   (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
            (label ,l3) (label ,l4) (const #f) (call return 1))
   (eq? l1 l3) (eq? l2 l4))

  (assert-tree-il->glil
   (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
   (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
            (const 1) (branch br ,l2)
                    (label ,l3) (const 2) (label ,l4)
                    (call null? 1) (call return 1))
   (eq? l1 l3) (eq? l2 l4)))

(with-test-prefix "primitive-ref"
  (assert-tree-il->glil
   (primitive +)
   (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))

  (assert-tree-il->glil
   (begin (primitive +) (const #f))
   (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (primitive +))
   (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
            (call return 1))))

(with-test-prefix "lexical refs"
  (assert-tree-il->glil
   (let (x) (y) ((const 1)) (lexical x y))
   (program () (std-prelude 0 1 #f) (label _)
            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
            (lexical #t #f ref 0) (call return 1)
            (unbind)))

  (assert-tree-il->glil
   (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
   (program () (std-prelude 0 1 #f) (label _)
            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
            (const #f) (call return 1)
            (unbind)))

  (assert-tree-il->glil
   (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
   (program () (std-prelude 0 1 #f) (label _)
            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
            (lexical #t #f ref 0) (call null? 1) (call return 1)
            (unbind))))

(with-test-prefix "lexical sets"
  (assert-tree-il->glil
   ;; unreferenced sets may be optimized away -- make sure they are ref'd
   (let (x) (y) ((const 1))
        (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
   (program () (std-prelude 0 1 #f) (label _)
            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
            (void) (call return 1)
            (unbind)))

  (assert-tree-il->glil
   (let (x) (y) ((const 1))
        (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
               (lexical x y)))
   (program () (std-prelude 0 1 #f) (label _)
            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
            (lexical #t #t ref 0) (call return 1)
            (unbind)))

  (assert-tree-il->glil
   (let (x) (y) ((const 1))
     (apply (primitive null?)
            (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
   (program () (std-prelude 0 1 #f) (label _)
            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
            (call null? 1) (call return 1)
            (unbind))))

(with-test-prefix "module refs"
  (assert-tree-il->glil
   (@ (foo) bar)
   (program () (std-prelude 0 0 #f) (label _)
            (module public ref (foo) bar)
            (call return 1)))

  (assert-tree-il->glil
   (begin (@ (foo) bar) (const #f))
   (program () (std-prelude 0 0 #f) (label _)
            (module public ref (foo) bar) (call drop 1)
            (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (@ (foo) bar))
   (program () (std-prelude 0 0 #f) (label _)
            (module public ref (foo) bar)
            (call null? 1) (call return 1)))

  (assert-tree-il->glil
   (@@ (foo) bar)
   (program () (std-prelude 0 0 #f) (label _)
            (module private ref (foo) bar)
            (call return 1)))

  (assert-tree-il->glil
   (begin (@@ (foo) bar) (const #f))
   (program () (std-prelude 0 0 #f) (label _)
            (module private ref (foo) bar) (call drop 1)
            (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (@@ (foo) bar))
   (program () (std-prelude 0 0 #f) (label _)
            (module private ref (foo) bar)
            (call null? 1) (call return 1))))

(with-test-prefix "module sets"
  (assert-tree-il->glil
   (set! (@ (foo) bar) (const 2))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (module public set (foo) bar)
            (void) (call return 1)))

  (assert-tree-il->glil
   (begin (set! (@ (foo) bar) (const 2)) (const #f))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (module public set (foo) bar)
            (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (module public set (foo) bar)
            (void) (call null? 1) (call return 1)))

  (assert-tree-il->glil
   (set! (@@ (foo) bar) (const 2))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (module private set (foo) bar)
            (void) (call return 1)))

  (assert-tree-il->glil
   (begin (set! (@@ (foo) bar) (const 2)) (const #f))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (module private set (foo) bar)
            (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (module private set (foo) bar)
            (void) (call null? 1) (call return 1))))

(with-test-prefix "toplevel refs"
  (assert-tree-il->glil
   (toplevel bar)
   (program () (std-prelude 0 0 #f) (label _)
            (toplevel ref bar)
            (call return 1)))

  (assert-tree-il->glil
   (begin (toplevel bar) (const #f))
   (program () (std-prelude 0 0 #f) (label _)
            (toplevel ref bar) (call drop 1)
            (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (toplevel bar))
   (program () (std-prelude 0 0 #f) (label _)
            (toplevel ref bar)
            (call null? 1) (call return 1))))

(with-test-prefix "toplevel sets"
  (assert-tree-il->glil
   (set! (toplevel bar) (const 2))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (toplevel set bar)
            (void) (call return 1)))

  (assert-tree-il->glil
   (begin (set! (toplevel bar) (const 2)) (const #f))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (toplevel set bar)
            (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (set! (toplevel bar) (const 2)))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (toplevel set bar)
            (void) (call null? 1) (call return 1))))

(with-test-prefix "toplevel defines"
  (assert-tree-il->glil
   (define bar (const 2))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (toplevel define bar)
            (void) (call return 1)))

  (assert-tree-il->glil
   (begin (define bar (const 2)) (const #f))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (toplevel define bar)
            (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (define bar (const 2)))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (toplevel define bar)
            (void) (call null? 1) (call return 1))))

(with-test-prefix "constants"
  (assert-tree-il->glil
   (const 2)
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (call return 1)))

  (assert-tree-il->glil
   (begin (const 2) (const #f))
   (program () (std-prelude 0 0 #f) (label _)
            (const #f) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (const 2))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (call null? 1) (call return 1))))

(with-test-prefix "letrec"
  ;; simple bindings -> let
  (assert-tree-il->glil
   (letrec (x y) (x1 y1) ((const 10) (const 20))
           (apply (toplevel foo) (lexical x x1) (lexical y y1)))
   (program () (std-prelude 0 2 #f) (label _)
            (const 10) (const 20)
            (bind (x #f 0) (y #f 1))
            (lexical #t #f set 1) (lexical #t #f set 0)
            (toplevel ref foo)
            (lexical #t #f ref 0) (lexical #t #f ref 1)
            (call tail-call 2)
            (unbind)))

  ;; complex bindings -> box and set! within let
  (assert-tree-il->glil
   (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
           (apply (primitive +) (lexical x x1) (lexical y y1)))
   (program () (std-prelude 0 4 #f) (label _)
            (void) (void) ;; what are these?
            (bind (x #t 0) (y #t 1))
            (lexical #t #t box 1) (lexical #t #t box 0)
            (call new-frame 0) (toplevel ref foo) (call call 0)
            (call new-frame 0) (toplevel ref bar) (call call 0)
            (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
            (lexical #t #f ref 2) (lexical #t #t set 0)
            (lexical #t #f ref 3) (lexical #t #t set 1) (unbind)
            (lexical #t #t ref 0) (lexical #t #t ref 1)
            (call add 2) (call return 1) (unbind)))

  ;; complex bindings in letrec* -> box and set! in order
  (assert-tree-il->glil
   (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
            (apply (primitive +) (lexical x x1) (lexical y y1)))
   (program () (std-prelude 0 2 #f) (label _)
            (void) (void) ;; what are these?
            (bind (x #t 0) (y #t 1))
            (lexical #t #t box 1) (lexical #t #t box 0)
            (call new-frame 0) (toplevel ref foo) (call call 0)
            (lexical #t #t set 0)
            (call new-frame 0) (toplevel ref bar) (call call 0)
            (lexical #t #t set 1)
            (lexical #t #t ref 0)
            (lexical #t #t ref 1)
            (call add 2) (call return 1) (unbind))))

(with-test-prefix "lambda"
  (assert-tree-il->glil
   (lambda ()
     (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
   (program ()  (std-prelude 0 0 #f) (label _)
            (program () (std-prelude 1 1 #f)
                     (bind (x #f 0)) (label _)
                     (const 2) (call return 1) (unbind))
            (call return 1)))

  (assert-tree-il->glil
   (lambda ()
     (lambda-case (((x y) #f #f #f () (x1 y1))
                   (const 2))
                  #f))
   (program () (std-prelude 0 0 #f) (label _)
            (program () (std-prelude 2 2 #f)
                     (bind (x #f 0) (y #f 1)) (label _)
                     (const 2) (call return 1)
                     (unbind))
            (call return 1)))

  (assert-tree-il->glil
   (lambda ()
     (lambda-case ((() #f x #f () (y)) (const 2))
                  #f))
   (program () (std-prelude 0 0 #f) (label _)
            (program () (opt-prelude 0 0 0 1 #f)
                     (bind (x #f 0)) (label _)
                     (const 2) (call return 1)
                     (unbind))
            (call return 1)))

  (assert-tree-il->glil
   (lambda ()
     (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
                  #f))
   (program () (std-prelude 0 0 #f) (label _)
            (program () (opt-prelude 1 0 1 2 #f)
                     (bind (x #f 0) (x1 #f 1)) (label _)
                     (const 2) (call return 1)
                     (unbind))
            (call return 1)))

  (assert-tree-il->glil
   (lambda ()
     (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
                  #f))
   (program () (std-prelude 0 0 #f) (label _)
            (program () (opt-prelude 1 0 1 2 #f)
                     (bind (x #f 0) (x1 #f 1)) (label _)
                     (lexical #t #f ref 0) (call return 1)
                     (unbind))
            (call return 1)))

  (assert-tree-il->glil
   (lambda ()
     (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
                  #f))
   (program () (std-prelude 0 0 #f) (label _)
            (program () (opt-prelude 1 0 1 2 #f)
                     (bind (x #f 0) (x1 #f 1)) (label _)
                     (lexical #t #f ref 1) (call return 1)
                     (unbind))
            (call return 1)))

  (assert-tree-il->glil
   (lambda ()
     (lambda-case (((x) #f #f #f () (x1))
                   (lambda ()
                     (lambda-case (((y) #f #f #f () (y1))
                                   (lexical x x1))
                                  #f)))
                  #f))
   (program () (std-prelude 0 0 #f) (label _)
            (program () (std-prelude 1 1 #f)
                     (bind (x #f 0)) (label _)
                     (program () (std-prelude 1 1 #f)
                              (bind (y #f 0)) (label _)
                              (lexical #f #f ref 0) (call return 1)
                              (unbind))
                     (lexical #t #f ref 0)
                     (call make-closure 1)
                     (call return 1)
                     (unbind))
            (call return 1))))

(with-test-prefix "sequence"
  (assert-tree-il->glil
   (begin (begin (const 2) (const #f)) (const #t))
   (program () (std-prelude 0 0 #f) (label _)
            (const #t) (call return 1)))

  (assert-tree-il->glil
   (apply (primitive null?) (begin (const #f) (const 2)))
   (program () (std-prelude 0 0 #f) (label _)
            (const 2) (call null? 1) (call return 1))))

;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case
(with-test-prefix "the or hack"
  (assert-tree-il->glil
   (let (x) (y) ((const 1))
        (if (lexical x y)
            (lexical x y)
            (let (a) (b) ((const 2))
                 (lexical a b))))
   (program () (std-prelude 0 1 #f) (label _)
            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
            (lexical #t #f ref 0) (branch br-if-not ,l1)
            (lexical #t #f ref 0) (call return 1)
            (label ,l2)
            (const 2) (bind (a #f 0)) (lexical #t #f set 0)
            (lexical #t #f ref 0) (call return 1)
            (unbind)
            (unbind))
   (eq? l1 l2))

  ;; second bound var is unreferenced
  (assert-tree-il->glil
   (let (x) (y) ((const 1))
        (if (lexical x y)
            (lexical x y)
            (let (a) (b) ((const 2))
                 (lexical x y))))
   (program () (std-prelude 0 1 #f) (label _)
            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
            (lexical #t #f ref 0) (branch br-if-not ,l1)
            (lexical #t #f ref 0) (call return 1)
            (label ,l2)
            (lexical #t #f ref 0) (call return 1)
            (unbind))
   (eq? l1 l2)))

(with-test-prefix "apply"
  (assert-tree-il->glil
   (apply (primitive @apply) (toplevel foo) (toplevel bar))
   (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
  (assert-tree-il->glil
   (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
   (program () (std-prelude 0 0 #f) (label _)
            (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
            (label ,l4)
            (void) (call return 1))
   (and (eq? l1 l3) (eq? l2 l4)))
  (assert-tree-il->glil
   (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
   (program () (std-prelude 0 0 #f) (label _)
            (toplevel ref foo)
            (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
            (call tail-call 1))))

(with-test-prefix "call/cc"
  (assert-tree-il->glil
   (apply (primitive @call-with-current-continuation) (toplevel foo))
   (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
  (assert-tree-il->glil
   (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
   (program () (std-prelude 0 0 #f) (label _)
            (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
            (label ,l4)
            (void) (call return 1))
   (and (eq? l1 l3) (eq? l2 l4)))
  (assert-tree-il->glil
   (apply (toplevel foo)
          (apply (toplevel @call-with-current-continuation) (toplevel bar)))
   (program () (std-prelude 0 0 #f) (label _)
            (toplevel ref foo)
            (toplevel ref bar) (call call/cc 1)
            (call tail-call 1))))

(with-test-prefix "tree-il-fold"

  (pass-if "empty tree"
    (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
      (and (eq? mark
                (tree-il-fold (lambda (x y) (set! leaf? #t) y)
                              (lambda (x y) (set! down? #t) y)
                              (lambda (x y) (set! up? #t) y)
                              mark
                              '()))
           (not leaf?)
           (not up?)
           (not down?))))

  (pass-if "lambda and application"
    (let* ((leaves '()) (ups '()) (downs '())
           (result (tree-il-fold (lambda (x y)
                                   (set! leaves (cons x leaves))
                                   (1+ y))
                                 (lambda (x y)
                                   (set! downs (cons x downs))
                                   (1+ y))
                                 (lambda (x y)
                                   (set! ups (cons x ups))
                                   (1+ y))
                                 0
                                 (parse-tree-il
                                  '(lambda ()
                                     (lambda-case
                                      (((x y) #f #f #f () (x1 y1))
                                       (apply (toplevel +)
                                              (lexical x x1)
                                              (lexical y y1)))
                                      #f))))))
      (and (equal? (map strip-source leaves)
                   (list (make-lexical-ref #f 'y 'y1)
                         (make-lexical-ref #f 'x 'x1)
                         (make-toplevel-ref #f '+)))
           (= (length downs) 3)
           (equal? (reverse (map strip-source ups))
                   (map strip-source downs))))))

;;;
;;; Warnings.
;;;

;; Make sure we get English messages.
(setlocale LC_ALL "C")

(define (call-with-warnings thunk)
  (let ((port (open-output-string)))
    (with-fluid* *current-warning-port* port
      thunk)
    (let ((warnings (get-output-string port)))
      (string-tokenize warnings
                       (char-set-complement (char-set #\newline))))))

(define %opts-w-unused
  '(#:warnings (unused-variable)))

(define %opts-w-unused-toplevel
  '(#:warnings (unused-toplevel)))

(define %opts-w-unbound
  '(#:warnings (unbound-variable)))

(define %opts-w-arity
  '(#:warnings (arity-mismatch)))

(with-test-prefix "warnings"

   (pass-if "unknown warning type"
     (let ((w (call-with-warnings
                (lambda ()
                  (compile #t #:opts '(#:warnings (does-not-exist)))))))
       (and (= (length w) 1)
            (number? (string-contains (car w) "unknown warning")))))

   (with-test-prefix "unused-variable"

     (pass-if "quiet"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(lambda (x y) (+ x y))
                           #:opts %opts-w-unused)))))

     (pass-if "let/unused"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(lambda (x)
                                (let ((y (+ x 2)))
                                  x))
                             #:opts %opts-w-unused)))))
         (and (= (length w) 1)
              (number? (string-contains (car w) "unused variable `y'")))))

     (pass-if "shadowed variable"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(lambda (x)
                                (let ((y x))
                                  (let ((y (+ x 2)))
                                    (+ x y))))
                             #:opts %opts-w-unused)))))
         (and (= (length w) 1)
              (number? (string-contains (car w) "unused variable `y'")))))

     (pass-if "letrec"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(lambda ()
                              (letrec ((x (lambda () (y)))
                                       (y (lambda () (x))))
                                y))
                           #:opts %opts-w-unused)))))

     (pass-if "unused argument"
       ;; Unused arguments should not be reported.
       (null? (call-with-warnings
                (lambda ()
                  (compile '(lambda (x y z) #t)
                           #:opts %opts-w-unused))))))

   (with-test-prefix "unused-toplevel"

     (pass-if "used after definition"
       (null? (call-with-warnings
                (lambda ()
                  (let ((in (open-input-string
                             "(define foo 2) foo")))
                    (read-and-compile in
                                      #:to 'assembly
                                      #:opts %opts-w-unused-toplevel))))))

     (pass-if "used before definition"
       (null? (call-with-warnings
                (lambda ()
                  (let ((in (open-input-string
                             "(define (bar) foo) (define foo 2) (bar)")))
                    (read-and-compile in
                                      #:to 'assembly
                                      #:opts %opts-w-unused-toplevel))))))

     (pass-if "unused but public"
       (let ((in (open-input-string
                  "(define-module (test-suite tree-il x) #:export (bar))
                   (define (bar) #t)")))
         (null? (call-with-warnings
                  (lambda ()
                    (read-and-compile in
                                      #:to 'assembly
                                      #:opts %opts-w-unused-toplevel))))))

     (pass-if "unused but public (more)"
       (let ((in (open-input-string
                  "(define-module (test-suite tree-il x) #:export (bar))
                   (define (bar) (baz))
                   (define (baz) (foo))
                   (define (foo) #t)")))
         (null? (call-with-warnings
                  (lambda ()
                    (read-and-compile in
                                      #:to 'assembly
                                      #:opts %opts-w-unused-toplevel))))))

     (pass-if "unused but define-public"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(define-public foo 2)
                           #:to 'assembly
                           #:opts %opts-w-unused-toplevel)))))

     (pass-if "used by macro"
       ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
       (throw 'unresolved)

       (null? (call-with-warnings
                (lambda ()
                  (let ((in (open-input-string
                             "(define (bar) 'foo)
                              (define-syntax baz
                                (syntax-rules () ((_) (bar))))")))
                    (read-and-compile in
                                      #:to 'assembly
                                      #:opts %opts-w-unused-toplevel))))))

     (pass-if "unused"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(define foo 2)
                             #:to 'assembly
                             #:opts %opts-w-unused-toplevel)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        (format #f "top-level variable `~A'"
                                                'foo))))))

     (pass-if "unused recursive"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(define (foo) (foo))
                             #:to 'assembly
                             #:opts %opts-w-unused-toplevel)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        (format #f "top-level variable `~A'"
                                                'foo))))))

     (pass-if "unused mutually recursive"
       (let* ((in (open-input-string
                   "(define (foo) (bar)) (define (bar) (foo))"))
              (w  (call-with-warnings
                    (lambda ()
                      (read-and-compile in
                                        #:to 'assembly
                                        #:opts %opts-w-unused-toplevel)))))
         (and (= (length w) 2)
              (number? (string-contains (car w)
                                        (format #f "top-level variable `~A'"
                                                'foo)))
              (number? (string-contains (cadr w)
                                        (format #f "top-level variable `~A'"
                                                'bar)))))))

   (with-test-prefix "unbound variable"

     (pass-if "quiet"
       (null? (call-with-warnings
                (lambda ()
                  (compile '+ #:opts %opts-w-unbound)))))

     (pass-if "ref"
       (let* ((v (gensym))
              (w (call-with-warnings
                   (lambda ()
                     (compile v
                              #:to 'assembly
                              #:opts %opts-w-unbound)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        (format #f "unbound variable `~A'"
                                                v))))))

     (pass-if "set!"
       (let* ((v (gensym))
              (w (call-with-warnings
                   (lambda ()
                     (compile `(set! ,v 7)
                              #:to 'assembly
                              #:opts %opts-w-unbound)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        (format #f "unbound variable `~A'"
                                                v))))))

     (pass-if "module-local top-level is visible"
       (let ((m (make-module))
             (v (gensym)))
         (beautify-user-module! m)
         (compile `(define ,v 123)
                  #:env m #:opts %opts-w-unbound)
         (null? (call-with-warnings
                  (lambda ()
                    (compile v
                             #:env m
                             #:to 'assembly
                             #:opts %opts-w-unbound))))))

     (pass-if "module-local top-level is visible after"
       (let ((m (make-module))
             (v (gensym)))
         (beautify-user-module! m)
         (null? (call-with-warnings
                  (lambda ()
                    (let ((in (open-input-string
                               "(define (f)
                                  (set! chbouib 3))
                                (define chbouib 5)")))
                      (read-and-compile in
                                        #:env m
                                        #:opts %opts-w-unbound)))))))

     (pass-if "optional arguments are visible"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(lambda* (x #:optional y z) (list x y z))
                           #:opts %opts-w-unbound
                           #:to 'assembly)))))

     (pass-if "keyword arguments are visible"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(lambda* (x #:key y z) (list x y z))
                           #:opts %opts-w-unbound
                           #:to 'assembly)))))

     (pass-if "GOOPS definitions are visible"
       (let ((m (make-module))
             (v (gensym)))
         (beautify-user-module! m)
         (module-use! m (resolve-interface '(oop goops)))
         (null? (call-with-warnings
                  (lambda ()
                    (let ((in (open-input-string
                               "(define-class <foo> ()
                                  (bar #:getter foo-bar))
                                (define z (foo-bar (make <foo>)))")))
                      (read-and-compile in
                                        #:env m
                                        #:opts %opts-w-unbound))))))))

   (with-test-prefix "arity mismatch"

     (pass-if "quiet"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(cons 'a 'b) #:opts %opts-w-arity)))))

     (pass-if "direct application"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))
     (pass-if "local"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(let ((f (lambda (x y) (+ x y))))
                                (f 2))
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "global"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(cons 1 2 3 4)
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "alias to global"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(let ((f cons)) (f 1 2 3 4))
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "alias to lexical to global"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(let ((f number?))
                                (let ((g f))
                                  (f 1 2 3 4)))
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "alias to lexical"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(let ((f (lambda (x y z) (+ x y z))))
                                (let ((g f))
                                  (g 1)))
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "letrec"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
                                       (even? (lambda (x)
                                                (or (= 0 x)
                                                    (odd?)))))
                                (odd? 1))
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "case-lambda"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(let ((f (case-lambda
                                       ((x)     1)
                                       ((x y)   2)
                                       ((x y z) 3))))
                              (list (f 1)
                                    (f 1 2)
                                    (f 1 2 3)))
                           #:opts %opts-w-arity
                           #:to 'assembly)))))

     (pass-if "case-lambda with wrong number of arguments"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(let ((f (case-lambda
                                         ((x)     1)
                                         ((x y)   2))))
                                (f 1 2 3))
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "case-lambda*"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(let ((f (case-lambda*
                                       ((x #:optional y) 1)
                                       ((x #:key y)      2)
                                       ((x y #:key z)    3))))
                              (list (f 1)
                                    (f 1 2)
                                    (f #:y 2)
                                    (f 1 2 #:z 3)))
                           #:opts %opts-w-arity
                           #:to 'assembly)))))

     (pass-if "case-lambda* with wrong arguments"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(let ((f (case-lambda*
                                         ((x #:optional y) 1)
                                         ((x #:key y)      2)
                                         ((x y #:key z)    3))))
                                (list (f)
                                      (f 1 #:z 3)))
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 2)
              (null? (filter (lambda (w)
                               (not
                                (number?
                                 (string-contains
                                  w "wrong number of arguments to"))))
                             w)))))

     (pass-if "local toplevel-defines"
       (let ((w (call-with-warnings
                  (lambda ()
                    (let ((in (open-input-string "
                                (define (g x) (f x))
                                (define (f) 1)")))
                      (read-and-compile in
                                        #:opts %opts-w-arity
                                        #:to 'assembly))))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "global toplevel alias"
       (let ((w (call-with-warnings
                  (lambda ()
                    (let ((in (open-input-string "
                                (define f cons)
                                (define (g) (f))")))
                      (read-and-compile in
                                        #:opts %opts-w-arity
                                        #:to 'assembly))))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "local toplevel overrides global"
       (null? (call-with-warnings
                (lambda ()
                  (let ((in (open-input-string "
                              (define (cons) 0)
                              (define (foo x) (cons))")))
                    (read-and-compile in
                                      #:opts %opts-w-arity
                                      #:to 'assembly))))))

     (pass-if "keyword not passed and quiet"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(let ((f (lambda* (x #:key y) y)))
                              (f 2))
                           #:opts %opts-w-arity
                           #:to 'assembly)))))

     (pass-if "keyword passed and quiet"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(let ((f (lambda* (x #:key y) y)))
                              (f 2 #:y 3))
                           #:opts %opts-w-arity
                           #:to 'assembly)))))

     (pass-if "keyword passed to global and quiet"
       (null? (call-with-warnings
                (lambda ()
                  (let ((in (open-input-string "
                              (use-modules (system base compile))
                              (compile '(+ 2 3) #:env (current-module))")))
                    (read-and-compile in
                                      #:opts %opts-w-arity
                                      #:to 'assembly))))))

     (pass-if "extra keyword"
       (let ((w (call-with-warnings
                  (lambda ()
                    (compile '(let ((f (lambda* (x #:key y) y)))
                                (f 2 #:Z 3))
                             #:opts %opts-w-arity
                             #:to 'assembly)))))
         (and (= (length w) 1)
              (number? (string-contains (car w)
                                        "wrong number of arguments to")))))

     (pass-if "extra keywords allowed"
       (null? (call-with-warnings
                (lambda ()
                  (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
                                       y)))
                              (f 2 #:Z 3))
                           #:opts %opts-w-arity
                           #:to 'assembly)))))))


code:
;;;; vectors.test --- test suite for Guile's vector functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2003, 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

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

;; FIXME:  As soon as guile supports immutable vectors, this has to be
;; replaced with the appropriate error type and message.
(define exception:immutable-vector
  (cons 'some-error-type "^trying to modify an immutable vector"))

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

  (expect-fail-exception "vector constant"
    exception:immutable-vector
    (vector-set! '#(1 2 3) 0 4)))

(with-test-prefix "vector->list"

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

  (pass-if "string vector 1"
    (equal? '("abc" "def" "ghi") (vector->list #("abc" "def" "ghi"))))

  (pass-if "string-vector 2"
    (equal? '("abc\u0100" "def\u0101" "ghi\u0102")
            (vector->list #("abc\u0100" "def\u0101" "ghi\u0102"))))

  (pass-if "shared array"
    (let ((b (make-shared-array #(1) (lambda (x) '(0)) 2)))
      (equal? b (list->vector (vector->list b))))))

(with-test-prefix "make-vector"

  (pass-if "null"
    (equal? #() (make-vector 0)))

  (pass-if "fill with num"
    (equal? #(1 1 1) (make-vector 3 1)))

  (pass-if "fill with string"
    (equal? #("abc" "abc" "abc") (make-vector 3 "abc")))

  (pass-if "fill with string 2"
    (equal? #("ab\u0100" "ab\u0100" "ab\u0100")
            (make-vector 3 "ab\u0100"))))

(with-test-prefix "vector-move-left!"

  (pass-if-exception "before start" exception:out-of-range
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
      (vector-move-left! a 3 5 b -1)))

  (pass-if "beginning"
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
      (vector-move-left! a 3 5 b 0)
      (equal? b #(4 5 30 40 50 60 70 80 90))))

  (pass-if "middle"
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
      (vector-move-left! a 3 5 b 2)
      (equal? b #(10 20 4 5 50 60 70 80 90))))

  (pass-if "overlap -"
    (let ((a (vector 1 2 3 4 5 6 7 8 9)))
      (vector-move-left! a 3 5 a 2)
      (equal? a #(1 2 4 5 5 6 7 8 9))))

  (pass-if "overlap +"
    (let ((a (vector 1 2 3 4 5 6 7 8 9)))
      (vector-move-left! a 3 5 a 4)
      (equal? a #(1 2 3 4 4 4 7 8 9))))

  (pass-if "end"
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
       (vector-move-left! a 3 5 b 7)
       (equal? b #(10 20 30 40 50 60 70 4 5))))

  (pass-if-exception "past end" exception:out-of-range
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
      (vector-move-left! a 3 5 b 8))))

(with-test-prefix "vector-move-right!"

  (pass-if-exception "before start" exception:out-of-range
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
      (vector-move-right! a 3 5 b -1)))

  (pass-if "beginning"
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
      (vector-move-right! a 3 5 b 0)
      (equal? b #(4 5 30 40 50 60 70 80 90))))

  (pass-if "middle"
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
      (vector-move-right! a 3 5 b 2)
      (equal? b #(10 20 4 5 50 60 70 80 90))))

  (pass-if "overlap -"
    (let ((a (vector 1 2 3 4 5 6 7 8 9)))
      (vector-move-right! a 3 5 a 2)
      (equal? a #(1 2 5 5 5 6 7 8 9))))

  (pass-if "overlap +"
    (let ((a (vector 1 2 3 4 5 6 7 8 9)))
      (vector-move-right! a 3 5 a 4)
      (equal? a #(1 2 3 4 4 5 7 8 9))))

  (pass-if "end"
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
       (vector-move-right! a 3 5 b 7)
       (equal? b #(10 20 30 40 50 60 70 4 5))))

  (pass-if-exception "past end" exception:out-of-range
    (let ((a (vector 1 2 3 4 5 6 7 8 9))
          (b (vector 10 20 30 40 50 60 70 80 90)))
      (vector-move-right! a 3 5 b 8))))


code:
;;;; version.test --- test suite for Guile's version functions  -*- scheme -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
;;;; 	Copyright (C) 2000, 2001, 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

(define-module (test-version)
  #:use-module (test-suite lib))

(pass-if "version reporting works"
	 (and (string? (major-version))
	      (string? (minor-version))
	      (string? (micro-version))
	      (string-contains (version)
                               (string-append (major-version) "."
                                              (minor-version) "."
                                              (micro-version)))))