code:
(define-syntax compile-match
  (syntax-rules ()
    [(compile-match pat action0 action ...)
     (lambda (x)
       (sxml-match x [pat action0 action ...]))]))

(run-test "basic match of a top-level pattern var"
          (sxml-match '(e 3 4 5)
                      [,y (list "matched" y)])
          '("matched" (e 3 4 5)))
(run-test "match of simple element contents with pattern vars"
          ((compile-match (e ,a ,b ,c) (list a b c)) '(e 3 4 5))
          '(3 4 5))
(run-test "match a literal pattern within a element pattern"
          ((compile-match (e ,a "abc" ,c) (list a c)) '(e 3 "abc" 5))
          '(3 5))
(run-test "match an empty element"
          ((compile-match (e) "match") '(e))
          "match")
(run-test "match a nested element"
          ((compile-match (e ,a (f ,b ,c) ,d) (list a b c d)) '(e 3 (f 4 5) 6))
          '(3 4 5 6))
(run-test "match a dot-rest pattern within a nested element"
          ((compile-match (e ,a (f . ,y) ,d) (list a y d)) '(e 3 (f 4 5) 6))
          '(3 (4 5) 6))
(run-test "match a basic list pattern"
          ((compile-match (list ,a ,b ,c ,d ,e) (list a b c d e)) '("i" "j" "k" "l" "m"))
          '("i" "j" "k" "l" "m"))
(run-test "match a list pattern with a dot-rest pattern"
          ((compile-match (list ,a ,b ,c . ,y) (list a b c y)) '("i" "j" "k" "l" "m"))
          '("i" "j" "k" ("l" "m")))
(run-test "basic test of a multi-clause sxml-match"
          (sxml-match '(a 1 2 3)
                      ((a ,n) n)
                      ((a ,m ,n) (+ m n))
                      ((a ,m ,n ,o) (list "matched" (list m n o))))
          '("matched" (1 2 3)))
(run-test "basic test of a sxml-match-let"
          (sxml-match-let ([(a ,i ,j) '(a 1 2)])
                          (+ i j))
          3)
(run-test "basic test of a sxml-match-let*"
          (sxml-match-let* ([(a ,k) '(a (b 1 2))]
                            [(b ,i ,j) k])
                           (list i j))
          '(1 2))
(run-test "match of top-level literal string pattern"
          ((compile-match "abc" "match") "abc")
          "match")
(run-test "match of top-level literal number pattern"
          ((compile-match 77 "match") 77)
          "match")
(run-test "test of multi-expression guard in pattern"
          (sxml-match '(a 1 2 3)
                      ((a ,n) n)
                      ((a ,m ,n) (+ m n))
                      ((a ,m ,n ,o) (guard (number? m) (number? n) (number? o)) (list "guarded-matched" (list m n o))))
          '("guarded-matched" (1 2 3)))
(run-test "basic test of multiple action items in match clause"
          ((compile-match 77 (display "") "match") 77)
          "match")

(define simple-eval
  (lambda (x)
    (sxml-match x
                [,i (guard (integer? i)) i]
                [(+ ,x ,y) (+ (simple-eval x) (simple-eval y))]
                [(* ,x ,y) (* (simple-eval x) (simple-eval y))]
                [(- ,x ,y) (- (simple-eval x) (simple-eval y))]
                [(/ ,x ,y) (/ (simple-eval x) (simple-eval y))]
                [,otherwise (error "simple-eval: invalid expression" x)])))

(run-test "basic test of explicit recursion in match clauses"
          (simple-eval '(* (+ 7 3) (- 7 3)))
          40)

(define simple-eval2
  (lambda (x)
    (sxml-match x
                [,i (guard (integer? i)) i]
                [(+ ,[x] ,[y]) (+ x y)]
                [(* ,[x] ,[y]) (* x y)]
                [(- ,[x] ,[y]) (- x y)]
                [(/ ,[x] ,[y]) (/ x y)]
                [,otherwise (error "simple-eval: invalid expression" x)])))

(run-test "basic test of anonymous catas"
          (simple-eval2 '(* (+ 7 3) (- 7 3)))
          40)

(define simple-eval3
  (lambda (x)
    (sxml-match x
                [,i (guard (integer? i)) i]
                [(+ ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (+ x y)]
                [(* ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (* x y)]
                [(- ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (- x y)]
                [(/ ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (/ x y)]
                [,otherwise (error "simple-eval: invalid expression" x)])))

(run-test "test of named catas"
          (simple-eval3 '(* (+ 7 3) (- 7 3)))
          40)

; need a test case for cata on a ". rest)" pattern

(run-test "successful test of attribute matching: pat-var in value position"
          (sxml-match '(e (@ (z 1)) 3 4 5)
                      [(e (@ (z ,d)) ,a ,b ,c) (list d a b c)]
                      [,otherwise #f])
          '(1 3 4 5))

(run-test "failing test of attribute matching: pat-var in value position"
          (sxml-match '(e (@ (a 1)) 3 4 5)
                      [(e (@ (z ,d)) ,a ,b ,c) (list d a b c)]
                      [,otherwise #f])
          #f)

(run-test "test of attribute matching: literal in value position"
          ((compile-match (e (@ (z 1)) ,a ,b ,c) (list a b c)) '(e (@ (z 1)) 3 4 5))
          '(3 4 5))

(run-test "test of attribute matching: default-value spec in value position"
          ((compile-match (e (@ (z (,d 1))) ,a ,b ,c) (list d a b c)) '(e 3 4 5))
          '(1 3 4 5))

(run-test "test of attribute matching: multiple attributes in pattern"
          ((compile-match (e (@ (y ,e) (z ,d)) ,a ,b ,c) (list e d a b c)) '(e (@ (z 1) (y 2)) 3 4 5))
          '(2 1 3 4 5))

(run-test "basic test of ellipses in pattern; no ellipses in output"
          ((compile-match (e ,i ...) i) '(e 3 4 5))
          '(3 4 5))

(run-test "test of non-null tail pattern following ellipses"
          ((compile-match (e ,i ... ,a ,b) i) '(e 3 4 5 6 7))
          '(3 4 5 ))

(define simple-eval4
  (lambda (x)
    (sxml-match x
                [,i (guard (integer? i)) i]
                [(+ ,[x*] ...) (apply + x*)]
                [(* ,[x*] ...) (apply * x*)]
                [(- ,[x] ,[y]) (- x y)]
                [(/ ,[x] ,[y]) (/ x y)]
                [,otherwise (error "simple-eval: invalid expression" x)])))

(run-test "test of catas with ellipses in pattern"
          (simple-eval4 '(* (+ 7 3) (- 7 3)))
          40)

(run-test "simple test of ellipses in pattern and output"
          ((compile-match (e ,i ...) ((lambda rst (cons 'f rst)) i ...)) '(e 3 4 5))
          '(f 3 4 5))

(define simple-eval5
  (lambda (x)
    (sxml-match x
                [,i (guard (integer? i)) i]
                [(+ ,[x*] ...) (+ x* ...)]
                [(* ,[x*] ...) (* x* ...)]
                [(- ,[x] ,[y]) (- x y)]
                [(/ ,[x] ,[y]) (/ x y)]
                [,otherwise (error "simple-eval: invalid expression" x)])))

(run-test "test of catas with ellipses in pattern and output"
          (simple-eval5 '(* (+ 7 3) (- 7 3)))
          40)

(run-test "test of nested dots in pattern and output"
          ((lambda (x)
             (sxml-match x
                         [(d (a ,b ...) ...)
                          (list (list b ...) ...)]))
           '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10)))
          '((1 2 3) (4 5) (6 7 8) (9 10)))

(run-test "test successful tail pattern match (after ellipses)"
          (sxml-match '(e 3 4 5 6 7) ((e ,i ... 6 7) #t) (,otherwise #f))
          #t)

(run-test "test failing tail pattern match (after ellipses), too few items"
          (sxml-match '(e 3 4 5 6) ((e ,i ... 6 7) #t) (,otherwise #f))
          #f)

(run-test "test failing tail pattern match (after ellipses), too many items"
          (sxml-match '(e 3 4 5 6 7 8) ((e ,i ... 6 7) #t) (,otherwise #f))
          #f)

(run-test "test failing tail pattern match (after ellipses), wrong items"
          (sxml-match '(e 3 4 5 7 8) ((e ,i ... 6 7) #t) (,otherwise #f))
          #f)

(run-test "test of ellipses in output quasiquote"
          (sxml-match '(e 3 4 5 6 7)
                      [(e ,i ... 6 7) `("start" ,i ... "end")]
                      [,otherwise #f])
          '("start" 3 4 5 "end"))

(run-test "test of ellipses in output quasiquote, with more complex unquote expression"
          (sxml-match '(e 3 4 5 6 7)
                      [(e ,i ... 6 7) `("start" ,(list 'wrap i) ... "end")]
                      [,otherwise #f])
          '("start" (wrap 3) (wrap 4) (wrap 5) "end"))

(run-test "test of a quasiquote expr within the dotted unquote expression"
          (sxml-match '(e 3 4 5 6 7)
                      [(e ,i ... 6 7) `("start" ,`(wrap ,i) ... "end")]
                      [,otherwise #f])
          '("start" (wrap 3) (wrap 4) (wrap 5) "end"))

(define xyzpq '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       `(,`(,b ...) ...)])
          '((1 2 3) (4 5) (6 7 8) (9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       (list (list b ...) ...)])
          '((1 2 3) (4 5) (6 7 8) (9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       `(xx ,`(y ,b ...) ...)])
          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       `(xx ,@(map (lambda (i) `(y ,@i)) b))])
          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       `(xx ,(cons 'y b) ...)])
          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       `(xx ,`(y ,b ...) ...)])
          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       `(xx ,`(y ,@b) ...)])
          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       `((,b ...) ...)])
          '((1 2 3) (4 5) (6 7 8) (9 10)))

(run-test "quasiquote tests"
          (sxml-match xyzpq
                      [(d (a ,b ...) ...)
                       `(xx (y ,b ...) ...)])
          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))

(define (prog-trans p)
  (sxml-match p
              [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)
                        (Description . ,desc)
                        ,cl)
               `(div (p ,start-time
                        (br) ,series-title
                        (br) ,desc)
                     ,cl)]
              [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)
                        (Description . ,desc))
               `(div (p ,start-time
                        (br) ,series-title
                        (br) ,desc))]
              [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title))
               `(div (p ,start-time
                        (br) ,series-title))]))

(run-test "test for shrinking-order list of pattern clauses"
          (prog-trans '(Program (Start "2001-07-05T20:00:00") (Duration "PT1H") (Series "HomeFront")))
          '(div (p "2001-07-05T20:00:00" (br) "HomeFront")))

(run-test "test binding of unmatched attributes"
          (sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6)
                      [(a (@ (y ,www) . ,qqq) ,t ...)
                       (list www qqq t ...)])
          '(2 ((z 1) (x 3)) 4 5 6))

(run-test "test binding all attributes"
          (sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6)
                      [(a (@ . ,qqq) ,t ...)
                       (list qqq t ...)])
          '(((z 1) (y 2) (x 3)) 4 5 6))

(run-test "test multiple value returns"
           (call-with-values
               (lambda ()
                 (sxml-match '(foo)
                   ((foo) (values 'x 'y))))
             (lambda (x y)
               (cons x y)))
           '(x . y))


code:
;;;; sxml.fold.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 (sxml fold).
;;
;;; Code:

(define-module (test-suite sxml-fold)
  #:use-module (test-suite lib)
  #:use-module ((srfi srfi-1) #:select (fold))
  #:use-module (sxml fold))

(define atom? (@@ (sxml fold) atom?))
(define (id x) x)
(define-syntax accept
  (syntax-rules ()
    ((_ expr)
     (call-with-values (lambda () expr) list))))

(with-test-prefix "test-fold"
  (define test-doc
    '(presentation
      (@ (width 1024)
         (height 768)
         (title-style "font-family:Georgia")
         (title-height 72)
         (title-baseline-y 96)
         (title-x 48)
         (text-height 64)
         (text-style "font-family:Georgia")
         (text-upper-left-x 96)
         (text-upper-left-y 216))
      (slide
       (@ (title "Declarative interface"))
       (p "The declarative interface"
          "lets you be more concise"
          "when making the slides."))
      (slide
       (@ (title "Still cumbersome"))
       (p "Parentheses are still"
          "cumbersome."))))

  (pass-if (atom? 'foo))
  (pass-if (atom? '()))
  (pass-if (not (atom? '(1 2 3))))

  (pass-if "foldt identity"
    (equal? (foldt id id test-doc) test-doc))

  (pass-if "fold cons == reverse"
    (equal? (fold cons '() test-doc)
            (reverse test-doc)))

  (pass-if "foldts identity"
    (equal? (foldts (lambda (seed tree) '())
                    (lambda (seed kid-seed tree)
                      (cons (reverse kid-seed) seed))
                    (lambda (seed tree)
                      (cons tree seed))
                    '()
                    test-doc)
            (cons test-doc '())))

  (pass-if "foldts* identity"
    (equal? (foldts* (lambda (seed tree) (values '() tree))
                     (lambda (seed kid-seed tree)
                       (cons (reverse kid-seed) seed))
                     (lambda (seed tree)
                       (cons tree seed))
                     '()
                     test-doc)
            (cons test-doc '())))

  (pass-if "fold-values == fold"
    (equal? (fold-values cons test-doc '())
            (fold cons '() test-doc)))

  (pass-if "foldts*-values == foldts*"
    (equal? (foldts*-values
             (lambda (tree seed) (values tree '()))
             (lambda (tree seed kid-seed)
               (cons (reverse kid-seed) seed))
             (lambda (tree seed)
               (cons tree seed))
             test-doc
             '())
            (foldts* (lambda (seed tree) (values '() tree))
                     (lambda (seed kid-seed tree)
                       (cons (reverse kid-seed) seed))
                     (lambda (seed tree)
                       (cons tree seed))
                     '()
                     test-doc)))

  (let ()
    (define (replace pred val list)
      (reverse
       (fold
        (lambda (x xs)
          (cons (if (pred x) val x) xs))
        '()
        list)))

    (define (car-eq? x what)
      (and (pair? x) (eq? (car x) what)))

    ;; avoid entering <slide>
    (pass-if "foldts* *pre* behaviour"
      (equal? (foldts*-values
               (lambda (tree seed)
                 (values (if (car-eq? tree 'slide) '() tree) '()))
               (lambda (tree seed kid-seed)
                 (cons (reverse kid-seed) seed))
               (lambda (tree seed)
                 (cons tree seed))
               test-doc
               '())
              (cons
               (replace (lambda (x) (car-eq? x 'slide))
                        '()
                        test-doc)
               '()))))

  (let ()
    (define (all-elts tree)
      (reverse!
       (foldts*-values
        (lambda (tree seed)
          (values tree seed))
        (lambda (tree seed kid-seed)
          kid-seed)
        (lambda (tree seed)
          (cons tree seed))
        tree
        '())))

    (define (len tree)
      (foldts*-values
       (lambda (tree seed)
         (values tree seed))
       (lambda (tree seed kid-seed)
         kid-seed)
       (lambda (tree seed)
         (1+ seed))
       tree
       0))

    (pass-if "foldts length"
      (equal? (length (all-elts test-doc))
              (len test-doc)))))

(with-test-prefix "test-fold-layout"
  (define test-doc
    '(presentation
      (@ (width 1024)
         (height 768)
         (title-style "font-family:Georgia")
         (title-height 72)
         (title-baseline-y 96)
         (title-x 48)
         (text-height 64)
         (text-style "font-family:Georgia")
         (text-upper-left-x 96)
         (text-upper-left-y 216))
      (slide
       (@ (title "Declarative interface"))
       (p "The declarative interface"
          "lets you be more concise"
          "when making the slides."))
      (slide
       (@ (title "Still cumbersome"))
       (p "Parentheses are still"
          "cumbersome."))))

  (define (identity-layout tree)
    (fold-layout
     tree
     `((*default*
        . ,(lambda (tag params old-layout layout kids)
             (values layout
                     (if (null? (car params))
                         (cons tag kids)
                         (cons* tag (cons '@ (car params)) kids)))))
       (*text*
        . ,(lambda (text params layout)
             (values layout text))))
     '()
     (cons 0 0)
     '()))

  (pass-if "fold-layout"
    (equal? (accept (identity-layout test-doc))
            (list test-doc (cons 0 0)))))

license: mit


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

(define-module (test-sxml-match)
  #:use-module (test-suite lib)
  #:use-module (sxml match))

(define-syntax run-test
  (syntax-rules ()
    ((_ desc test expected-result)
     (pass-if desc (equal? test expected-result)))))

;;;
;;; Include upstream source file.
;;;

;; This file was taken unmodified from
;; <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/> on
;; 2010-05-24.  It was written by Jim Bender <benderjg2@aol.com> and released
;; under the MIT/X11 license
;; <http://www.gnu.org/licenses/license-list.html#X11License>.
;;
;; It was modified to remove the `#lang' and `require' forms as well as the
;; `run-test' macro, replaced by the one above.
;;
;; FIXME: The `xyzpq' variable in there is originally named `x' but using that
;; name triggers a psyntax "identifier out of context" error.

(include-from-path "test-suite/tests/sxml-match-tests.ss")


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

(define-module (test-sxml-simple)
  #:use-module (test-suite lib)
  #:use-module (sxml simple))

(define %xml-sample
  ;; An XML sample without any space in between tags, to make it easier.
  (string-append "<?xml version='1.0' encoding='utf-8'?>"
                 "<foo chbouib=\"yes\">"
                   "<bar/>"
                   "<baz>"
                     "<smurf one=\"1\"/>"
                   "</baz>"
                 "</foo>"))

(with-test-prefix "simple"

  (pass-if "xml->sxml"
    (equal?  (xml->sxml (open-input-string %xml-sample))
            '(*TOP*
              (*PI* xml "version='1.0' encoding='utf-8'")
              (foo (@ (chbouib "yes"))
                   (bar)
                   (baz (smurf (@ (one "1"))))))))

  (pass-if "xml->sxml->xml->sxml"
    ;; Regression test for bug #29260.
    (equal? (xml->sxml (open-input-string %xml-sample))
            (xml->sxml
             (open-input-string
              (with-output-to-string
                (lambda ()
                  (sxml->xml
                   (xml->sxml (open-input-string %xml-sample))))))))))


code:
;;;; sxml.ssax.test                 -*- scheme -*-
;;;;
;;;; Copyright (C) 2010  Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2002,2003,2004 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 ssax). You can tweak this harness to get more
;; debugging information, but in the end I just wanted to keep Oleg's
;; tests in the file and see if we could work with them directly.
;;
;;; Code:

(define-module (test-suite sxml-ssax)
  #:use-module (sxml ssax input-parse)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-13)
  #:use-module (sxml ssax)
  #:use-module (ice-9 pretty-print))

(define pp pretty-print)

(define-macro (import module . symbols)
  `(begin
     ,@(map (lambda (sym)
              `(module-define! (current-module) ',sym (module-ref (resolve-module ',module) ',sym)))
            symbols)))

;; This list was arrived at over time. See the problem is that SSAX's
;; test cases are inline with its text, and written in the private
;; language of SSAX. That is to say, they use procedures that (sxml
;; ssax) doesn't export. So here we test that the procedures from (sxml
;; ssax) actually work, but in order to do so we have to pull in private
;; definitions. It's not the greatest solution, but it's what we got.
(import (sxml ssax)
        ssax:read-NCName
        ssax:read-QName
        ssax:largest-unres-name
        ssax:Prefix-XML
        ssax:resolve-name
        ssax:scan-Misc
        ssax:assert-token
        ssax:handle-parsed-entity
        ssax:warn
        ssax:skip-pi
        ssax:S-chars
        ssax:skip-S
        ssax:ncname-starting-char?
        ssax:define-labeled-arg-macro
        let*-values
        ssax:make-parser/positional-args
        when
        make-xml-token
        nl
        ;unesc-string
        parser-error
        ascii->char
        char->ascii
        char-newline
        char-return
        char-tab
        name-compare)

(define (cout . args)
  "Similar to @code{cout << arguments << args}, where @var{argument} can
be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
called without args rather than printed."
  (for-each (lambda (x)
              (if (procedure? x) (x) (display x)))
            args))

(define (cerr . args)
  "Similar to @code{cerr << arguments << args}, where @var{argument} can
be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
called without args rather than printed."
  (format (current-ssax-error-port)
          ";;; SSAX warning: ~a\n" args))

(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-syntax failed?
  (syntax-rules ()
    ((_ e ...)
     (not (false-if-exception (begin e ... #t))))))

(define *saved-port* (current-output-port))

(define-syntax assert
  (syntax-rules ()
    ((assert expr ...)
     (with-output-to-port *saved-port*
       (lambda ()
         (pass-if '(and expr ...)
           (let* ((out (open-output-string))
                  (res (with-output-to-port out
                         (lambda ()
                           (with-ssax-error-to-port (current-output-port)
                                                    (lambda ()
                                                      (and expr ...)))))))
             ;; (get-output-string out)
             res)))))))

(define (load-tests file)
  (with-input-from-file (%search-load-path file)
    (lambda ()
      (let loop ((sexp (read)))
        (cond
         ((eof-object? sexp))
         ((and (pair? sexp) (pair? (cdr sexp))
               (eq? (cadr sexp) 'run-test))
          (primitive-eval sexp)
          (loop (read)))
         ((and (pair? sexp) (eq? (car sexp) 'run-test))
          (primitive-eval sexp)
          (loop (read)))
         (else
          (loop (read))))))))

(with-output-to-string
  (lambda ()
    (load-tests "sxml/upstream/SSAX.scm")))


code:
;;;; sxml.transform.test                 -*- scheme -*-
;;;;
;;;; Copyright (C) 2010  Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2002,2003,2004 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 transform).
;;
;;; Code:

(define-module (test-suite sxml-transform)
  #:use-module (test-suite lib)
  #:use-module (sxml transform))

(let* ((tree '(root (n1 (n11) "s12" (n13))
                "s2"
                (n2 (n21) "s22")
                (n3 (n31 (n311))
                    "s32"
                    (n33 (n331) "s332" (n333))
                    "s34"))))
  (define (test pred-begin pred-end expected)
    (pass-if expected
      (equal? expected (car (replace-range pred-begin pred-end (list tree))))))

  ;; Remove one node, "s2"
  (test
   (lambda (node)
     (and (equal? node "s2") '()))
   (lambda (node) (list node))
   '(root (n1 (n11) "s12" (n13))
      (n2 (n21) "s22")
      (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))

  ;; Replace one node, "s2" with "s2-new"
  (test
   (lambda (node)
     (and (equal? node "s2") '("s2-new")))
   (lambda (node) (list node))
   '(root (n1 (n11) "s12" (n13))
      "s2-new"
      (n2 (n21) "s22")
      (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))

  ;; Replace one node, "s2" with "s2-new" and its brother (n-new "s")
  (test
   (lambda (node)
     (and (equal? node "s2") '("s2-new" (n-new "s"))))
   (lambda (node) (list node))
   '(root (n1 (n11) "s12" (n13))
      "s2-new" (n-new "s")
      (n2 (n21) "s22")
      (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))

  ;; Remove everything from "s2" onward
  (test
   (lambda (node)
     (and (equal? node "s2") '()))
   (lambda (node) #f)
   '(root (n1 (n11) "s12" (n13))))

  ;; Remove everything from "n1" onward
  (test
   (lambda (node)
     (and (pair? node) (eq? 'n1 (car node)) '()))
   (lambda (node) #f)
   '(root))

  ;; Replace from n1 through n33
  (test
   (lambda (node)
     (and (pair? node)
          (eq? 'n1 (car node))
          (list node '(n1* "s12*"))))
   (lambda (node)
     (and (pair? node)
          (eq? 'n33 (car node))
          (list node)))
   '(root
        (n1 (n11) "s12" (n13))
      (n1* "s12*")
      (n3
       (n33 (n331) "s332" (n333))
       "s34"))))


code:
;;;; sxml.xpath.test                 -*- scheme -*-
;;;;
;;;; Copyright (C) 2010  Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2002,2003,2004 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 xpath).
;;
;;; Code:

(define-module (test-suite sxml-xpath)
  #:use-module (test-suite lib)
  #:use-module (sxml xpath))

(define tree1
  '(html
    (head (title "Slides"))
    (body
     (p (@ (align "center"))
	(table (@ (style "font-size: x-large"))
	       (tr
		(td (@ (align "right")) "Talks ")
		(td (@ (align "center")) " = ")
		(td " slides + transition"))
	       (tr (td)
		   (td (@ (align "center")) " = ")
		   (td " data + control"))
	       (tr (td)
		   (td (@ (align "center")) " = ")
		   (td " programs"))))
     (ul
      (li (a (@ (href "slides/slide0001.gif")) "Introduction"))
      (li (a (@ (href "slides/slide0010.gif")) "Summary")))
     )))

;; Example from a posting "Re: DrScheme and XML",
;; Shriram Krishnamurthi, comp.lang.scheme, Nov. 26. 1999.
;; http://www.deja.com/getdoc.xp?AN=553507805
(define tree3
  '(poem (@ (title "The Lovesong of J. Alfred Prufrock")
	    (poet "T. S. Eliot"))
	 (stanza
	  (line "Let us go then, you and I,")
	  (line "When the evening is spread out against the sky")
	  (line "Like a patient etherized upon a table:"))
	 (stanza
	  (line "In the room the women come and go")
	  (line "Talking of Michaelangelo."))))

(define (run-test selector node expected)
  (pass-if expected
    (equal? expected (selector node))))

(with-test-prefix "test-all"

  ;; Location path, full form: child::para
  ;; Location path, abbreviated form: para
  ;; selects the para element children of the context node
  (let ((tree
         '(elem (@) (para (@) "para") (br (@)) "cdata" (para (@) "second par"))
         )
        (expected '((para (@) "para") (para (@) "second par")))
        )
    (run-test (select-kids (node-typeof? 'para)) tree expected)
    (run-test (sxpath '(para)) tree expected))

  ;; Location path, full form: child::*
  ;; Location path, abbreviated form: *
  ;; selects all element children of the context node
  (let ((tree
         '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
         )
        (expected
         '((para (@) "para") (br (@)) (para "second par")))
        )
    (run-test (select-kids (node-typeof? '*)) tree expected)
    (run-test (sxpath '(*)) tree expected))

  ;; Location path, full form: child::text()
  ;; Location path, abbreviated form: text()
  ;; selects all text node children of the context node
  (let ((tree
         '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
         )
        (expected
         '("cdata"))
        )
    (run-test (select-kids (node-typeof? '*text*)) tree expected)
    (run-test (sxpath '(*text*)) tree expected))

  ;; Location path, full form: child::node()
  ;; Location path, abbreviated form: node()
  ;; selects all the children of the context node, whatever their node type
  (let* ((tree
          '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
          )
         (expected (cdr tree))
         )
    (run-test (select-kids (node-typeof? '*any*)) tree expected)
    (run-test (sxpath '(*any*)) tree expected)
    )

  ;; Location path, full form: child::*/child::para
  ;; Location path, abbreviated form: */para
  ;; selects all para grandchildren of the context node

  (let ((tree
         '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")
                (div (@ (name "aa")) (para "third para")))
         )
        (expected
         '((para "third para")))
        )
    (run-test
     (node-join (select-kids (node-typeof? '*))
                (select-kids (node-typeof? 'para)))
     tree expected)
    (run-test (sxpath '(* para)) tree expected)
    )

  ;; Location path, full form: attribute::name
  ;; Location path, abbreviated form: @name
  ;; selects the 'name' attribute of the context node

  (let ((tree
         '(elem (@ (name "elem") (id "idz"))
                (para (@) "para") (br (@)) "cdata" (para (@) "second par")
                (div (@ (name "aa")) (para (@) "third para")))
         )
        (expected
         '((name "elem")))
        )
    (run-test
     (node-join (select-kids (node-typeof? '@))
                (select-kids (node-typeof? 'name)))
     tree expected)
    (run-test (sxpath '(@ name)) tree expected)
    )

  ;; Location path, full form:  attribute::*
  ;; Location path, abbreviated form: @*
  ;; selects all the attributes of the context node
  (let ((tree
         '(elem (@ (name "elem") (id "idz"))
                (para (@) "para") (br (@)) "cdata" (para "second par")
                (div (@ (name "aa")) (para (@) "third para")))
         )
        (expected
         '((name "elem") (id "idz")))
        )
    (run-test
     (node-join (select-kids (node-typeof? '@))
                (select-kids (node-typeof? '*)))
     tree expected)
    (run-test (sxpath '(@ *)) tree expected)
    )

  ;; Location path, full form: descendant::para
  ;; Location path, abbreviated form: .//para
  ;; selects the para element descendants of the context node

  (let ((tree
         '(elem (@ (name "elem") (id "idz"))
                (para (@) "para") (br (@)) "cdata" (para "second par")
                (div (@ (name "aa")) (para (@) "third para")))
         )
        (expected
         '((para (@) "para") (para "second par") (para (@) "third para")))
        )
    (run-test
     (node-closure (node-typeof? 'para))
     tree expected)
    (run-test (sxpath '(// para)) tree expected)
    )

  ;; Location path, full form: self::para
  ;; Location path, abbreviated form: _none_
  ;; selects the context node if it is a para element; otherwise selects nothing

  (let ((tree
         '(elem (@ (name "elem") (id "idz"))
                (para (@) "para") (br (@)) "cdata" (para "second par")
                (div (@ (name "aa")) (para (@) "third para")))
         )
        )
    (run-test (node-self (node-typeof? 'para)) tree '())
    (run-test (node-self (node-typeof? 'elem)) tree (list tree))
    )

  ;; Location path, full form: descendant-or-self::node()
  ;; Location path, abbreviated form: //
  ;; selects the context node, all the children (including attribute nodes)
  ;; of the context node, and all the children of all the (element)
  ;; descendants of the context node.
  ;; This is _almost_ a powerset of the context node.
  (let* ((tree
          '(para (@ (name "elem") (id "idz"))
                 (para (@) "para") (br (@)) "cdata" (para "second par")
                 (div (@ (name "aa")) (para (@) "third para")))
          )
         (expected
          (cons tree
                (append (cdr tree)
                        '((@) "para" (@) "second par"
                          (@ (name "aa")) (para (@) "third para")
                          (@) "third para"))))
         )
    (run-test
     (node-or
      (node-self (node-typeof? '*any*))
      (node-closure (node-typeof? '*any*)))
     tree expected)
    (run-test (sxpath '(//)) tree expected)
    )

  ;; Location path, full form: ancestor::div
  ;; Location path, abbreviated form: _none_
  ;; selects all div ancestors of the context node
  ;; This Location expression is equivalent to the following:
                                        ;	/descendant-or-self::div[descendant::node() = curr_node]
  ;; This shows that the ancestor:: axis is actually redundant. Still,
  ;; it can be emulated as the following SXPath expression demonstrates.

  ;; The insight behind "ancestor::div" -- selecting all "div" ancestors
  ;; of the current node -- is
  ;;  S[ancestor::div] context_node =
  ;;    { y | y=subnode*(root), context_node=subnode(subnode*(y)),
  ;;          isElement(y), name(y) = "div" }
  ;; We observe that
  ;;    { y | y=subnode*(root), pred(y) }
  ;; can be expressed in SXPath as
  ;;    ((node-or (node-self pred) (node-closure pred)) root-node)
  ;; The composite predicate 'isElement(y) & name(y) = "div"' corresponds to
  ;; (node-self (node-typeof? 'div)) in SXPath. Finally, filter
  ;; context_node=subnode(subnode*(y)) is tantamount to
  ;; (node-closure (node-eq? context-node)), whereas node-reduce denotes the
  ;; the composition of converters-predicates in the filtering context.

  (let*
      ((root
           '(div (@ (name "elem") (id "idz"))
                 (para (@) "para") (br (@)) "cdata" (para (@) "second par")
                 (div (@ (name "aa")) (para (@) "third para"))))
       (context-node ; /descendant::any()[child::text() == "third para"]
        (car
         ((node-closure
           (select-kids
            (node-equal? "third para")))
          root)))
       (pred
        (node-reduce (node-self (node-typeof? 'div))
                     (node-closure (node-eq? context-node))
                     ))
       )
    (run-test
     (node-or
      (node-self pred)
      (node-closure pred))
     root
     (cons root
           '((div (@ (name "aa")) (para (@) "third para")))))
    )

  ;; Location path, full form: child::div/descendant::para
  ;; Location path, abbreviated form: div//para
  ;; selects the para element descendants of the div element
  ;; children of the context node

  (let ((tree
         '(elem (@ (name "elem") (id "idz"))
                (para (@) "para") (br (@)) "cdata" (para "second par")
                (div (@ (name "aa")) (para (@) "third para")
                     (div (para "fourth para"))))
         )
        (expected
         '((para (@) "third para") (para "fourth para")))
        )
    (run-test
     (node-join
      (select-kids (node-typeof? 'div))
      (node-closure (node-typeof? 'para)))
     tree expected)
    (run-test (sxpath '(div // para)) tree expected)
    )

  ;; Location path, full form: /descendant::olist/child::item
  ;; Location path, abbreviated form: //olist/item
  ;; selects all the item elements that have an olist parent (which is not root)
  ;; and that are in the same document as the context node
  ;; See the following test.

  ;; Location path, full form: /descendant::td/attribute::align
  ;; Location path, abbreviated form: //td/@align
  ;; Selects 'align' attributes of all 'td' elements in tree1
  (let ((tree tree1)
        (expected
         '((align "right") (align "center") (align "center") (align "center"))
         ))
    (run-test
     (node-join
      (node-closure (node-typeof? 'td))
      (select-kids (node-typeof? '@))
      (select-kids (node-typeof? 'align)))
     tree expected)
    (run-test (sxpath '(// td @ align)) tree expected)
    )

  ;; Location path, full form: /descendant::td[attribute::align]
  ;; Location path, abbreviated form: //td[@align]
  ;; Selects all td elements that have an attribute 'align' in tree1
  (let ((tree tree1)
        (expected
         '((td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ")
           (td (@ (align "center")) " = ") (td (@ (align "center")) " = "))
         ))
    (run-test
     (node-reduce
      (node-closure (node-typeof? 'td))
      (filter
       (node-join
        (select-kids (node-typeof? '@))
        (select-kids (node-typeof? 'align)))))
     tree expected)
    (run-test (sxpath `(// td ,(node-self (sxpath '(@ align)))))  tree expected)
    (run-test (sxpath '(// (td (@ align)))) tree expected)
    (run-test (sxpath '(// ((td) (@ align)))) tree expected)
    ;; note! (sxpath ...) is a converter. Therefore, it can be used
    ;; as any other converter, for example, in the full-form SXPath.
    ;; Thus we can mix the full and abbreviated form SXPath's freely.
    (run-test
     (node-reduce
      (node-closure (node-typeof? 'td))
      (filter
       (sxpath '(@ align))))
     tree expected)
    )

  ;; Location path, full form: /descendant::td[attribute::align = "right"]
  ;; Location path, abbreviated form: //td[@align = "right"]
  ;; Selects all td elements that have an attribute align = "right" in tree1
  (let ((tree tree1)
        (expected
         '((td (@ (align "right")) "Talks "))
         ))
    (run-test
     (node-reduce
      (node-closure (node-typeof? 'td))
      (filter
       (node-join
        (select-kids (node-typeof? '@))
        (select-kids (node-equal? '(align "right"))))))
     tree expected)
    (run-test (sxpath '(// (td (@ (equal? (align "right")))))) tree expected)
    )

  ;; Location path, full form: child::para[position()=1]
  ;; Location path, abbreviated form: para[1]
  ;; selects the first para child of the context node
  (let ((tree
         '(elem (@ (name "elem") (id "idz"))
                (para (@) "para") (br (@)) "cdata" (para "second par")
                (div (@ (name "aa")) (para (@) "third para")))
         )
        (expected
         '((para (@) "para"))
         ))
    (run-test
     (node-reduce
      (select-kids (node-typeof? 'para))
      (node-pos 1))
     tree expected)
    (run-test (sxpath '((para 1))) tree expected)
    )

  ;; Location path, full form: child::para[position()=last()]
  ;; Location path, abbreviated form: para[last()]
  ;; selects the last para child of the context node
  (let ((tree
         '(elem (@ (name "elem") (id "idz"))
                (para (@) "para") (br (@)) "cdata" (para "second par")
                (div (@ (name "aa")) (para (@) "third para")))
         )
        (expected
         '((para "second par"))
         ))
    (run-test
     (node-reduce
      (select-kids (node-typeof? 'para))
      (node-pos -1))
     tree expected)
    (run-test (sxpath '((para -1))) tree expected)
    )

  ;; Illustrating the following Note of Sec 2.5 of XPath:
  ;; "NOTE: The location path //para[1] does not mean the same as the
  ;; location path /descendant::para[1]. The latter selects the first
  ;; descendant para element; the former selects all descendant para
  ;; elements that are the first para children of their parents."

  (let ((tree
         '(elem (@ (name "elem") (id "idz"))
                (para (@) "para") (br (@)) "cdata" (para "second par")
                (div (@ (name "aa")) (para (@) "third para")))
         )
        )
    (run-test
     (node-reduce                       ; /descendant::para[1] in SXPath
      (node-closure (node-typeof? 'para))
      (node-pos 1))
     tree '((para (@) "para")))
    (run-test (sxpath '(// (para 1))) tree
              '((para (@) "para") (para (@) "third para")))
    )

  ;; Location path, full form: parent::node()
  ;; Location path, abbreviated form: ..
  ;; selects the parent of the context node. The context node may be
  ;; an attribute node!
  ;; For the last test:
  ;; Location path, full form: parent::*/attribute::name
  ;; Location path, abbreviated form: ../@name
  ;; Selects the name attribute of the parent of the context node

  (let* ((tree
          '(elem (@ (name "elem") (id "idz"))
                 (para (@) "para") (br (@)) "cdata" (para "second par")
                 (div (@ (name "aa")) (para (@) "third para")))
          )
         (para1                         ; the first para node
          (car ((sxpath '(para)) tree)))
         (para3                         ; the third para node
          (car ((sxpath '(div para)) tree)))
         (div                           ; div node
          (car ((sxpath '(// div)) tree)))
         )
    (run-test
     (node-parent tree)
     para1 (list tree))
    (run-test
     (node-parent tree)
     para3 (list div))
    (run-test                 ; checking the parent of an attribute node
     (node-parent tree)
     ((sxpath '(@ name)) div) (list div))
    (run-test
     (node-join
      (node-parent tree)
      (select-kids (node-typeof? '@))
      (select-kids (node-typeof? 'name)))
     para3 '((name "aa")))
    (run-test
     (sxpath `(,(node-parent tree) @ name))
     para3 '((name "aa")))
    )

  ;; Location path, full form: following-sibling::chapter[position()=1]
  ;; Location path, abbreviated form: none
  ;; selects the next chapter sibling of the context node
  ;; The path is equivalent to
  ;;  let cnode = context-node
  ;;    in
  ;;	parent::* / child::chapter [take-after node_eq(self::*,cnode)]
  ;;		[position()=1]
  (let* ((tree
          '(document
            (preface "preface")
            (chapter (@ (id "one")) "Chap 1 text")
            (chapter (@ (id "two")) "Chap 2 text")
            (chapter (@ (id "three")) "Chap 3 text")
            (chapter (@ (id "four")) "Chap 4 text")
            (epilogue "Epilogue text")
            (appendix (@ (id "A")) "App A text")
            (References "References"))
          )
         (a-node                        ; to be used as a context node
          (car ((sxpath '(// (chapter (@ (equal? (id "two")))))) tree)))
         (expected
          '((chapter (@ (id "three")) "Chap 3 text")))
         )
    (run-test
     (node-reduce
      (node-join
       (node-parent tree)
       (select-kids (node-typeof? 'chapter)))
      (take-after (node-eq? a-node))
      (node-pos 1)
      )
     a-node expected)
    )

  ;; preceding-sibling::chapter[position()=1]
  ;; selects the previous chapter sibling of the context node
  ;; The path is equivalent to
  ;;  let cnode = context-node
  ;;    in
  ;;	parent::* / child::chapter [take-until node_eq(self::*,cnode)]
  ;;		[position()=-1]
  (let* ((tree
          '(document
            (preface "preface")
            (chapter (@ (id "one")) "Chap 1 text")
            (chapter (@ (id "two")) "Chap 2 text")
            (chapter (@ (id "three")) "Chap 3 text")
            (chapter (@ (id "four")) "Chap 4 text")
            (epilogue "Epilogue text")
            (appendix (@ (id "A")) "App A text")
            (References "References"))
          )
         (a-node                        ; to be used as a context node
          (car ((sxpath '(// (chapter (@ (equal? (id "three")))))) tree)))
         (expected
          '((chapter (@ (id "two")) "Chap 2 text")))
         )
    (run-test
     (node-reduce
      (node-join
       (node-parent tree)
       (select-kids (node-typeof? 'chapter)))
      (take-until (node-eq? a-node))
      (node-pos -1)
      )
     a-node expected)
    )

  ;; /descendant::figure[position()=42]
  ;; selects the forty-second figure element in the document
  ;; See the next example, which is more general.

  ;; Location path, full form:
  ;;    child::table/child::tr[position()=2]/child::td[position()=3]
  ;; Location path, abbreviated form: table/tr[2]/td[3]
  ;; selects the third td of the second tr of the table
  (let ((tree ((node-closure (node-typeof? 'p)) tree1))
        (expected
         '((td " data + control"))
         ))
    (run-test
     (node-join
      (select-kids (node-typeof? 'table))
      (node-reduce (select-kids (node-typeof? 'tr))
                   (node-pos 2))
      (node-reduce (select-kids (node-typeof? 'td))
                   (node-pos 3)))
     tree expected)
    (run-test (sxpath '(table (tr 2) (td 3))) tree expected)
    )

  ;; Location path, full form:
  ;;		child::para[attribute::type='warning'][position()=5]
  ;; Location path, abbreviated form: para[@type='warning'][5]
  ;; selects the fifth para child of the context node that has a type
  ;; attribute with value warning
  (let ((tree
         '(chapter
           (para "para1")
           (para (@ (type "warning")) "para 2")
           (para (@ (type "warning")) "para 3")
           (para (@ (type "warning")) "para 4")
           (para (@ (type "warning")) "para 5")
           (para (@ (type "warning")) "para 6"))
         )
        (expected
         '((para (@ (type "warning")) "para 6"))
         ))
    (run-test
     (node-reduce
      (select-kids (node-typeof? 'para))
      (filter
       (node-join
        (select-kids (node-typeof? '@))
        (select-kids (node-equal? '(type "warning")))))
      (node-pos 5))
     tree expected)
    (run-test (sxpath '( (((para (@ (equal? (type "warning"))))) 5 )  ))
              tree expected)
    (run-test (sxpath '( (para (@ (equal? (type "warning"))) 5 )  ))
              tree expected)
    )

  ;; Location path, full form:
  ;;		child::para[position()=5][attribute::type='warning']
  ;; Location path, abbreviated form: para[5][@type='warning']
  ;; selects the fifth para child of the context node if that child has a 'type'
  ;; attribute with value warning
  (let ((tree
         '(chapter
           (para "para1")
           (para (@ (type "warning")) "para 2")
           (para (@ (type "warning")) "para 3")
           (para (@ (type "warning")) "para 4")
           (para (@ (type "warning")) "para 5")
           (para (@ (type "warning")) "para 6"))
         )
        (expected
         '((para (@ (type "warning")) "para 5"))
         ))
    (run-test
     (node-reduce
      (select-kids (node-typeof? 'para))
      (node-pos 5)
      (filter
       (node-join
        (select-kids (node-typeof? '@))
        (select-kids (node-equal? '(type "warning"))))))
     tree expected)
    (run-test (sxpath '( (( (para 5))  (@ (equal? (type "warning"))))))
              tree expected)
    (run-test (sxpath '( (para 5 (@ (equal? (type "warning")))) ))
              tree expected)
    )

  ;; Location path, full form:
  ;;		child::*[self::chapter or self::appendix]
  ;; Location path, semi-abbreviated form: *[self::chapter or self::appendix]
  ;; selects the chapter and appendix children of the context node
  (let ((tree
         '(document
           (preface "preface")
           (chapter (@ (id "one")) "Chap 1 text")
           (chapter (@ (id "two")) "Chap 2 text")
           (chapter (@ (id "three")) "Chap 3 text")
           (epilogue "Epilogue text")
           (appendix (@ (id "A")) "App A text")
           (References "References"))
         )
        (expected
         '((chapter (@ (id "one")) "Chap 1 text")
           (chapter (@ (id "two")) "Chap 2 text")
           (chapter (@ (id "three")) "Chap 3 text")
           (appendix (@ (id "A")) "App A text"))
         ))
    (run-test
     (node-join
      (select-kids (node-typeof? '*))
      (filter
       (node-or
        (node-self (node-typeof? 'chapter))
        (node-self (node-typeof? 'appendix)))))
     tree expected)
    (run-test (sxpath `(* ,(node-or (node-self (node-typeof? 'chapter))
                                    (node-self (node-typeof? 'appendix)))))
              tree expected)
    )

  ;; Location path, full form: child::chapter[child::title='Introduction']
  ;; Location path, abbreviated form: chapter[title = 'Introduction']
  ;; selects the chapter children of the context node that have one or more
  ;; title children with string-value equal to Introduction
  ;; See a similar example: //td[@align = "right"] above.

  ;; Location path, full form: child::chapter[child::title]
  ;; Location path, abbreviated form: chapter[title]
  ;; selects the chapter children of the context node that have one or
  ;; more title children
  ;; See a similar example //td[@align] above.

  (let ((tree tree3)
        (expected
         '("Let us go then, you and I," "In the room the women come and go")
         ))
    (run-test
     (node-join
      (node-closure (node-typeof? 'stanza))
      (node-reduce
       (select-kids (node-typeof? 'line)) (node-pos 1))
      (select-kids (node-typeof? '*text*)))
     tree expected)
    (run-test (sxpath '(// stanza (line 1) *text*)) tree expected)
    )
  )


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

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

;;;
;;; miscellaneous
;;;

(define exception:immutable-string
  (cons 'misc-error "^string is read-only"))

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

(define (symbol-length s)
  (string-length (symbol->string s)))

;;
;; symbol internals
;;

(with-test-prefix "symbol internals"

  (pass-if "length of new symbol same as stringbuf"
    (let ((s 'def))
      (= (symbol-length s) (assq-ref (%symbol-dump s) 'stringbuf-length))))

  (pass-if "contents of new symbol same as stringbuf"
    (let ((s 'ghi))
      (string=? (symbol->string s)
                (assq-ref (%symbol-dump s) 'stringbuf-chars))))

  (with-test-prefix "hashes"

    (pass-if "equal symbols have equal hashes"
      (let ((s1 'mux)
            (s2 'mux))
        (= (assq-ref (%symbol-dump s1) 'hash)
           (assq-ref (%symbol-dump s2) 'hash))))

    (pass-if "different symbols have different hashes"
      (let ((s1 'mux)
            (s2 'muy))
        (not (= (assq-ref (%symbol-dump s1) 'hash)
                (assq-ref (%symbol-dump s2) 'hash))))))

  (with-test-prefix "encodings"

    (pass-if "the null symbol is Latin-1 encoded"
      (let ((s '#{}#))
        (not (assq-ref (%symbol-dump s) 'stringbuf-wide))))

    (pass-if "ASCII symbols are Latin-1 encoded"
      (let ((s 'jkl))
        (not (assq-ref (%symbol-dump s) 'stringbuf-wide))))

    (pass-if "Latin-1 symbols are Latin-1 encoded"
      (let ((s (string->symbol "\xC0\xC1\xC2")))
        (not (assq-ref (%symbol-dump s) 'stringbuf-wide))))

    (pass-if "BMP symbols are UCS-4 encoded"
      (let ((s (string->symbol "\u0100\u0101\x0102")))
        (assq-ref (%symbol-dump s) 'stringbuf-wide)))

    (pass-if "SMP symbols are UCS-4 encoded"
      (let ((s (string->symbol "\U010300\u010301\x010302")))
        (assq-ref (%symbol-dump s) 'stringbuf-wide)))))

;;;
;;; symbol?
;;;

(with-test-prefix "symbol?"

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

  (pass-if "string"
    (not (symbol? "foo")))

  (pass-if "symbol"
    (symbol? 'foo)))

;;;
;;; wide symbols
;;;

(with-test-prefix "BMP symbols"

  (pass-if "BMP symbol's string"
    (and (= 4 (string-length "abc\u0100"))
         (string=? "abc\u0100"
                   (symbol->string (string->symbol "abc\u0100"))))))

;;;
;;; symbol->string
;;;

(with-test-prefix "symbol->string"

  (pass-if-exception "result is an immutable string"
    exception:immutable-string
    (string-set! (symbol->string 'abc) 1 #\space)))

;;;
;;; gensym
;;;

(with-test-prefix "gensym"

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

  (pass-if "produces a symbol"
    (symbol? (gensym)))

  (pass-if "produces a fresh symbol"
    (not (eq? (gensym) (gensym))))

  (pass-if "accepts a string prefix"
    (symbol? (gensym "foo")))

  (pass-if-exception "does not accept a symbol prefix"
    exception:wrong-type-arg
    (gensym 'foo))

  (pass-if "accepts long prefices"
    (symbol? (gensym (make-string 4000 #\!))))

  (pass-if "accepts embedded NULs"
    (> (string-length (symbol->string (gensym "foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0"))) 6)))


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

;; These tests are in a module so that the syntax transformer does not
;; affect code outside of this file.
;;
(define-module (test-suite test-syncase)
  #:use-module (test-suite lib)
  #:use-module (system base compile)
  #:use-module ((srfi srfi-1) :select (member)))

(define-syntax plus
  (syntax-rules ()
    ((plus x ...) (+ x ...))))

(pass-if "basic syncase macro"
  (= (plus 1 2 3) (+ 1 2 3)))

(pass-if "@ works with syncase"
  (eq? run-test (@ (test-suite lib) run-test)))

(define-syntax string-let
  (lambda (stx)
    (syntax-case stx ()
      ((_ id body ...)
       #`(let ((id #,(symbol->string
                      (syntax->datum #'id))))
           body ...)))))

(pass-if "macro using quasisyntax"
  (equal? (string-let foo (list foo foo))
          '("foo" "foo")))

(define-syntax string-case
  (syntax-rules (else)
    ((string-case expr ((string ...) clause-body ...) ... (else else-body ...))
     (let ((value expr))
       (cond ((member value '(string ...) string=?)
              clause-body ...)
             ...
             (else
              else-body ...))))
    ((string-case expr ((string ...) clause-body ...) ...)
     (let ((value expr))
       (cond ((member value '(string ...) string=?)
              clause-body ...)
             ...)))))

(define-syntax alist
  (syntax-rules (tail)
    ((alist ((key val) ... (tail expr)))
     (cons* '(key . val) ... expr))
    ((alist ((key val) ...))
     (list '(key . val) ...))))

(with-test-prefix "tail patterns"
  (with-test-prefix "at the outermost level"
    (pass-if "non-tail invocation"
      (equal? (string-case "foo" (("foo") 'foo))
              'foo))
    (pass-if "tail invocation"
      (equal? (string-case "foo" (("bar") 'bar) (else 'else))
              'else)))
  (with-test-prefix "at a nested level"
    (pass-if "non-tail invocation"
      (equal? (alist ((a 1) (b 2) (c 3)))
              '((a . 1) (b . 2) (c . 3))))
    (pass-if "tail invocation"
      (equal? (alist ((foo 42) (tail '((bar . 66)))))
              '((foo . 42) (bar . 66))))))

(with-test-prefix "serializable labels and marks"
  (compile '(begin
              (define-syntax duplicate-macro
                (syntax-rules ()
                  ((_ new-name old-name)
                   (define-syntax new-name
                     (syntax-rules ()
                       ((_ . vals)
                        (letrec-syntax ((apply (syntax-rules ()
                                                 ((_ macro args)
                                                  (macro . args)))))
                          (apply old-name vals))))))))

              (define-syntax kwote
                (syntax-rules ()
                  ((_ arg1) 'arg1)))

              (duplicate-macro kwote* kwote))
           #:env (current-module))
  (pass-if "compiled macro-generating macro works"
    (eq? (eval '(kwote* foo) (current-module))
         'foo)))

(with-test-prefix "changes to expansion environment"
  (pass-if "expander detects changes to current-module with @@"
    (compile '(begin
                (define-module (new-module))
                (@@ (new-module)
                    (define-syntax new-module-macro
                      (lambda (stx)
                        (syntax-case stx ()
                          ((_ arg) (syntax arg))))))
                (@@ (new-module)
                    (new-module-macro #t)))
             #:env (current-module))))

(define-module (test-suite test-syncase-2)
  #:export (make-the-macro))

(define (hello)
  'hello)

(define-syntax make-the-macro
  (syntax-rules ()
    ((_ name)
     (define-syntax name
       (syntax-rules ()
         ((_) (hello)))))))

(define-module (test-suite test-syncase)) ;; back to main module
(use-modules (test-suite test-syncase-2))

(make-the-macro foo)

(with-test-prefix "macro-generating macro"
  (pass-if "module hygiene"
    (eq? (foo) 'hello)))

(pass-if "_ is a placeholder"
  (equal? (eval '(begin
                   (define-syntax ciao
                     (lambda (stx)
                       (syntax-case stx ()
                         ((_ _)
                          "ciao"))))
                   (ciao 1))
                (current-module))
          "ciao"))

(define qux 30)

(with-test-prefix "identifier-syntax"

  (pass-if "global reference"
    (let-syntax ((baz (identifier-syntax qux)))
      (equal? baz qux)))

  (pass-if "lexical hygienic reference"
    (let-syntax ((baz (identifier-syntax qux)))
      (let ((qux 20))
        (equal? (+ baz qux)
                50))))

  (pass-if "lexical hygienic reference (bound)"
    (let ((qux 20))
      (let-syntax ((baz (identifier-syntax qux)))
        (equal? (+ baz qux)
                40))))

  (pass-if "global reference (settable)"
    (let-syntax ((baz (identifier-syntax
                       (id qux)
                       ((set! id expr) (set! qux expr)))))
      (equal? baz qux)))

  (pass-if "lexical hygienic reference (settable)"
    (let-syntax ((baz (identifier-syntax
                       (id qux)
                       ((set! id expr) (set! qux expr)))))
      (let ((qux 20))
        (equal? (+ baz qux)
                50))))

  (pass-if "lexical hygienic reference (bound, settable)"
    (let ((qux 20))
      (let-syntax ((baz (identifier-syntax
                         (id qux)
                         ((set! id expr) (set! qux expr)))))
        (equal? (+ baz qux)
                40))))

  (pass-if "global set!"
    (let-syntax ((baz (identifier-syntax
                       (id qux)
                       ((set! id expr) (set! qux expr)))))
      (set! baz 10)
      (equal? (+ baz qux) 20)))

  (pass-if "lexical hygienic set!"
    (let-syntax ((baz (identifier-syntax
                       (id qux)
                       ((set! id expr) (set! qux expr)))))
      (and (let ((qux 20))
             (set! baz 5)
             (equal? (+ baz qux)
                     25))
           (equal? qux 5))))

  (pass-if "lexical hygienic set! (bound)"
    (let ((qux 20))
      (let-syntax ((baz (identifier-syntax
                         (id qux)
                         ((set! id expr) (set! qux expr)))))
        (set! baz 50)
        (equal? (+ baz qux)
                100)))))


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

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

(define exception:generic-syncase-error
  (cons 'syntax-error "source expression failed to match"))
(define exception:unexpected-syntax
  (cons 'syntax-error "unexpected syntax"))

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

(define exception:missing/extra-expr
  (cons 'syntax-error "Missing or extra expression"))
(define exception:missing-expr
  (cons 'syntax-error "Missing expression"))
(define exception:missing-body-expr
  (cons 'syntax-error "no expressions in body"))
(define exception:extra-expr
  (cons 'syntax-error "Extra expression"))
(define exception:illegal-empty-combination
  (cons 'syntax-error "Illegal empty combination"))

(define exception:bad-lambda
  '(syntax-error . "bad lambda"))
(define exception:bad-let
  '(syntax-error . "bad let "))
(define exception:bad-letrec
  '(syntax-error . "bad letrec "))
(define exception:bad-letrec*
  '(syntax-error . "bad letrec\\* "))
(define exception:bad-set!
  '(syntax-error . "bad set!"))
(define exception:bad-quote
  '(syntax-error . "quote: bad syntax"))
(define exception:bad-bindings
  (cons 'syntax-error "Bad bindings"))
(define exception:bad-binding
  (cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
  (cons 'syntax-error "duplicate bound variable"))
(define exception:bad-body
  (cons 'misc-error "^bad body"))
(define exception:bad-formals
  '(syntax-error . "invalid argument list"))
(define exception:bad-formal
  (cons 'syntax-error "Bad formal"))
(define exception:duplicate-formals
  (cons 'syntax-error "duplicate identifier in argument list"))

(define exception:missing-clauses
  (cons 'syntax-error "Missing clauses"))
(define exception:misplaced-else-clause
  (cons 'syntax-error "Misplaced else clause"))
(define exception:bad-case-clause
  (cons 'syntax-error "Bad case clause"))
(define exception:bad-case-labels
  (cons 'syntax-error "Bad case labels"))
(define exception:bad-cond-clause
  (cons 'syntax-error "Bad cond clause"))

(define exception:too-many-args
  (cons 'syntax-error "too many arguments"))

(with-test-prefix "expressions"

  (with-test-prefix "Bad argument list"

    (pass-if-exception "improper argument list of length 1"
      exception:generic-syncase-error
      (eval '(let ((foo (lambda (x y) #t)))
	       (foo . 1))
	    (interaction-environment)))

    (pass-if-exception "improper argument list of length 2"
      exception:generic-syncase-error
      (eval '(let ((foo (lambda (x y) #t)))
	       (foo 1 . 2))
	    (interaction-environment))))

  (with-test-prefix "missing or extra expression"

    ;; R5RS says:
    ;; *Note:* In many dialects of Lisp, the empty combination, (),
    ;; is a legitimate expression.  In Scheme, combinations must
    ;; have at least one subexpression, so () is not a syntactically
    ;; valid expression.

    ;; Fixed on 2001-3-3
    (pass-if-exception "empty parentheses \"()\""
      exception:unexpected-syntax
      (eval '()
	    (interaction-environment)))))

(with-test-prefix "quote"
  #t)

(with-test-prefix "quasiquote"

  (with-test-prefix "unquote"

    (pass-if "repeated execution"
      (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
	(and (equal? (foo) '(1)) (equal? (foo) '(2))))))

  (with-test-prefix "unquote-splicing"

    (pass-if-exception "extra arguments"
      '(syntax-error . "unquote-splicing takes exactly one argument")
      (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
            (interaction-environment)))))

(with-test-prefix "begin"

  (pass-if "legal (begin)"
    (eval '(begin (begin) #t) (interaction-environment)))

  (pass-if-exception "illegal (begin)"
    exception:generic-syncase-error
    (eval '(begin (if #t (begin)) #t) (interaction-environment))))

(define-syntax matches?
  (syntax-rules (<>)
    ((_ (op arg ...) pat)   (let ((x (op arg ...)))
                              (matches? x pat)))
    ((_ x ())               (null? x))
    ((_ x (a . b))          (and (pair? x)
                                 (matches? (car x) a)
                                 (matches? (cdr x) b)))
    ((_ x <>)                #t)
    ((_ x pat)              (equal? x 'pat))))

(with-test-prefix "lambda"

  (with-test-prefix "bad formals"

    (pass-if-exception "(lambda)"
      exception:bad-lambda
      (eval '(lambda)
	    (interaction-environment)))

    (pass-if-exception "(lambda . \"foo\")"
      exception:bad-lambda
      (eval '(lambda . "foo")
	    (interaction-environment)))

    (pass-if-exception "(lambda \"foo\")"
      exception:bad-lambda
      (eval '(lambda "foo")
	    (interaction-environment)))

    (pass-if-exception "(lambda \"foo\" #f)"
      exception:bad-formals
      (eval '(lambda "foo" #f)
	    (interaction-environment)))

    (pass-if-exception "(lambda (x 1) 2)"
      exception:bad-formals
      (eval '(lambda (x 1) 2)
	    (interaction-environment)))

    (pass-if-exception "(lambda (1 x) 2)"
      exception:bad-formals
      (eval '(lambda (1 x) 2)
	    (interaction-environment)))

    (pass-if-exception "(lambda (x \"a\") 2)"
      exception:bad-formals
      (eval '(lambda (x "a") 2)
	    (interaction-environment)))

    (pass-if-exception "(lambda (\"a\" x) 2)"
      exception:bad-formals
      (eval '(lambda ("a" x) 2)
	    (interaction-environment))))

  (with-test-prefix "duplicate formals"

    ;; Fixed on 2001-3-3
    (pass-if-exception "(lambda (x x) 1)"
      exception:duplicate-formals
      (eval '(lambda (x x) 1)
	    (interaction-environment)))

    ;; Fixed on 2001-3-3
    (pass-if-exception "(lambda (x x x) 1)"
      exception:duplicate-formals
      (eval '(lambda (x x x) 1)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(lambda ())"
      exception:bad-lambda
      (eval '(lambda ())
	    (interaction-environment)))))

(with-test-prefix "let"

  (with-test-prefix "bindings"

    (pass-if-exception "late binding"
      exception:unbound-var
      (let ((x 1) (y x)) y)))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let)"
      exception:bad-let
      (eval '(let)
	    (interaction-environment)))

    (pass-if-exception "(let 1)"
      exception:bad-let
      (eval '(let 1)
	    (interaction-environment)))

    (pass-if-exception "(let (x))"
      exception:bad-let
      (eval '(let (x))
	    (interaction-environment)))

    (pass-if-exception "(let ((x)))"
      exception:bad-let
      (eval '(let ((x)))
	    (interaction-environment)))

    (pass-if-exception "(let (x) 1)"
      exception:bad-let
      (eval '(let (x) 1)
	    (interaction-environment)))

    (pass-if-exception "(let ((x)) 3)"
      exception:bad-let
      (eval '(let ((x)) 3)
	    (interaction-environment)))

    (pass-if-exception "(let ((x 1) y) x)"
      exception:bad-let
      (eval '(let ((x 1) y) x)
	    (interaction-environment)))

    (pass-if-exception "(let ((1 2)) 3)"
      exception:bad-let
      (eval '(let ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "duplicate bindings"

    (pass-if-exception "(let ((x 1) (x 2)) x)"
      exception:duplicate-binding
      (eval '(let ((x 1) (x 2)) x)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(let ())"
      exception:bad-let
      (eval '(let ())
	    (interaction-environment)))

    (pass-if-exception "(let ((x 1)))"
      exception:bad-let
      (eval '(let ((x 1)))
	    (interaction-environment)))))

(with-test-prefix "named let"

  (with-test-prefix "initializers"

    (pass-if "evaluated in outer environment"
      (let ((f -))
	(eqv? (let f ((n (f 1))) n) -1))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let x (y))"
      exception:bad-let
      (eval '(let x (y))
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(let x ())"
      exception:bad-let
      (eval '(let x ())
	    (interaction-environment)))

    (pass-if-exception "(let x ((y 1)))"
      exception:bad-let
      (eval '(let x ((y 1)))
	    (interaction-environment)))))

(with-test-prefix "let*"

  (with-test-prefix "bindings"

    (pass-if "(let* ((x 1) (x 2)) ...)"
      (let* ((x 1) (x 2))
	(= x 2)))

    (pass-if "(let* ((x 1) (x x)) ...)"
      (let* ((x 1) (x x))
	(= x 1)))

    (pass-if "(let ((x 1) (y 2)) (let* () ...))"
      (let ((x 1) (y 2))
        (let* ()
          (and (= x 1) (= y 2))))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let*)"
      exception:generic-syncase-error
      (eval '(let*)
	    (interaction-environment)))

    (pass-if-exception "(let* 1)"
      exception:generic-syncase-error
      (eval '(let* 1)
	    (interaction-environment)))

    (pass-if-exception "(let* (x))"
      exception:generic-syncase-error
      (eval '(let* (x))
	    (interaction-environment)))

    (pass-if-exception "(let* (x) 1)"
      exception:generic-syncase-error
      (eval '(let* (x) 1)
	    (interaction-environment)))

    (pass-if-exception "(let* ((x)) 3)"
      exception:generic-syncase-error
      (eval '(let* ((x)) 3)
	    (interaction-environment)))

    (pass-if-exception "(let* ((x 1) y) x)"
      exception:generic-syncase-error
      (eval '(let* ((x 1) y) x)
	    (interaction-environment)))

    (pass-if-exception "(let* x ())"
      exception:generic-syncase-error
      (eval '(let* x ())
	    (interaction-environment)))

    (pass-if-exception "(let* x (y))"
      exception:generic-syncase-error
      (eval '(let* x (y))
	    (interaction-environment)))

    (pass-if-exception "(let* ((1 2)) 3)"
      exception:generic-syncase-error
      (eval '(let* ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(let* ())"
      exception:generic-syncase-error
      (eval '(let* ())
	    (interaction-environment)))

    (pass-if-exception "(let* ((x 1)))"
      exception:generic-syncase-error
      (eval '(let* ((x 1)))
	    (interaction-environment)))))

(with-test-prefix "letrec"

  (with-test-prefix "bindings"

    (pass-if-exception "initial bindings are undefined"
      exception:used-before-defined
      (let ((x 1))
        ;; FIXME: the memoizer does initialize the var to undefined, but
        ;; the Scheme evaluator has no way of checking what's an
        ;; undefined value. Not sure how to do this.
        (throw 'unresolved)
	(letrec ((x 1) (y x)) y))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(letrec)"
      exception:bad-letrec
      (eval '(letrec)
	    (interaction-environment)))

    (pass-if-exception "(letrec 1)"
      exception:bad-letrec
      (eval '(letrec 1)
	    (interaction-environment)))

    (pass-if-exception "(letrec (x))"
      exception:bad-letrec
      (eval '(letrec (x))
	    (interaction-environment)))

    (pass-if-exception "(letrec (x) 1)"
      exception:bad-letrec
      (eval '(letrec (x) 1)
	    (interaction-environment)))

    (pass-if-exception "(letrec ((x)) 3)"
      exception:bad-letrec
      (eval '(letrec ((x)) 3)
	    (interaction-environment)))

    (pass-if-exception "(letrec ((x 1) y) x)"
      exception:bad-letrec
      (eval '(letrec ((x 1) y) x)
	    (interaction-environment)))

    (pass-if-exception "(letrec x ())"
      exception:bad-letrec
      (eval '(letrec x ())
	    (interaction-environment)))

    (pass-if-exception "(letrec x (y))"
      exception:bad-letrec
      (eval '(letrec x (y))
	    (interaction-environment)))

    (pass-if-exception "(letrec ((1 2)) 3)"
      exception:bad-letrec
      (eval '(letrec ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "duplicate bindings"

    (pass-if-exception "(letrec ((x 1) (x 2)) x)"
      exception:duplicate-binding
      (eval '(letrec ((x 1) (x 2)) x)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(letrec ())"
      exception:bad-letrec
      (eval '(letrec ())
	    (interaction-environment)))

    (pass-if-exception "(letrec ((x 1)))"
      exception:bad-letrec
      (eval '(letrec ((x 1)))
	    (interaction-environment)))))

(with-test-prefix "letrec*"

  (with-test-prefix "bindings"

    (pass-if-exception "initial bindings are undefined"
      exception:used-before-defined
      (begin
        ;; FIXME: the memoizer does initialize the var to undefined, but
        ;; the Scheme evaluator has no way of checking what's an
        ;; undefined value. Not sure how to do this.
        (throw 'unresolved)
	(letrec* ((x y) (y 1)) y))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(letrec*)"
      exception:bad-letrec*
      (eval '(letrec*)
	    (interaction-environment)))

    (pass-if-exception "(letrec* 1)"
      exception:bad-letrec*
      (eval '(letrec* 1)
	    (interaction-environment)))

    (pass-if-exception "(letrec* (x))"
      exception:bad-letrec*
      (eval '(letrec* (x))
	    (interaction-environment)))

    (pass-if-exception "(letrec* (x) 1)"
      exception:bad-letrec*
      (eval '(letrec* (x) 1)
	    (interaction-environment)))

    (pass-if-exception "(letrec* ((x)) 3)"
      exception:bad-letrec*
      (eval '(letrec* ((x)) 3)
	    (interaction-environment)))

    (pass-if-exception "(letrec* ((x 1) y) x)"
      exception:bad-letrec*
      (eval '(letrec* ((x 1) y) x)
	    (interaction-environment)))

    (pass-if-exception "(letrec* x ())"
      exception:bad-letrec*
      (eval '(letrec* x ())
	    (interaction-environment)))

    (pass-if-exception "(letrec* x (y))"
      exception:bad-letrec*
      (eval '(letrec* x (y))
	    (interaction-environment)))

    (pass-if-exception "(letrec* ((1 2)) 3)"
      exception:bad-letrec*
      (eval '(letrec* ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "duplicate bindings"

    (pass-if-exception "(letrec* ((x 1) (x 2)) x)"
      exception:duplicate-binding
      (eval '(letrec* ((x 1) (x 2)) x)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(letrec* ())"
      exception:bad-letrec*
      (eval '(letrec* ())
	    (interaction-environment)))

    (pass-if-exception "(letrec* ((x 1)))"
      exception:bad-letrec*
      (eval '(letrec* ((x 1)))
	    (interaction-environment))))

  (with-test-prefix "referencing previous values"
    (pass-if (equal? (letrec ((a (cons 'foo 'bar))
                              (b a))
                       b)
                     '(foo . bar)))
    (pass-if (equal? (let ()
                       (define a (cons 'foo 'bar))
                       (define b a)
                       b)
                     '(foo . bar)))))

(with-test-prefix "if"

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(if)"
      exception:generic-syncase-error
      (eval '(if)
	    (interaction-environment)))

    (pass-if-exception "(if 1 2 3 4)"
      exception:generic-syncase-error
      (eval '(if 1 2 3 4)
	    (interaction-environment)))))

(with-test-prefix "cond"

  (with-test-prefix "cond is hygienic"

    (pass-if "bound 'else is handled correctly"
      (eq? (let ((else 'ok)) (cond (else))) 'ok))

    (with-test-prefix "bound '=> is handled correctly"

      (pass-if "#t => 'ok"
        (let ((=> 'foo))
          (eq? (cond (#t => 'ok)) 'ok)))

      (pass-if "else =>"
        (let ((=> 'foo))
          (eq? (cond (else =>)) 'foo)))

      (pass-if "else => identity"
        (let ((=> 'foo))
          (eq? (cond (else => identity)) identity)))))

  (with-test-prefix "SRFI-61"

    (pass-if "always available"
      (cond-expand (srfi-61 #t) (else #f)))

    (pass-if "single value consequent"
      (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))

    (pass-if "single value alternate"
      (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))

    (pass-if-exception "doesn't affect standard =>"
      exception:wrong-num-args
      (cond ((values 1 2) => (lambda (x y) #t))))

    (pass-if "multiple values consequent"
      (equal? '(2 1) (cond ((values 1 2)
			    (lambda (one two)
			      (and (= 1 one) (= 2 two))) =>
			    (lambda (one two) (list two one)))
			   (else #f))))

    (pass-if "multiple values alternate"
      (eq? 'ok (cond ((values 2 3 4)
		      (lambda args (equal? '(1 2 3) args)) =>
		      (lambda (x y z) #f))
		     (else 'ok))))

    (pass-if "zero values"
      (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
		     (else #f))))

    (pass-if "bound => is handled correctly"
      (let ((=> 'ok))
	(eq? 'ok (cond (#t identity =>) (else #f)))))

    (pass-if-exception "missing recipient"
      '(syntax-error . "cond: wrong number of receiver expressions")
      (cond (#t identity =>)))

    (pass-if-exception "extra recipient"
      '(syntax-error . "cond: wrong number of receiver expressions")
      (cond (#t identity => identity identity))))

  (with-test-prefix "bad or missing clauses"

    (pass-if-exception "(cond)"
      exception:generic-syncase-error
      (eval '(cond)
	    (interaction-environment)))

    (pass-if-exception "(cond #t)"
      exception:generic-syncase-error
      (eval '(cond #t)
	    (interaction-environment)))

    (pass-if-exception "(cond 1)"
      exception:generic-syncase-error
      (eval '(cond 1)
	    (interaction-environment)))

    (pass-if-exception "(cond 1 2)"
      exception:generic-syncase-error
      (eval '(cond 1 2)
	    (interaction-environment)))

    (pass-if-exception "(cond 1 2 3)"
      exception:generic-syncase-error
      (eval '(cond 1 2 3)
	    (interaction-environment)))

    (pass-if-exception "(cond 1 2 3 4)"
      exception:generic-syncase-error
      (eval '(cond 1 2 3 4)
	    (interaction-environment)))

    (pass-if-exception "(cond ())"
      exception:generic-syncase-error
      (eval '(cond ())
	    (interaction-environment)))

    (pass-if-exception "(cond () 1)"
      exception:generic-syncase-error
      (eval '(cond () 1)
	    (interaction-environment)))

    (pass-if-exception "(cond (1) 1)"
      exception:generic-syncase-error
      (eval '(cond (1) 1)
	    (interaction-environment))))

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

    (pass-if-exception "=> (lambda (x y) #t)"
      exception:wrong-num-args
      (cond (1 => (lambda (x y) #t))))))

(with-test-prefix "case"

  (pass-if "clause with empty labels list"
    (case 1 (() #f) (else #t)))

  (with-test-prefix "case is hygienic"

    (pass-if-exception "bound 'else is handled correctly"
      exception:generic-syncase-error
      (eval '(let ((else #f)) (case 1 (else #f)))
            (interaction-environment))))

  (with-test-prefix "bad or missing clauses"

    (pass-if-exception "(case)"
      exception:generic-syncase-error
      (eval '(case)
	    (interaction-environment)))

    (pass-if-exception "(case . \"foo\")"
      exception:generic-syncase-error
      (eval '(case . "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1)"
      exception:generic-syncase-error
      (eval '(case 1)
	    (interaction-environment)))

    (pass-if-exception "(case 1 . \"foo\")"
      exception:generic-syncase-error
      (eval '(case 1 . "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1 \"foo\")"
      exception:generic-syncase-error
      (eval '(case 1 "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1 ())"
      exception:generic-syncase-error
      (eval '(case 1 ())
	    (interaction-environment)))

    (pass-if-exception "(case 1 (\"foo\"))"
      exception:generic-syncase-error
      (eval '(case 1 ("foo"))
	    (interaction-environment)))

    (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
      exception:generic-syncase-error
      (eval '(case 1 ("foo" "bar"))
	    (interaction-environment)))

    (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
      exception:generic-syncase-error
      (eval '(case 1 ((2) "bar") . "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1 ((2) \"bar\") (else))"
      exception:generic-syncase-error
      (eval '(case 1 ((2) "bar") (else))
	    (interaction-environment)))

    (pass-if-exception "(case 1 (else #f) . \"foo\")"
      exception:generic-syncase-error
      (eval '(case 1 (else #f) . "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1 (else #f) ((1) #t))"
      exception:generic-syncase-error
      (eval '(case 1 (else #f) ((1) #t))
	    (interaction-environment)))))

(with-test-prefix "top-level define"

  (pass-if "redefinition"
    (let ((m (make-module)))
      (beautify-user-module! m)

      ;; The previous value of `round' must still be visible at the time the
      ;; new `round' is defined.  According to R5RS (Section 5.2.1), `define'
      ;; should behave like `set!' in this case (except that in the case of
      ;; Guile, we respect module boundaries).
      (eval '(define round round) m)
      (eq? (module-ref m 'round) round)))

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(define)"
      exception:generic-syncase-error
      (eval '(define)
	    (interaction-environment)))))

(with-test-prefix "internal define"

  (pass-if "internal defines become letrec"
    (eval '(let ((a identity) (b identity) (c identity))
             (define (a x) (if (= x 0) 'a (b (- x 1))))
             (define (b x) (if (= x 0) 'b (c (- x 1))))
             (define (c x) (if (= x 0) 'c (a (- x 1))))
             (and (eq? 'a (a 0) (a 3))
                  (eq? 'b (a 1) (a 4))
                  (eq? 'c (a 2) (a 5))))
          (interaction-environment)))

  (pass-if "binding is created before expression is evaluated"
    ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
    (= (eval '(let ()
                (define foo
                  (begin
                    (set! foo 1)
                    (+ foo 1)))
                foo)
             (interaction-environment))
       2))

  (pass-if "internal defines with begin"
    (false-if-exception
     (eval '(let ((a identity) (b identity) (c identity))
              (define (a x) (if (= x 0) 'a (b (- x 1))))
              (begin
                (define (b x) (if (= x 0) 'b (c (- x 1)))))
              (define (c x) (if (= x 0) 'c (a (- x 1))))
              (and (eq? 'a (a 0) (a 3))
                   (eq? 'b (a 1) (a 4))
                   (eq? 'c (a 2) (a 5))))
           (interaction-environment))))

  (pass-if "internal defines with empty begin"
    (false-if-exception
     (eval '(let ((a identity) (b identity) (c identity))
              (define (a x) (if (= x 0) 'a (b (- x 1))))
              (begin)
              (define (b x) (if (= x 0) 'b (c (- x 1))))
              (define (c x) (if (= x 0) 'c (a (- x 1))))
              (and (eq? 'a (a 0) (a 3))
                   (eq? 'b (a 1) (a 4))
                   (eq? 'c (a 2) (a 5))))
           (interaction-environment))))

  (pass-if "internal defines with macro application"
    (false-if-exception
     (eval '(begin
              (defmacro my-define forms
                (cons 'define forms))
              (let ((a identity) (b identity) (c identity))
                (define (a x) (if (= x 0) 'a (b (- x 1))))
                (my-define (b x) (if (= x 0) 'b (c (- x 1))))
                (define (c x) (if (= x 0) 'c (a (- x 1))))
                (and (eq? 'a (a 0) (a 3))
                     (eq? 'b (a 1) (a 4))
                     (eq? 'c (a 2) (a 5)))))
           (interaction-environment))))

  (pass-if-exception "missing body expression"
    exception:missing-body-expr
    (eval '(let () (define x #t))
          (interaction-environment))))

(with-test-prefix "set!"

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(set!)"
      exception:bad-set!
      (eval '(set!)
	    (interaction-environment)))

    (pass-if-exception "(set! 1)"
      exception:bad-set!
      (eval '(set! 1)
	    (interaction-environment)))

    (pass-if-exception "(set! 1 2 3)"
      exception:bad-set!
      (eval '(set! 1 2 3)
	    (interaction-environment))))

  (with-test-prefix "bad variable"

    (pass-if-exception "(set! \"\" #t)"
      exception:bad-set!
      (eval '(set! "" #t)
	    (interaction-environment)))

    (pass-if-exception "(set! 1 #t)"
      exception:bad-set!
      (eval '(set! 1 #t)
	    (interaction-environment)))

    (pass-if-exception "(set! #t #f)"
      exception:bad-set!
      (eval '(set! #t #f)
	    (interaction-environment)))

    (pass-if-exception "(set! #f #t)"
      exception:bad-set!
      (eval '(set! #f #t)
	    (interaction-environment)))

    (pass-if-exception "(set! #\\space #f)"
      exception:bad-set!
      (eval '(set! #\space #f)
	    (interaction-environment)))))

(with-test-prefix "quote"

  (with-test-prefix "missing or extra expression"

    (pass-if-exception "(quote)"
      exception:bad-quote
      (eval '(quote)
	    (interaction-environment)))

    (pass-if-exception "(quote a b)"
      exception:bad-quote
      (eval '(quote a b)
	    (interaction-environment)))))

(with-test-prefix "while"

  (define (unreachable)
    (error "unreachable code has been reached!"))

  ;; Return a new procedure COND which when called (COND) will return #t the
  ;; first N times, then #f, then any further call is an error.  N=0 is
  ;; allowed, in which case #f is returned by the first call.
  (define (make-iterations-cond n)
    (lambda ()
      (cond ((not n)
	     (error "oops, condition re-tested after giving false"))
	    ((= 0 n)
	     (set! n #f)
	     #f)
	    (else
	     (set! n (1- n))
	     #t))))

  (pass-if-exception "too few args" exception:generic-syncase-error
    (eval '(while) (interaction-environment)))

  (with-test-prefix "empty body"
    (do ((n 0 (1+ n)))
	((> n 5))
      (pass-if n
	(eval `(letrec ((make-iterations-cond
                         (lambda (n)
                           (lambda ()
                             (cond ((not n)
                                    (error "oops, condition re-tested after giving false"))
                                   ((= 0 n)
                                    (set! n #f)
                                    #f)
                                   (else
                                    (set! n (1- n))
                                    #t))))))
                 (let ((cond (make-iterations-cond ,n)))
                   (while (cond))
                   #t))
              (interaction-environment)))))

  (pass-if "initially false"
    (while #f
      (unreachable))
    #t)

  (with-test-prefix "iterations"
    (do ((n 0 (1+ n)))
	((> n 5))
      (pass-if n
	(let ((cond (make-iterations-cond n))
	      (i    0))
	  (while (cond)
	    (set! i (1+ i)))
	  (= i n)))))

  (with-test-prefix "break"

    (pass-if-exception "too many args" exception:too-many-args
      (eval '(while #t
               (break 1))
            (interaction-environment)))

    (with-test-prefix "from cond"
      (pass-if "first"
	(while (begin
		 (break)
		 (unreachable))
	  (unreachable))
	#t)

      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (if (cond)
		       #t
		       (begin
			 (break)
			 (unreachable)))
	      (set! i (1+ i)))
	    (= i n)))))

    (with-test-prefix "from body"
      (pass-if "first"
	(while #t
	  (break)
	  (unreachable))
	#t)

      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while #t
	      (if (not (cond))
		  (begin
		    (break)
		    (unreachable)))
	      (set! i (1+ i)))
	    (= i n)))))

    (pass-if "from nested"
      (while #t
	(let ((outer-break break))
	  (while #t
	    (outer-break)
	    (unreachable)))
	(unreachable))
      #t)

    (pass-if "from recursive"
      (let ((outer-break #f))
	(define (r n)
	  (while #t
	    (if (eq? n 'outer)
		(begin
		  (set! outer-break break)
		  (r 'inner))
		(begin
		  (outer-break)
		  (unreachable))))
	  (if (eq? n 'inner)
	      (error "broke only from inner loop")))
	(r 'outer))
      #t))

  (with-test-prefix "continue"

    (pass-if-exception "too many args" exception:too-many-args
      (eval '(while #t
               (continue 1))
            (interaction-environment)))

    (with-test-prefix "from cond"
      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (if (cond)
		       (begin
			 (set! i (1+ i))
			 (continue)
			 (unreachable))
		       #f)
	      (unreachable))
	    (= i n)))))

    (with-test-prefix "from body"
      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (cond)
	      (set! i (1+ i))
	      (continue)
	      (unreachable))
	    (= i n)))))

    (pass-if "from nested"
      (let ((cond (make-iterations-cond 3)))
	(while (cond)
	  (let ((outer-continue continue))
	    (while #t
	      (outer-continue)
	      (unreachable)))))
      #t)

    (pass-if "from recursive"
      (let ((outer-continue #f))
	(define (r n)
	  (let ((cond  (make-iterations-cond 3))
		(first #t))
	    (while (begin
		     (if (and (not first)
			      (eq? n 'inner))
			 (error "continued only to inner loop"))
		     (cond))
	      (set! first #f)
	      (if (eq? n 'outer)
		  (begin
		    (set! outer-continue continue)
		    (r 'inner))
		  (begin
		    (outer-continue)
		    (unreachable))))))
	(r 'outer))
      #t)))


code:
;;;; texinfo.docbook.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 docbook).
;;
;;; Code:

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

(with-test-prefix "test-flatten"
  (pass-if (equal?
            (sdocbook-flatten '(refsect1 (refsect2 (para "foo"))))
            '((refsect1) (refsect2) (para "foo")))))