code:
;;; common-test.scm --
;;;

;; Slightly modified for Guile by Ludovic Courtès <ludo@gnu.org>, 2010.

(use-modules (system base lalr)
             (ice-9 pretty-print))

(define *error* '())

(define-syntax when
  (syntax-rules ()
    ((_ ?expr ?body ...)
     (if ?expr
	 (let () ?body ...)
       #f))))

(define-syntax check
  (syntax-rules (=>)
    ((_ ?expr => ?expected-result)
     (check ?expr (=> equal?) ?expected-result))

    ((_ ?expr (=> ?equal) ?expected-result)
     (let ((result	?expr)
	   (expected	?expected-result))
       (set! *error* '())
       (when (not (?equal result expected))
	 (display "Failed test: \n")
	 (pretty-print (quote ?expr))(newline)
	 (display "\tresult was: ")
	 (pretty-print result)(newline)
	 (display "\texpected: ")
	 (pretty-print expected)(newline)
         (exit 1))))))

;;; --------------------------------------------------------------------

(define (display-result v)
  (if v
      (begin
        (display "==> ")
        (display v)
        (newline))))

(define eoi-token
  (make-lexical-token '*eoi* #f #f))

(define (make-lexer tokens)
  (lambda ()
    (if (null? tokens)
	eoi-token
      (let ((t (car tokens)))
	(set! tokens (cdr tokens))
	t))))

(define (error-handler message . args)
  (set! *error* (cons `(error-handler ,message . ,(if (pair? args)
						      (lexical-token-category (car args))
						    '()))
		      *error*))
  (cons message args))

;;; end of file


code:
":";exec snow -- "$0" "$@"
;;;
;;;; Tests for the GLR parser generator
;;;
;;
;; @created   "Fri Aug 19 11:23:48 EDT 2005"
;;

(package* glr-test/v1.0.0
  (require: lalr/v2.4.0))

(define (syntax-error msg . args)
  (display msg (current-error-port))
  (for-each (cut format (current-error-port) " ~A" <>) args)
  (newline (current-error-port))
  (throw 'misc-error))

(define (make-lexer words)
  (let ((phrase words))
    (lambda ()
      (if (null? phrase)
          '*eoi*
          (let ((word (car phrase)))
            (set! phrase (cdr phrase))
            word)))))

;;;
;;;; Test 1
;;;

(define parser-1
  ;; Grammar taken from Tomita's "An Efficient Augmented-Context-Free Parsing Algorithm"
  (lalr-parser
   (driver: glr)
   (expect: 2)
   (*n *v *d *p)
   (<s>  (<np> <vp>)
         (<s> <pp>))
   (<np> (*n)
         (*d *n)
         (<np> <pp>))
   (<pp> (*p <np>))
   (<vp> (*v <np>))))

(define *phrase-1* '(*n *v *d *n *p *d *n *p *d *n *p *d *n))

(define (test-1)
  (parser-1 (make-lexer *phrase-1*) syntax-error))

;;;
;;;; Test 2
;;;

(define parser-2
  ;; The dangling-else problem
  (lalr-parser
   (driver: glr)
   (expect: 1)
   ((nonassoc: if then else e s))
   (<s> (s)
        (if e then <s>)
        (if e then <s> else <s>))))

(define *phrase-2* '(if e then if e then s else s))

(define (test-2)
  (parser-2 (make-lexer *phrase-2*) syntax-error))

(define (assert-length l n test-name)
  (display "Test '")
  (display test-name)
  (display (if (not (= (length l) n)) "' failed!" "' passed!"))
  (newline))

(assert-length (test-1) 14 1)
(assert-length (test-2) 2 2)

license: mit


code:
# guile-test.sh --
#

for item in \
    test-glr-basics-01.scm              \
    test-glr-basics-02.scm              \
    test-glr-basics-03.scm              \
    test-glr-basics-04.scm              \
    test-glr-basics-05.scm              \
    test-glr-associativity.scm          \
    test-glr-script-expression.scm      \
    test-glr-single-expressions.scm     \
    \
    test-lr-basics-01.scm               \
    test-lr-basics-02.scm               \
    test-lr-basics-03.scm               \
    test-lr-basics-04.scm               \
    test-lr-basics-05.scm               \
    test-lr-error-recovery-01.scm       \
    test-lr-error-recovery-02.scm       \
    test-lr-no-clause.scm               \
    test-lr-associativity-01.scm        \
    test-lr-script-expression.scm       \
    test-lr-single-expressions.scm
    do
printf "\n\n*** Running $item\n"
guile $item
done

### end of file


code:
;;; test-glr-associativity.scm
;;
;;With the GLR parser both  the terminal precedence and the non-terminal
;;associativity  are  not  respected;  rather they  generate  two  child
;;processes.
;;

(load "common-test.scm")

(define parser
  (lalr-parser
   (driver: glr)
   (expect: 0)

   (N LPAREN RPAREN
	(left: + -)
	(right: * /)
	(nonassoc: uminus))

   (output	(expr)			: $1)
   (expr	(expr + expr)           : (list $1 '+ $3)
		(expr - expr)           : (list $1 '- $3)
		(expr * expr)           : (list $1 '* $3)
		(expr / expr)           : (list $1 '/ $3)
		(- expr (prec: uminus)) : (list '- $2)
		(N)                   : $1
		(LPAREN expr RPAREN)    : $2)))

(define (doit . tokens)
  (parser (make-lexer tokens) error-handler))

;;; --------------------------------------------------------------------

;;Remember that the result of the GLR  driver is a list of parses, not a
;;single parse.

(check
    (doit (make-lexical-token 'N #f 1))
  => '(1))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token '+ #f '+)
	  (make-lexical-token 'N #f 2))
  => '((1 + 2)))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token '* #f '*)
	  (make-lexical-token 'N #f 2))
  => '((1 * 2)))

(check
    (doit (make-lexical-token '- #f '-)
	  (make-lexical-token 'N #f 1))
  => '((- 1)))

(check
    (doit (make-lexical-token '- #f '-)
	  (make-lexical-token '- #f '-)
	  (make-lexical-token 'N #f 1))
  => '((- (- 1))))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token '+ #f '+)
	  (make-lexical-token '- #f '-)
	  (make-lexical-token 'N #f 2))
  => '((1 + (- 2))))

;;; --------------------------------------------------------------------

(check
    ;;left-associativity
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token '+ #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token '+ #f '+)
	  (make-lexical-token 'N #f 3))
  => '(((1 + 2) + 3)))

(check
    ;;right-associativity
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token '* #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token '* #f '*)
	  (make-lexical-token 'N #f 3))
  => '(((1 * 2) * 3)
       (1 * (2 * 3))))

(check
    ;;precedence
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token '+ #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token '* #f '*)
	  (make-lexical-token 'N #f 3))
  => '(((1 + 2) * 3)
       (1 + (2 * 3))))

;;; end of file


code:
;;; test-lr-basics-01.scm --
;;
;;A grammar that only accept a single terminal as input.  It refuses the
;;end-of-input as first token.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let* ((lexer		(make-lexer tokens))
	 (parser	(lalr-parser (expect: 0)
				     (driver: glr)
				     (A)
				     (e (A) : $1))))
    (parser lexer error-handler)))

(check
    (doit (make-lexical-token 'A #f 1))
  => '(1))

(check
    (doit)
  => '())

(check
    ;;Parse correctly the first A  and reduce it.  The second A triggers
    ;;an  error which  empties  the  stack and  consumes  all the  input
    ;;tokens.   Finally, an  unexpected end-of-input  error  is returned
    ;;because EOI is invalid as first token after the start.
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2)
	  (make-lexical-token 'A #f 3))
  => '())

;;; end of file


code:
;;; test-lr-basics-02.scm --
;;
;;A grammar that only accept a single terminal or the EOI.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (driver: glr)
			     (A)
			     (e (A) : $1
				()  : 0))))
    (parser (make-lexer tokens) error-handler)))

(check
    (doit)
  => '(0))

(check
    (doit (make-lexical-token 'A #f 1))
  => '(1))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2)
	  (make-lexical-token 'A #f 3))
  => '())

;;; end of file


code:
;;; test-lr-basics-03.scm --
;;
;;A grammar  that accepts  fixed sequences of  a single terminal  or the
;;EOI.

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (driver: glr)
			     (A)
			     (e (A)     : (list $1)
				(A A)   : (list $1 $2)
				(A A A) : (list $1 $2 $3)
				()      : 0))))
    (parser (make-lexer tokens) error-handler)))

(check
    (doit (make-lexical-token 'A #f 1))
  => '((1)))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2))
  => '((1 2)))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2)
	  (make-lexical-token 'A #f 3))
  => '((1 2 3)))

(check
    (doit)
  => '(0))

;;; end of file


code:
;;; test-lr-basics-04.scm --
;;
;;A grammar  accepting a sequence  of equal tokens of  arbitrary length.
;;The return value is the value of the last parsed token.

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (driver: glr)
			     (A)
			     (e (e A) : $2
				(A)   : $1
				()    : 0))))
    (parser (make-lexer tokens) error-handler)))

(check
    (doit)
  => '(0))

(check
    ;;Two  results because  there  is a  shift/reduce  conflict, so  two
    ;;processes are generated.
    (doit (make-lexical-token 'A #f 1))
  => '(1 1))

(check
    ;;Two  results because  there  is a  shift/reduce  conflict, so  two
    ;;processes are generated.  Notice that the rules:
    ;;
    ;;  (e A) (A)
    ;;
    ;;generate only one  conflict when the second "A"  comes.  The third
    ;;"A" comes when  the state is inside the rule "(e  A)", so there is
    ;;no conflict.
    ;;
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2)
	  (make-lexical-token 'A #f 3))
  => '(3 3))

;;; end of file


code:
;;; test-lr-basics-05.scm --
;;
;;A grammar  accepting a sequence  of equal tokens of  arbitrary length.
;;The return value is the list of values.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (driver: glr)
			     (A)
			     (e (e A) : (cons $2 $1)
				(A)   : (list $1)
				()    : (list 0)))))
    (parser (make-lexer tokens) error-handler)))

(check
    (doit)
  => '((0)))

(check
    (doit (make-lexical-token 'A #f 1))
  => '((1 0)
       (1)))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2))
  => '((2 1 0)
       (2 1)))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2)
	  (make-lexical-token 'A #f 3))
  => '((3 2 1 0)
       (3 2 1)))

;;; end of file


code:
;;; test-lr-script-expression.scm --
;;
;;Parse scripts, each line an expression.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (driver: glr)
			     (N O C T (left: A) (left: M) (nonassoc: U))

			     (script	(lines)		: (reverse $1))

			     (lines	(lines line)	: (cons $2 $1)
					(line)		: (list $1))

			     (line	(T)		: #\newline
					(E T)		: $1
					(error T)	: (list 'error-clause $2))

			     (E	(N)		: $1
				(E A E)		: ($2 $1 $3)
				(E M E)		: ($2 $1 $3)
				(A E (prec: U))	: ($1 $2)
				(O E C)		: $2))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------
;;; Correct input

(check
    (doit (make-lexical-token 'T #f #\newline))
  => '((#\newline)))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'T #f #\newline))
  => '((1)))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'T #f #\newline))
  => '((3)))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline))
  => '((9) (7)))

(check
    (doit (make-lexical-token 'N #f 10)
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline))
  => '((23)))

(check
    (doit (make-lexical-token 'O #f #\()
	  (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'C #f #\))
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline))
  => '((9)))

(check
    (doit (make-lexical-token 'O #f #\()
	  (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'C #f #\))
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline)

	  (make-lexical-token 'N #f 4)
	  (make-lexical-token 'M #f /)
	  (make-lexical-token 'N #f 5)
	  (make-lexical-token 'T #f #\newline))
  => '((9 4/5)))

;;; --------------------------------------------------------------------

(check
    ;;Successful error recovery.
    (doit (make-lexical-token 'O #f #\()
	  (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline)

	  (make-lexical-token 'N #f 4)
	  (make-lexical-token 'M #f /)
	  (make-lexical-token 'N #f 5)
	  (make-lexical-token 'T #f #\newline))
  => '())

(check
    ;;Unexpected end of input.
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2))
  => '())

(check
    ;;Unexpected end of input.
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'T #f #\newline))
  => '())

;;; end of file


code:
;;; test-lr-single-expressions.scm --
;;
;;Grammar accepting single expressions.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (driver: glr)
			     (N O C (left: A) (left: M) (nonassoc: U))

			     (E	(N)		: $1
				(E A E)		: ($2 $1 $3)
				(E M E)		: ($2 $1 $3)
				(A E (prec: U))	: ($1 $2)
				(O E C)		: $2))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------

(check	;correct input
    (doit (make-lexical-token 'N #f 1))
  => '(1))

(check	;correct input
    (doit (make-lexical-token 'A #f -)
	  (make-lexical-token 'N #f 1))
  => '(-1))

(check	;correct input
    (doit (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 1))
  => '(1))

(check	;correct input
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2))
  => '(3))

(check	;correct input
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3))
  => '(9 7))

(check	;correct input
    (doit (make-lexical-token 'O #f #\()
	  (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'C #f #\))
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3))
  => '(9))

;;; end of file


code:
;;; test-lr-associativity-01.scm --
;;
;;Show  how  to use  left  and  right  associativity.  Notice  that  the
;;terminal  M is  declared  as right  associative;  this influences  the
;;binding  of values to  the $n  symbols in  the semantic  clauses.  The
;;semantic clause in the rule:
;;
;;  (E M E M E)     : (list $1 $2 (list $3 $4 $5))
;;
;;looks like it is right-associated,  and it is because we have declared
;;M as "right:".
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser
		 (expect: 0)
		 (N (left: A)
		    (right: M)
		    (nonassoc: U))
		 (E	(N)		: $1
			(E A E)         : (list $1 $2 $3)
			(E M E)         : (list $1 $2 $3)
			(E M E M E)     : (list $1 $2 (list $3 $4 $5))
			(A E (prec: U))	: (list '- $2)))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------
;;; Single operator.

(check
    (doit (make-lexical-token 'N #f 1))
  => 1)

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2))
  => '(1 + 2))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2))
  => '(1 * 2))

(check
    (doit (make-lexical-token 'A #f '-)
	  (make-lexical-token 'N #f 1))
  => '(- 1))

;;; --------------------------------------------------------------------
;;; Precedence.

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 3))
  => '(1 + (2 * 3)))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 3))
  => '((1 * 2) + 3))

;;; --------------------------------------------------------------------
;;; Associativity.

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 3))
  => '((1 + 2) + 3))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 3))
  => '(1 * (2 * 3)))

;;; end of file


code:
;;; test-lr-associativity-02.scm --
;;
;;Show  how  to use  left  and  right  associativity.  Notice  that  the
;;terminal  M  is declared  as  left  associative;  this influences  the
;;binding  of values to  the $n  symbols in  the semantic  clauses.  The
;;semantic clause in the rule:
;;
;;  (E M E M E)     : (list $1 $2 (list $3 $4 $5))
;;
;;looks like  it is right-associated, but the  result is left-associated
;;because we have declared M as "left:".
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser
		 (expect: 0)
		 (N (left: A)
		    (left: M)
		    (nonassoc: U))
		 (E	(N)		: $1
			(E A E)         : (list $1 $2 $3)
			(E M E)         : (list $1 $2 $3)
			(E M E M E)     : (list $1 $2 (list $3 $4 $5))
			(A E (prec: U))	: (list '- $2)))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------
;;; Single operator.

(check
    (doit (make-lexical-token 'N #f 1))
  => 1)

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2))
  => '(1 + 2))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2))
  => '(1 * 2))

(check
    (doit (make-lexical-token 'A #f '-)
	  (make-lexical-token 'N #f 1))
  => '(- 1))

;;; --------------------------------------------------------------------
;;; Precedence.

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 3))
  => '(1 + (2 * 3)))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 3))
  => '((1 * 2) + 3))

;;; --------------------------------------------------------------------
;;; Associativity.

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 3))
  => '((1 + 2) + 3))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 3))
  => '((1 * 2) * 3))

;;; end of file


code:
;;; test-lr-associativity-01.scm --
;;
;;Show  how  to use  left  and  right  associativity.  Notice  that  the
;;terminal M is declared as non-associative; this influences the binding
;;of values  to the  $n symbols in  the semantic clauses.   The semantic
;;clause in the rule:
;;
;;  (E M E M E)     : (list $1 $2 (list $3 $4 $5))
;;
;;looks like it is right-associated,  and it is because we have declared
;;M as "right:".
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser
		 (expect: 0)
		 (N (nonassoc: A)
		    (nonassoc: M))
		 (E	(N)		: $1
			(E A E)         : (list $1 $2 $3)
			(E A E A E)     : (list (list $1 $2 $3) $4 $5)
			(E M E)         : (list $1 $2 $3)
			(E M E M E)     : (list $1 $2 (list $3 $4 $5))))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------
;;; Single operator.

(check
    (doit (make-lexical-token 'N #f 1))
  => 1)

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2))
  => '(1 + 2))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2))
  => '(1 * 2))

;;; --------------------------------------------------------------------
;;; Precedence.

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 3))
  => '(1 + (2 * 3)))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 3))
  => '((1 * 2) + 3))

;;; --------------------------------------------------------------------
;;; Associativity.

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 3))
  => '((1 + 2) + 3))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 3))
  => '(1 * (2 * 3)))

;;; end of file


code:
;;; test-lr-associativity-04.scm --
;;
;;Show how to use associativity.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser
		 (expect: 0)
		 (N (left: A)
		    (left: M))
		 (E	(N)		: $1

			(E A E)         : (list $1 $2 $3)
			(E A E A E)     : (list (list $1 $2 $3) $4 $5)

			(E M E)         : (list $1 $2 $3)
			(E M E M E)     : (list $1 $2 (list $3 $4 $5))

			(E A E M E)     : (list $1 $2 $3 $4 $5)
			(E M E A E)     : (list $1 $2 $3 $4 $5)
			))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------
;;; Single operator.

(check
    (doit (make-lexical-token 'N #f 1))
  => 1)

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2))
  => '(1 + 2))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2))
  => '(1 * 2))

;;; --------------------------------------------------------------------
;;; Precedence.

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 3))
  => '(1 + (2 * 3)))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 3))
  => '((1 * 2) + 3))

;;; --------------------------------------------------------------------
;;; Associativity.

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'A #f '+)
	  (make-lexical-token 'N #f 3))
  => '((1 + 2) + 3))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f '*)
	  (make-lexical-token 'N #f 3))
  => '((1 * 2) * 3))

;;; end of file


code:
;;; test-lr-basics-01.scm --
;;
;;A grammar that only accept a single terminal as input.  It refuses the
;;end-of-input as first token.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let* ((lexer		(make-lexer tokens))
	 (parser	(lalr-parser (expect: 0)
				     (A)
				     (e (A) : $1))))
    (parser lexer error-handler)))

(check
    (doit (make-lexical-token 'A #f 1))
  => 1)

(check
    (let ((r (doit)))
      (cons r *error*))
  => '(#f (error-handler "Syntax error: unexpected end of input")))

(check
    ;;Parse correctly the first A  and reduce it.  The second A triggers
    ;;an  error which  empties  the  stack and  consumes  all the  input
    ;;tokens.   Finally, an  unexpected end-of-input  error  is returned
    ;;because EOI is invalid as first token after the start.
    (let ((r (doit (make-lexical-token 'A #f 1)
		   (make-lexical-token 'A #f 2)
		   (make-lexical-token 'A #f 3))))
      (cons r *error*))
  => '(#f
       (error-handler "Syntax error: unexpected end of input")
       (error-handler "Syntax error: unexpected token : " . A)))

;;; end of file


code:
;;; test-lr-basics-02.scm --
;;
;;A grammar that only accept a single terminal or the EOI.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (A)
			     (e (A) : $1
				()  : 0))))
    (parser (make-lexer tokens) error-handler)))

(check
    (doit)
  => 0)

(check
    (doit (make-lexical-token 'A #f 1))
  => 1)

(check
    ;;Parse correctly the first A  and reduce it.  The second A triggers
    ;;an  error which  empties  the  stack and  consumes  all the  input
    ;;tokens.  Finally, the end-of-input token is correctly parsed.
    (let ((r (doit (make-lexical-token 'A #f 1)
		   (make-lexical-token 'A #f 2)
		   (make-lexical-token 'A #f 3))))
      (cons r *error*))
  => '(0 (error-handler "Syntax error: unexpected token : " . A)))

;;; end of file


code:
;;; test-lr-basics-03.scm --
;;
;;A grammar  that accepts  fixed sequences of  a single terminal  or the
;;EOI.

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (A)
			     (e (A)     : (list $1)
				(A A)   : (list $1 $2)
				(A A A) : (list $1 $2 $3)
				()      : 0))))
    (parser (make-lexer tokens) error-handler)))

(check
    (doit (make-lexical-token 'A #f 1))
  => '(1))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2))
  => '(1 2))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2)
	  (make-lexical-token 'A #f 3))
  => '(1 2 3))

(check
    (doit)
  => 0)

;;; end of file


code:
;;; test-lr-basics-04.scm --
;;
;;A grammar  accepting a sequence  of equal tokens of  arbitrary length.
;;The return value is the value of the last parsed token.

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (A)
			     (e (e A) : $2
				(A)   : $1
				()    : 0))))
    (parser (make-lexer tokens) error-handler)))

(check
    (doit)
  => 0)

(check
    (doit (make-lexical-token 'A #f 1))
  => 1)

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2)
	  (make-lexical-token 'A #f 3))
  => 3)

;;; end of file


code:
;;; test-lr-basics-05.scm --
;;
;;A grammar  accepting a sequence  of equal tokens of  arbitrary length.
;;The return value is the list of values.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (A)
			     (e (e A) : (cons $2 $1)
				(A)   : (list $1)
				()    : 0))))
    (parser (make-lexer tokens) error-handler)))

(check
    (doit)
  => 0)

(check
    (doit (make-lexical-token 'A #f 1))
  => '(1))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2))
  => '(2 1))

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'A #f 2)
	  (make-lexical-token 'A #f 3))
  => '(3 2 1))

;;; end of file


code:
;;; test-lr-error-recovery-01.scm --
;;
;;Test error recovery with a terminator terminal.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser
		 (expect: 0)
		 (NUMBER BAD NEWLINE)

		 (script	(lines)		: (reverse $1)
				()		: 0)
		 (lines	(lines line)		: (cons $2 $1)
			(line)			: (list $1))
		 (line	(NEWLINE)		: (list 'line $1)
			(NUMBER NEWLINE)	: (list 'line $1 $2)
			(NUMBER NUMBER NEWLINE)	: (list 'line $1 $2 $3)

			;;This semantic  action will cause  "(recover $1
			;;$2)" to be the result of the offending line.
			(error NEWLINE)		: (list 'recover $1 $2)))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------
;;; No errors, grammar tests.

(check
    (doit)
  => 0)

(check
    (doit (make-lexical-token 'NEWLINE #f #\newline))
  => '((line #\newline)))

(check
    (doit (make-lexical-token 'NUMBER  #f 1)
	  (make-lexical-token 'NEWLINE #f #\newline))
  => '((line 1 #\newline)))

(check
    (doit (make-lexical-token 'NUMBER  #f 1)
	  (make-lexical-token 'NUMBER  #f 2)
	  (make-lexical-token 'NEWLINE #f #\newline))
  => '((line 1 2 #\newline)))

(check
    (doit (make-lexical-token 'NUMBER  #f 1)
	  (make-lexical-token 'NEWLINE #f #\newline)
	  (make-lexical-token 'NUMBER  #f 2)
	  (make-lexical-token 'NEWLINE #f #\newline))
  => '((line 1 #\newline)
       (line 2 #\newline)))

(check
    (doit (make-lexical-token 'NUMBER  #f 1)
	  (make-lexical-token 'NEWLINE #f #\newline)
	  (make-lexical-token 'NUMBER  #f 2)
	  (make-lexical-token 'NEWLINE #f #\newline)
	  (make-lexical-token 'NUMBER  #f 3)
	  (make-lexical-token 'NEWLINE #f #\newline))
  => '((line 1 #\newline)
       (line 2 #\newline)
       (line 3 #\newline)))

(check
    (doit (make-lexical-token 'NUMBER  #f 1)
	  (make-lexical-token 'NEWLINE #f #\newline)
	  (make-lexical-token 'NUMBER  #f 2)
	  (make-lexical-token 'NEWLINE #f #\newline)
	  (make-lexical-token 'NUMBER  #f 3)
	  (make-lexical-token 'NEWLINE #f #\newline)
	  (make-lexical-token 'NUMBER  #f 41)
	  (make-lexical-token 'NUMBER  #f 42)
	  (make-lexical-token 'NEWLINE #f #\newline))
  => '((line 1 #\newline)
       (line 2 #\newline)
       (line 3 #\newline)
       (line 41 42 #\newline)))

;;; --------------------------------------------------------------------
;;; Successful error recovery.

(check
    ;;The BAD triggers an error,  recovery happens, the first NEWLINE is
    ;;correctly parsed as recovery token; the second line is correct.
    (let ((r (doit (make-lexical-token 'NUMBER  #f 1)
		   (make-lexical-token 'BAD      #f 'alpha)
		   (make-lexical-token 'NEWLINE #f #\newline)
		   (make-lexical-token 'NUMBER  #f 2)
		   (make-lexical-token 'NEWLINE #f #\newline))))
      (cons r *error*))
  => '(((recover #f #f)
	(line 2 #\newline))
       (error-handler "Syntax error: unexpected token : " . BAD)))

(check
    ;;The  first BAD triggers  an error,  recovery happens  skipping the
    ;;second  and   third  BADs,  the  first  NEWLINE   is  detected  as
    ;;synchronisation token; the second line is correct.
    (let ((r (doit (make-lexical-token 'NUMBER  #f 1)
		   (make-lexical-token 'BAD     #f 'alpha)
		   (make-lexical-token 'BAD     #f 'beta)
		   (make-lexical-token 'BAD     #f 'delta)
		   (make-lexical-token 'NEWLINE #f #\newline)
		   (make-lexical-token 'NUMBER  #f 2)
		   (make-lexical-token 'NEWLINE #f #\newline))))
      (cons r *error*))
  => '(((recover #f #f)
	(line 2 #\newline))
       (error-handler "Syntax error: unexpected token : " . BAD)))

;;; --------------------------------------------------------------------
;;; Failed error recovery.

(check
    ;;End-of-input is found after NUMBER.
    (let ((r (doit (make-lexical-token 'NUMBER  #f 1))))
      (cons r *error*))
  => '(#f (error-handler "Syntax error: unexpected end of input")))

(check
    ;;The BAD triggers  the error, the stack is rewind  up to the start,
    ;;then end-of-input  happens while trying  to skip tokens  until the
    ;;synchronisation one is found.  End-of-input is an acceptable token
    ;;after the start.
    (let ((r (doit (make-lexical-token 'NUMBER  #f 1)
		   (make-lexical-token 'BAD     #f 'alpha)
		   (make-lexical-token 'BAD     #f 'beta)
		   (make-lexical-token 'BAD     #f 'delta))))
      (cons r *error*))
  => '(0 (error-handler "Syntax error: unexpected token : " . BAD)))

(check
    ;;The BAD triggers  the error, the stack is rewind  up to the start,
    ;;then end-of-input  happens while trying  to skip tokens  until the
    ;;synchronisation one is found.  End-of-input is an acceptable token
    ;;after the start.
    (let ((r (doit (make-lexical-token 'BAD #f 'alpha))))
      (cons r *error*))
  => '(0 (error-handler "Syntax error: unexpected token : " . BAD)))

;;; end of file


code:
;;; test-lr-error-recovery-02.scm --
;;
;;Test error  recovery policy when the synchronisation  terminal has the
;;same category of the lookahead that raises the error.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (A B C)
			     (alphas (alpha)		: $1
				     (alphas alpha)	: $2)
			     (alpha (A B)	: (list $1 $2)
				    (C)		: $1
				    (error C)	: 'error-form))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------
;;; No error, just grammar tests.

(check
    (doit (make-lexical-token 'A #f 1)
	  (make-lexical-token 'B #f 2))
  => '(1 2))

(check
    (doit (make-lexical-token 'C #f 3))
  => '3)

;;; --------------------------------------------------------------------
;;; Successful error recovery.

(check
    ;;Error, recovery, end-of-input.
    (let ((r (doit (make-lexical-token 'A #f 1)
		   (make-lexical-token 'C #f 3))))
      (cons r *error*))
  => '(error-form (error-handler "Syntax error: unexpected token : " . C)))

(check
    ;;Error, recovery, correct parse of "A B".
    (let ((r (doit (make-lexical-token 'A #f 1)
		   (make-lexical-token 'C #f 3)
		   (make-lexical-token 'A #f 1)
		   (make-lexical-token 'B #f 2))))
      (cons r *error*))
  => '((1 2)
       (error-handler "Syntax error: unexpected token : " . C)))

;;; end of file


code:
;;; test-lr-no-clause.scm --
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (NUMBER COMMA NEWLINE)

			     (lines (lines line)	: (list $2)
				    (line)		: (list $1))
			     (line (NEWLINE)		: #\newline
				   (NUMBER NEWLINE)	: $1
				   ;;this is a rule with no semantic action
				   (COMMA NUMBER NEWLINE)))))
    (parser (make-lexer tokens) error-handler)))

(check
    ;;correct input
    (doit (make-lexical-token 'NUMBER  #f 1)
	  (make-lexical-token 'NEWLINE #f #\newline))
  => '(1))

(check
    ;;correct input with comma, which is a rule with no client form
    (doit (make-lexical-token 'COMMA   #f #\,)
	  (make-lexical-token 'NUMBER  #f 1)
	  (make-lexical-token 'NEWLINE #f #\newline))
  => '(#(line-3 #\, 1 #\newline)))

(check
    ;;correct input with comma, which is a rule with no client form
    (doit (make-lexical-token 'NUMBER  #f 1)
	  (make-lexical-token 'NEWLINE #f #\newline)
	  (make-lexical-token 'COMMA   #f #\,)
	  (make-lexical-token 'NUMBER  #f 2)
	  (make-lexical-token 'NEWLINE #f #\newline))
  => '(#(line-3 #\, 2 #\newline)))

;;; end of file


code:
;;; test-lr-script-expression.scm --
;;
;;Parse scripts, each line an expression.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (N O C T (left: A) (left: M) (nonassoc: U))

			     (script	(lines)		: (reverse $1))

			     (lines	(lines line)	: (cons $2 $1)
					(line)		: (list $1))

			     (line	(T)		: #\newline
					(E T)		: $1
					(error T)	: (list 'error-clause $2))

			     (E	(N)		: $1
				(E A E)		: ($2 $1 $3)
				(E M E)		: ($2 $1 $3)
				(A E (prec: U))	: ($1 $2)
				(O E C)		: $2))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------
;;; Correct input

(check
    (doit (make-lexical-token 'T #f #\newline))
  => '(#\newline))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'T #f #\newline))
  => '(1))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'T #f #\newline))
  => '(3))

(check
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline))
  => '(7))

(check
    (doit (make-lexical-token 'O #f #\()
	  (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'C #f #\))
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline))
  => '(9))

(check
    (doit (make-lexical-token 'O #f #\()
	  (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'C #f #\))
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline)

	  (make-lexical-token 'N #f 4)
	  (make-lexical-token 'M #f /)
	  (make-lexical-token 'N #f 5)
	  (make-lexical-token 'T #f #\newline))
  => '(9 4/5))

;;; --------------------------------------------------------------------

(check
    ;;Successful error recovery.
    (doit (make-lexical-token 'O #f #\()
	  (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3)
	  (make-lexical-token 'T #f #\newline)

	  (make-lexical-token 'N #f 4)
	  (make-lexical-token 'M #f /)
	  (make-lexical-token 'N #f 5)
	  (make-lexical-token 'T #f #\newline))
  => '((error-clause #f)
       4/5))

(check
    ;;Unexpected end of input.
    (let ((r (doit (make-lexical-token 'N #f 1)
		   (make-lexical-token 'A #f +)
		   (make-lexical-token 'N #f 2))))
      (cons r *error*))
  => '(#f (error-handler "Syntax error: unexpected end of input")))

(check
    ;;Unexpected end of input.
    (let ((r (doit (make-lexical-token 'N #f 1)
		   (make-lexical-token 'A #f +)
		   (make-lexical-token 'T #f #\newline))))
      (cons r *error*))
  => '(((error-clause #f))
       (error-handler "Syntax error: unexpected token : " . T)))

;;; end of file


code:
;;; test-lr-single-expressions.scm --
;;
;;Grammar accepting single expressions.
;;

(load "common-test.scm")

(define (doit . tokens)
  (let ((parser (lalr-parser (expect: 0)
			     (N O C (left: A) (left: M) (nonassoc: U))

			     (E	(N)		: $1
				(E A E)		: ($2 $1 $3)
				(E M E)		: ($2 $1 $3)
				(A E (prec: U))	: ($1 $2)
				(O E C)		: $2))))
    (parser (make-lexer tokens) error-handler)))

;;; --------------------------------------------------------------------

(check	;correct input
    (doit (make-lexical-token 'N #f 1))
  => 1)

(check	;correct input
    (doit (make-lexical-token 'A #f -)
	  (make-lexical-token 'N #f 1))
  => -1)

(check	;correct input
    (doit (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 1))
  => 1)

(check	;correct input
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2))
  => 3)

(check	;correct input
    (doit (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3))
  => 7)

(check	;correct input
    (doit (make-lexical-token 'O #f #\()
	  (make-lexical-token 'N #f 1)
	  (make-lexical-token 'A #f +)
	  (make-lexical-token 'N #f 2)
	  (make-lexical-token 'C #f #\))
	  (make-lexical-token 'M #f *)
	  (make-lexical-token 'N #f 3))
  => 9)

;;; end of file


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

(define-module (test-suite lib)
  :use-module (ice-9 stack-catch)
  :use-module (ice-9 regex)
  :autoload   (srfi srfi-1)  (append-map)
  :export (

 ;; Exceptions which are commonly being tested for.
 exception:syntax-pattern-unmatched
 exception:bad-variable
 exception:missing-expression
 exception:out-of-range exception:unbound-var
 exception:used-before-defined
 exception:wrong-num-args exception:wrong-type-arg
 exception:numerical-overflow
 exception:struct-set!-denied
 exception:system-error
 exception:encoding-error
 exception:miscellaneous-error
 exception:string-contains-nul
 exception:read-error
 exception:null-pointer-error
 exception:vm-error

 ;; Reporting passes and failures.
 run-test
 pass-if expect-fail
 pass-if-exception expect-fail-exception

 ;; Naming groups of tests in a regular fashion.
 with-test-prefix with-test-prefix* current-test-prefix
 format-test-name

 ;; Using the debugging evaluator.
 with-debugging-evaluator with-debugging-evaluator*

 ;; Using a given locale
 with-locale with-locale* with-latin1-locale with-latin1-locale*

 ;; Reporting results in various ways.
 register-reporter unregister-reporter reporter-registered?
 make-count-reporter print-counts
 make-log-reporter
 full-reporter
 user-reporter))

;;;; If you're using Emacs's Scheme mode:
;;;;   (put 'with-test-prefix 'scheme-indent-function 1)

;;;; CORE FUNCTIONS
;;;;
;;;; The function (run-test name expected-result thunk) is the heart of the
;;;; testing environment.  The first parameter NAME is a unique name for the
;;;; test to be executed (for an explanation of this parameter see below under
;;;; TEST NAMES).  The second parameter EXPECTED-RESULT is a boolean value
;;;; that indicates whether the corresponding test is expected to pass.  If
;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
;;;; #f the test is expected to fail.  Finally, THUNK is the function that
;;;; actually performs the test.  For example:
;;;;
;;;;    (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
;;;;
;;;; To report success, THUNK should either return #t or throw 'pass.  To
;;;; report failure, THUNK should either return #f or throw 'fail.  If THUNK
;;;; returns a non boolean value or throws 'unresolved, this indicates that
;;;; the test did not perform as expected.  For example the property that was
;;;; to be tested could not be tested because something else went wrong.
;;;; THUNK may also throw 'untested to indicate that the test was deliberately
;;;; not performed, for example because the test case is not complete yet.
;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
;;;; requires some feature that is not available in the configured testing
;;;; environment.  All other exceptions thrown by THUNK are considered as
;;;; errors.
;;;;
;;;;
;;;; Convenience macros for tests expected to pass or fail
;;;;
;;;; * (pass-if name body) is a short form for
;;;;   (run-test name #t (lambda () body))
;;;; * (expect-fail name body) is a short form for
;;;;   (run-test name #f (lambda () body))
;;;;
;;;; For example:
;;;;
;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
;;;;
;;;;
;;;; Convenience macros to test for exceptions
;;;;
;;;; The following macros take exception parameters which are pairs
;;;; (type . message), where type is a symbol that denotes an exception type
;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
;;;; regular expression that describes the error message for the exception
;;;; like "Argument .* out of range".
;;;;
;;;; * (pass-if-exception name exception body) will pass if the execution of
;;;;   body causes the given exception to be thrown.  If no exception is
;;;;   thrown, the test fails.  If some other exception is thrown, is is an
;;;;   error.
;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
;;;;   the execution of body causes the given exception to be thrown.  If no
;;;;   exception is thrown, the test fails expectedly.  If some other
;;;;   exception is thrown, it is an error.

;;;; TEST NAMES
;;;;
;;;; Every test in the test suite has a unique name, to help
;;;; developers find tests that are failing (or unexpectedly passing),
;;;; and to help gather statistics.
;;;;
;;;; A test name is a list of printable objects.  For example:
;;;; ("ports.scm" "file" "read and write back list of strings")
;;;; ("ports.scm" "pipe" "read")
;;;;
;;;; Test names may contain arbitrary objects, but they always have
;;;; the following properties:
;;;; - Test names can be compared with EQUAL?.
;;;; - Test names can be reliably stored and retrieved with the standard WRITE
;;;;   and READ procedures; doing so preserves their identity.
;;;;
;;;; For example:
;;;;
;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))
;;;;
;;;; In that case, the test name is the list ("simple addition").
;;;;
;;;; In the case of simple tests the expression that is tested would often
;;;; suffice as a test name by itself.  Therefore, the convenience macros
;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
;;;; a test name in such cases.
;;;;
;;;; * (pass-if expression) is a short form for
;;;;   (run-test 'expression #t (lambda () expression))
;;;; * (expect-fail expression) is a short form for
;;;;   (run-test 'expression #f (lambda () expression))
;;;;
;;;; For example:
;;;;
;;;;    (pass-if (= 2 (+ 1 1)))
;;;;
;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
;;;; a prefix for the names of all tests whose results are reported
;;;; within their dynamic scope.  For example:
;;;;
;;;; (begin
;;;;   (with-test-prefix "basic arithmetic"
;;;;     (pass-if "addition" (= (+ 2 2) 4))
;;;;     (pass-if "subtraction" (= (- 4 2) 2)))
;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
;;;;
;;;; In that example, the three test names are:
;;;;   ("basic arithmetic" "addition"),
;;;;   ("basic arithmetic" "subtraction"), and
;;;;   ("multiplication").
;;;;
;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
;;;; a new element to the current prefix:
;;;;
;;;; (with-test-prefix "arithmetic"
;;;;   (with-test-prefix "addition"
;;;;     (pass-if "integer" (= (+ 2 2) 4))
;;;;     (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
;;;;   (with-test-prefix "subtraction"
;;;;     (pass-if "integer" (= (- 2 2) 0))
;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
;;;;
;;;; The four test names here are:
;;;;   ("arithmetic" "addition" "integer")
;;;;   ("arithmetic" "addition" "complex")
;;;;   ("arithmetic" "subtraction" "integer")
;;;;   ("arithmetic" "subtraction" "complex")
;;;;
;;;; To print a name for a human reader, we DISPLAY its elements,
;;;; separated by ": ".  So, the last set of test names would be
;;;; reported as:
;;;;
;;;;   arithmetic: addition: integer
;;;;   arithmetic: addition: complex
;;;;   arithmetic: subtraction: integer
;;;;   arithmetic: subtraction: complex
;;;;
;;;; The Guile benchmarks use with-test-prefix to include the name of
;;;; the source file containing the test in the test name, to help
;;;; developers to find failing tests, and to provide each file with its
;;;; own namespace.

;;;; REPORTERS
;;;;
;;;; A reporter is a function which we apply to each test outcome.
;;;; Reporters can log results, print interesting results to the
;;;; standard output, collect statistics, etc.
;;;;
;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
;;;; possibly additional arguments depending on RESULT; its return value
;;;; is ignored.  RESULT has one of the following forms:
;;;;
;;;; pass         - The test named TEST passed.
;;;;                Additional arguments are ignored.
;;;; upass        - The test named TEST passed unexpectedly.
;;;;                Additional arguments are ignored.
;;;; fail         - The test named TEST failed.
;;;;                Additional arguments are ignored.
;;;; xfail        - The test named TEST failed, as expected.
;;;;                Additional arguments are ignored.
;;;; unresolved   - The test named TEST did not perform as expected, for
;;;;                example the property that was to be tested could not be
;;;;                tested because something else went wrong.
;;;;                Additional arguments are ignored.
;;;; untested     - The test named TEST was not actually performed, for
;;;;                example because the test case is not complete yet.
;;;;                Additional arguments are ignored.
;;;; unsupported  - The test named TEST requires some feature that is not
;;;;                available in the configured testing environment.
;;;;                Additional arguments are ignored.
;;;; error        - An error occurred while the test named TEST was
;;;;                performed.  Since this result means that the system caught
;;;;                an exception it could not handle, the exception arguments
;;;;                are passed as additional arguments.
;;;;
;;;; This library provides some standard reporters for logging results
;;;; to a file, reporting interesting results to the user, and
;;;; collecting totals.
;;;;
;;;; You can use the REGISTER-REPORTER function and friends to add
;;;; whatever reporting functions you like.  If you don't register any
;;;; reporters, the library uses FULL-REPORTER, which simply writes
;;;; all results to the standard output.

;;;; MISCELLANEOUS
;;;;

;;; Define some exceptions which are commonly being tested for.
(define exception:syntax-pattern-unmatched
  (cons 'syntax-error "source expression failed to match any pattern"))
(define exception:bad-variable
  (cons 'syntax-error "Bad variable"))
(define exception:missing-expression
  (cons 'misc-error "^missing or extra expression"))
(define exception:out-of-range
  (cons 'out-of-range "^.*out of range"))
(define exception:unbound-var
  (cons 'unbound-variable "^Unbound variable"))
(define exception:used-before-defined
  (cons 'unbound-variable "^Variable used before given a value"))
(define exception:wrong-num-args
  (cons 'wrong-number-of-args "^Wrong number of arguments"))
(define exception:wrong-type-arg
  (cons 'wrong-type-arg "^Wrong type"))
(define exception:numerical-overflow
  (cons 'numerical-overflow "^Numerical overflow"))
(define exception:struct-set!-denied
  (cons 'misc-error "^set! denied for field"))
(define exception:system-error
  (cons 'system-error ".*"))
(define exception:encoding-error
  (cons 'encoding-error "(cannot convert to output locale|input locale conversion error)"))
(define exception:miscellaneous-error
  (cons 'misc-error "^.*"))
(define exception:read-error
  (cons 'read-error "^.*$"))
(define exception:null-pointer-error
  (cons 'null-pointer-error "^.*$"))
(define exception:vm-error
  (cons 'vm-error "^.*$"))

;; as per throw in scm_to_locale_stringn()
(define exception:string-contains-nul
  (cons 'misc-error "^string contains #\\\\nul character"))

;;; Display all parameters to the default output port, followed by a newline.
(define (display-line . objs)
  (for-each display objs)
  (newline))

;;; Display all parameters to the given output port, followed by a newline.
(define (display-line-port port . objs)
  (for-each (lambda (obj) (display obj port)) objs)
  (newline port))

;;;; CORE FUNCTIONS
;;;;

;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test #f)
(let ((test-running #f))
  (define (local-run-test name expect-pass thunk)
    (if test-running
	(error "Nested calls to run-test are not permitted.")
	(let ((test-name (full-name name)))
	  (set! test-running #t)
	  (catch #t
	    (lambda ()
	      (let ((result (thunk)))
		(if (eq? result #t) (throw 'pass))
		(if (eq? result #f) (throw 'fail))
		(throw 'unresolved)))
	    (lambda (key . args)
	      (case key
		((pass)
		 (report (if expect-pass 'pass 'upass) test-name))
		((fail)
		 (report (if expect-pass 'fail 'xfail) test-name))
		((unresolved untested unsupported)
		 (report key test-name))
		((quit)
		 (report 'unresolved test-name)
		 (quit))
		(else
		 (report 'error test-name (cons key args))))))
	  (set! test-running #f))))
  (set! run-test local-run-test))

;;; A short form for tests that are expected to pass, taken from Greg.
(define-syntax pass-if
  (syntax-rules ()
    ((_ name)
     ;; presume this is a simple test, i.e. (pass-if (even? 2))
     ;; where the body should also be the name.
     (run-test 'name #t (lambda () name)))
    ((_ name rest ...)
     (run-test name #t (lambda () rest ...)))))

;;; A short form for tests that are expected to fail, taken from Greg.
(define-syntax expect-fail
  (syntax-rules ()
    ((_ name)
     ;; presume this is a simple test, i.e. (expect-fail (even? 2))
     ;; where the body should also be the name.
     (run-test 'name #f (lambda () name)))
    ((_ name rest ...)
     (run-test name #f (lambda () rest ...)))))

;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
  (run-test name expect-pass
    (lambda ()
      (stack-catch (car exception)
	(lambda () (thunk) #f)
	(lambda (key proc message . rest)
	  (cond
           ;; handle explicit key
           ((string-match (cdr exception) message)
            #t)
           ;; handle `(error ...)' which uses `misc-error' for key and doesn't
           ;; yet format the message and args (we have to do it here).
           ((and (eq? 'misc-error (car exception))
                 (list? rest)
                 (string-match (cdr exception)
                               (apply simple-format #f message (car rest))))
            #t)
           ;; handle syntax errors which use `syntax-error' for key and don't
           ;; yet format the message and args (we have to do it here).
           ((and (eq? 'syntax-error (car exception))
                 (list? rest)
                 (string-match (cdr exception)
                               (apply simple-format #f message (car rest))))
            #t)
           ;; unhandled; throw again
           (else
            (apply throw key proc message rest))))))))

;;; A short form for tests that expect a certain exception to be thrown.
(define-syntax pass-if-exception
  (syntax-rules ()
    ((_ name exception body rest ...)
     (run-test-exception name exception #t (lambda () body rest ...)))))

;;; A short form for tests expected to fail to throw a certain exception.
(define-syntax expect-fail-exception
  (syntax-rules ()
    ((_ name exception body rest ...)
     (run-test-exception name exception #f (lambda () body rest ...)))))

;;;; TEST NAMES
;;;;

;;;; Turn a test name into a nice human-readable string.
(define (format-test-name name)
  ;; Choose a Unicode-capable encoding so that the string port can contain any
  ;; valid Unicode character.
  (with-fluids ((%default-port-encoding "UTF-8"))
    (call-with-output-string
     (lambda (port)
       (let loop ((name name)
                  (separator ""))
         (if (pair? name)
             (begin
               (display separator port)
               (display (car name) port)
               (loop (cdr name) ": "))))))))

;;;; For a given test-name, deliver the full name including all prefixes.
(define (full-name name)
  (append (current-test-prefix) (list name)))

;;; A fluid containing the current test prefix, as a list.
(define prefix-fluid (make-fluid))
(fluid-set! prefix-fluid '())
(define (current-test-prefix)
  (fluid-ref prefix-fluid))

;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
;;; The name prefix is only changed within the dynamic scope of the
;;; call to with-test-prefix*.  Return the value returned by THUNK.
(define (with-test-prefix* prefix thunk)
  (with-fluids ((prefix-fluid
		 (append (fluid-ref prefix-fluid) (list prefix))))
    (thunk)))

;;; (with-test-prefix PREFIX BODY ...)
;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
;;; The name prefix is only changed within the dynamic scope of the
;;; with-test-prefix expression.  Return the value returned by the last
;;; BODY expression.
(defmacro with-test-prefix (prefix . body)
  `(with-test-prefix* ,prefix (lambda () ,@body)))

;;; Call THUNK using the debugging evaluator.
(define (with-debugging-evaluator* thunk)
  (let ((dopts #f))
    (dynamic-wind
	(lambda ()
	  (set! dopts (debug-options))
	  (debug-enable 'debug))
	thunk
	(lambda ()
	  (debug-options dopts)))))

;;; Evaluate BODY... using the debugging evaluator.
(define-macro (with-debugging-evaluator . body)
  `(with-debugging-evaluator* (lambda () ,@body)))

;;; Call THUNK with a given locale
(define (with-locale* nloc thunk)
  (let ((loc #f))
    (dynamic-wind
	(lambda ()
          (if (defined? 'setlocale)
              (begin
                (set! loc (false-if-exception (setlocale LC_ALL)))
                (if (or (not loc)
                        (not (false-if-exception (setlocale LC_ALL nloc))))
                    (throw 'unresolved)))
              (throw 'unresolved)))
	thunk
	(lambda ()
          (if (and (defined? 'setlocale) loc)
              (setlocale LC_ALL loc))))))

;;; Evaluate BODY... using the given locale.
(define-syntax with-locale
  (syntax-rules ()
    ((_ loc body ...)
     (with-locale* loc (lambda () body ...)))))

;;; Try out several ISO-8859-1 locales and run THUNK under the one that works
;;; (if any).
(define (with-latin1-locale* thunk)
  (define %locales
    (append-map (lambda (name)
                  (list (string-append name ".ISO-8859-1")
                        (string-append name ".iso88591")
                        (string-append name ".ISO8859-1")))
                '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US"
                  "fr_FR" "pt_PT" "nl_NL" "sv_SE")))

  (let loop ((locales %locales))
    (if (null? locales)
        (throw 'unresolved)
        (catch 'unresolved
          (lambda ()
            (with-locale* (car locales) thunk))
          (lambda (key . args)
            (loop (cdr locales)))))))

;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none
;;; was found.
(define-syntax with-latin1-locale
  (syntax-rules ()
    ((_ body ...)
     (with-latin1-locale* (lambda () body ...)))))

;;;; REPORTERS
;;;;

;;; The global list of reporters.
(define reporters '())

;;; The default reporter, to be used only if no others exist.
(define default-reporter #f)

;;; Add the procedure REPORTER to the current set of reporter functions.
;;; Signal an error if that reporter procedure object is already registered.
(define (register-reporter reporter)
  (if (memq reporter reporters)
      (error "register-reporter: reporter already registered: " reporter))
  (set! reporters (cons reporter reporters)))

;;; Remove the procedure REPORTER from the current set of reporter
;;; functions.  Signal an error if REPORTER is not currently registered.
(define (unregister-reporter reporter)
  (if (memq reporter reporters)
      (set! reporters (delq! reporter reporters))
      (error "unregister-reporter: reporter not registered: " reporter)))

;;; Return true iff REPORTER is in the current set of reporter functions.
(define (reporter-registered? reporter)
  (if (memq reporter reporters) #t #f))

;;; Send RESULT to all currently registered reporter functions.
(define (report . args)
  (if (pair? reporters)
      (for-each (lambda (reporter) (apply reporter args))
		reporters)
      (apply default-reporter args)))

;;;; Some useful standard reporters:
;;;; Count reporters count the occurrence of each test result type.
;;;; Log reporters write all test results to a given log file.
;;;; Full reporters write all test results to the standard output.
;;;; User reporters write interesting test results to the standard output.

;;; The complete list of possible test results.
(define result-tags
  '((pass        "PASS"        "passes:                 ")
    (fail        "FAIL"        "failures:               ")
    (upass       "UPASS"       "unexpected passes:      ")
    (xfail       "XFAIL"       "expected failures:      ")
    (unresolved  "UNRESOLVED"  "unresolved test cases:  ")
    (untested    "UNTESTED"    "untested test cases:    ")
    (unsupported "UNSUPPORTED" "unsupported test cases: ")
    (error       "ERROR"       "errors:                 ")))

;;; The list of important test results.
(define important-result-tags
  '(fail upass unresolved error))

;;; Display a single test result in formatted form to the given port
(define (print-result port result name . args)
  (let* ((tag (assq result result-tags))
	 (label (if tag (cadr tag) #f)))
    (if label
	(begin
	  (display label port)
	  (display ": " port)
	  (display (format-test-name name) port)
	  (if (pair? args)
	      (begin
		(display " - arguments: " port)
		(write args port)))
	  (newline port))
	(error "(test-suite lib) FULL-REPORTER: unrecognized result: "
	       result))))

;;; Return a list of the form (COUNTER RESULTS), where:
;;; - COUNTER is a reporter procedure, and
;;; - RESULTS is a procedure taking no arguments which returns the
;;;   results seen so far by COUNTER.  The return value is an alist
;;;   mapping outcome symbols (`pass', `fail', etc.) onto counts.
(define (make-count-reporter)
  (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
    (list
     (lambda (result name . args)
       (let ((pair (assq result counts)))
	 (if pair
	     (set-cdr! pair (+ 1 (cdr pair)))
	     (error "count-reporter: unexpected test result: "
		    (cons result (cons name args))))))
     (lambda ()
       (append counts '())))))

;;; Print a count reporter's results nicely.  Pass this function the value
;;; returned by a count reporter's RESULTS procedure.
(define (print-counts results . port?)
  (let ((port (if (pair? port?)
		  (car port?)
		  (current-output-port))))
    (newline port)
    (display-line-port port "Totals for this test run:")
    (for-each
     (lambda (tag)
       (let ((result (assq (car tag) results)))
	 (if result
	     (display-line-port port (caddr tag) (cdr result))
	     (display-line-port port
				"Test suite bug: "
				"no total available for `" (car tag) "'"))))
     result-tags)
    (newline port)))

;;; Return a reporter procedure which prints all results to the file
;;; FILE, in human-readable form.  FILE may be a filename, or a port.
(define (make-log-reporter file)
  (let ((port (if (output-port? file) file
		  (open-output-file file))))
    (lambda args
      (apply print-result port args)
      (force-output port))))

;;; A reporter that reports all results to the user.
(define (full-reporter . args)
  (apply print-result (current-output-port) args))

;;; A reporter procedure which shows interesting results (failures,
;;; unexpected passes etc.) to the user.
(define (user-reporter result name . args)
  (if (memq result important-result-tags)
      (apply full-reporter result name args)))

(set! default-reporter full-reporter)


code:
/test-conversion
/test-gh
/test-list
/test-num2integral
/test-round
/test-unwind
/test-with-guile-module
/test-use-srfi
/test-scm-with-guile
/test-scm-c-read
/test-fast-slot-ref
/test-scm-take-locale-symbol
/test-scm-take-u8vector
/test-loose-ends
/test-srfi-1


code:
## Process this file with automake to produce Makefile.in.
##
## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Software Foundation, Inc.
##
## This file is part of GUILE.
##
##   GUILE 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, or
##   (at your option) any later version.
##
##   GUILE 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 GUILE; see the file COPYING.LESSER.  If not,
##   write to the Free Software Foundation, Inc., 51 Franklin Street,
##   Fifth Floor, Boston, MA 02110-1301 USA

include $(top_srcdir)/am/snarf

# initializations so we can use += below.
TESTS =
noinst_LTLIBRARIES =
check_PROGRAMS =
check_SCRIPTS =
BUILT_SOURCES =
EXTRA_DIST =

TESTS_ENVIRONMENT =						\
  builddir="$(builddir)"					\
  GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"

## Check for headers in $(srcdir) and bulid dir before $(CPPFLAGS), which
## may point us to an old, installed version of guile.
AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \
	      -I$(top_srcdir)/lib -I$(top_builddir)/lib

test_cflags =					\
  -I$(top_srcdir)/test-suite/standalone -I.	\
  $(EXTRA_DEFS) $(GUILE_CFLAGS) $(GCC_CFLAGS)

AM_LDFLAGS = $(GUILE_CFLAGS)

snarfcppopts =								      \
  -I$(top_srcdir) -I$(top_srcdir)/lib -I$(top_builddir)/lib -I$(top_builddir) \
  -I. $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS)

SUFFIXES = .x
.c.x:
	$(AM_V_SNARF)$(GUILE_SNARF) -o $@ $< $(snarfcppopts)

CLEANFILES = *.x

.DELETE_ON_ERROR:

check_SCRIPTS += test-system-cmds
TESTS += test-system-cmds

check_SCRIPTS += test-bad-identifiers
TESTS += test-bad-identifiers

check_SCRIPTS += test-require-extension
TESTS += test-require-extension

# test-num2integral
test_num2integral_SOURCES = test-num2integral.c
test_num2integral_CFLAGS = ${test_cflags}
test_num2integral_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-num2integral
TESTS += test-num2integral

# test-round
test_round_CFLAGS = ${test_cflags}
test_round_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-round
TESTS += test-round

# test-asmobs
noinst_LTLIBRARIES += libtest-asmobs.la
libtest_asmobs_la_SOURCES = test-asmobs-lib.c
libtest_asmobs_la_CFLAGS = ${test_cflags}
libtest_asmobs_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really build an .so
libtest_asmobs_la_LIBADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
BUILT_SOURCES += test-asmobs-lib.x
check_SCRIPTS += test-asmobs
TESTS += test-asmobs

# test-ffi
noinst_LTLIBRARIES += libtest-ffi.la
libtest_ffi_la_SOURCES = test-ffi-lib.c
libtest_ffi_la_CFLAGS = ${test_cflags}
libtest_ffi_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really build an .so
libtest_ffi_la_LIBADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_SCRIPTS += test-ffi
TESTS += test-ffi

# test-list
test_list_SOURCES = test-list.c
test_list_CFLAGS = ${test_cflags}
test_list_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-list
TESTS += test-list

# test-unwind
test_unwind_SOURCES = test-unwind.c
test_unwind_CFLAGS = ${test_cflags}
test_unwind_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-unwind
TESTS += test-unwind

# test-conversion
test_conversion_SOURCES = test-conversion.c
test_conversion_CFLAGS = ${test_cflags}
test_conversion_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-conversion
TESTS += test-conversion

# test-loose-ends
test_loose_ends_SOURCES = test-loose-ends.c
test_loose_ends_CFLAGS = ${test_cflags}
test_loose_ends_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-loose-ends
TESTS += test-loose-ends

# test-fast-slot-ref
check_SCRIPTS += test-fast-slot-ref
TESTS += test-fast-slot-ref

# test-use-srfi
check_SCRIPTS += test-use-srfi
TESTS += test-use-srfi

# test-scm-c-read
test_scm_c_read_SOURCES = test-scm-c-read.c
test_scm_c_read_CFLAGS = ${test_cflags}
test_scm_c_read_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-scm-c-read
TESTS += test-scm-c-read

# test-scm-take-locale-symbol
test_scm_take_locale_symbol_SOURCES = test-scm-take-locale-symbol.c
test_scm_take_locale_symbol_CFLAGS = ${test_cflags}
test_scm_take_locale_symbol_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-scm-take-locale-symbol
TESTS += test-scm-take-locale-symbol

# test-scm-take-u8vector
test_scm_take_u8vector_SOURCES = test-scm-take-u8vector.c
test_scm_take_u8vector_CFLAGS = ${test_cflags}
test_scm_take_u8vector_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-scm-take-u8vector
TESTS += test-scm-take-u8vector

# test-extensions
noinst_LTLIBRARIES += libtest-extensions.la
libtest_extensions_la_SOURCES = test-extensions-lib.c
libtest_extensions_la_CFLAGS = ${test_cflags}
libtest_extensions_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really build an .so
libtest_extensions_la_LIBADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_SCRIPTS += test-extensions
TESTS += test-extensions

# test-srfi-1
test_srfi_1_SOURCES = test-srfi-1.c
test_srfi_1_CFLAGS = ${test_cflags}
test_srfi_1_LDADD =	\
  ${top_builddir}/srfi/libguile-srfi-srfi-1-v-@LIBGUILE_SRFI_SRFI_1_MAJOR@.la
check_PROGRAMS += test-srfi-1
TESTS += test-srfi-1

if BUILD_PTHREAD_SUPPORT

# test-with-guile-module
test_with_guile_module_CFLAGS = ${test_cflags}
test_with_guile_module_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-with-guile-module
TESTS += test-with-guile-module

test_scm_with_guile_CFLAGS = ${test_cflags}
test_scm_with_guile_LDADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la
check_PROGRAMS += test-scm-with-guile
TESTS += test-scm-with-guile

else

EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c

endif

EXTRA_DIST += ${check_SCRIPTS}


code:
-*-text-*-

These tests use the standard automake TESTS mechanism.  Tests should
be listed in TESTS in Makefile.am, and should exit with 0 on success,
non-zero on failure, and 77 if the result should be ignored.  See the
automake info pages for more information.

If you want to use a scheme script, prefix it as follows:

  #!/bin/sh
  exec guile -s "$0" "$@"
  !#

Makefile.am will arrange for all tests (scripts or executables) to be
run under uninstalled-env so that the PATH, LD_LIBRARY_PATH, and
GUILE_LOAD_PATH will be augmented appropriately.

The Makefile.am has an example of creating a shared library to be used
from a test scheme script as well.

You can also create standalone executables that include your own code,
are linked against libguile, and that run a given test script (or
scripts).  One way to do this is to create the binary, make sure it
calls scm_shell (argc, argv) as its final action, and put this bit at
the top of your test script:

  #!./my-test-binary -s
  !#

path: test-suite/standalone/README


code:
#!/bin/sh
exec guile -q -s "$0" "$@"
!#

(load-extension (string-append (getenv "builddir") "/libtest-asmobs")
                "libtest_asmobs_init")

(define (test x v)
  (if v
      (if (not (equal? (eval x (current-module)) v))
	  (error "Wrong return value" x))
      (catch #t
	     (lambda ()
	       (begin (eval x (current-module))
		      (throw 'should-be-error)))
	     (lambda (key . args)
	       (if (eq? key 'should-be-error)
		   (error "Should be error" x))))))

(define asmob000 (make-asmob000))
(test '(asmob000) '())
(test '(asmob000 1) #f)
(test '(asmob000 1 2) #f)
(test '(asmob000 1 2 3) #f)

(define asmob100 (make-asmob100))
(test '(asmob100) #f)
(test '(asmob100 1) '(1))
(test '(asmob100 1 2) #f)
(test '(asmob100 1 2 3) #f)

(define asmob010 (make-asmob010))
(test '(asmob010) '(#f))
(test '(asmob010 1) '(1))
(test '(asmob010 1 2) #f)
(test '(asmob010 1 2 3) #f)

(define asmob001 (make-asmob001))
(test '(asmob001) '(()))
(test '(asmob001 1) '((1)))
(test '(asmob001 1 2) '((1 2)))
(test '(asmob001 1 2 3) '((1 2 3)))

(define asmob200 (make-asmob200))
(test '(asmob200) #f)
(test '(asmob200 1) #f)
(test '(asmob200 1 2) '(1 2))
(test '(asmob200 1 2 3) #f)

(define asmob110 (make-asmob110))
(test '(asmob110) #f)
(test '(asmob110 1) '(1 #f))
(test '(asmob110 1 2) '(1 2))
(test '(asmob110 1 2 3) #f)

(define asmob020 (make-asmob020))
(test '(asmob020) '(#f #f))
(test '(asmob020 1) '(1 #f))
(test '(asmob020 1 2) '(1 2))
(test '(asmob020 1 2 3) #f)

(define asmob101 (make-asmob101))
(test '(asmob101) #f)
(test '(asmob101 1) '(1 ()))
(test '(asmob101 1 2) '(1 (2)))
(test '(asmob101 1 2 3) '(1 (2 3)))

(define asmob011 (make-asmob011))
(test '(asmob011) '(#f ()))
(test '(asmob011 1) '(1 ()))
(test '(asmob011 1 2) '(1 (2)))
(test '(asmob011 1 2 3) '(1 (2 3)))

(define asmob300 (make-asmob300))
(test '(asmob300) #f)
(test '(asmob300 1) #f)
(test '(asmob300 1 2) #f)
(test '(asmob300 1 2 3) '(1 2 3))

(define asmob210 (make-asmob210))
(test '(asmob210) #f)
(test '(asmob210 1) #f)
(test '(asmob210 1 2) '(1 2 #f))
(test '(asmob210 1 2 3) '(1 2 3))

(define asmob120 (make-asmob120))
(test '(asmob120) #f)
(test '(asmob120 1) '(1 #f #f))
(test '(asmob120 1 2) '(1 2 #f))
(test '(asmob120 1 2 3) '(1 2 3))

(define asmob030 (make-asmob030))
(test '(asmob030) '(#f #f #f))
(test '(asmob030 1) '(1 #f #f))
(test '(asmob030 1 2) '(1 2 #f))
(test '(asmob030 1 2 3) '(1 2 3))

(define asmob201 (make-asmob201))
(test '(asmob201) #f)
(test '(asmob201 1) #f)
(test '(asmob201 1 2) '(1 2 ()))
(test '(asmob201 1 2 3) '(1 2 (3)))

(define asmob021 (make-asmob021))
(test '(asmob021) '(#f #f ()))
(test '(asmob021 1) '(1 #f ()))
(test '(asmob021 1 2) '(1 2 ()))
(test '(asmob021 1 2 3) '(1 2 (3)))

(define asmob111 (make-asmob111))
(test '(asmob111) #f)
(test '(asmob111 1) '(1 #f ()))
(test '(asmob111 1 2) '(1 2 ()))
(test '(asmob111 1 2 3) '(1 2 (3)))

;; Local Variables:
;; mode: scheme
;; End:

path: test-suite/standalone/test-asmobs


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

#ifndef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>

long asmob000;
long asmob100;
long asmob010;
long asmob001;
long asmob200;
long asmob110;
long asmob020;
long asmob101;
long asmob011;
long asmob300;
long asmob210;
long asmob120;
long asmob030;
long asmob201;
long asmob021;
long asmob111;

/* since we don't have SCM_DEFINE_STATIC or similar */
SCM scm_make_asmob000 (void);
SCM scm_make_asmob001 (void);
SCM scm_make_asmob010 (void);
SCM scm_make_asmob011 (void);
SCM scm_make_asmob100 (void);
SCM scm_make_asmob101 (void);
SCM scm_make_asmob110 (void);
SCM scm_make_asmob111 (void);
SCM scm_make_asmob120 (void);
SCM scm_make_asmob020 (void);
SCM scm_make_asmob021 (void);
SCM scm_make_asmob200 (void);
SCM scm_make_asmob201 (void);
SCM scm_make_asmob210 (void);
SCM scm_make_asmob030 (void);
SCM scm_make_asmob300 (void);

SCM_DEFINE (scm_make_asmob000, "make-asmob000", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob000, 0);
}

SCM_DEFINE (scm_make_asmob100, "make-asmob100", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob100, 0);
}

SCM_DEFINE (scm_make_asmob010, "make-asmob010", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob010, 0);
}

SCM_DEFINE (scm_make_asmob001, "make-asmob001", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob001, 0);
}

SCM_DEFINE (scm_make_asmob200, "make-asmob200", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob200, 0);
}

SCM_DEFINE (scm_make_asmob110, "make-asmob110", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob110, 0);
}

SCM_DEFINE (scm_make_asmob020, "make-asmob020", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob020, 0);
}

SCM_DEFINE (scm_make_asmob101, "make-asmob101", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob101, 0);
}

SCM_DEFINE (scm_make_asmob011, "make-asmob011", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob011, 0);
}

SCM_DEFINE (scm_make_asmob300, "make-asmob300", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob300, 0);
}

SCM_DEFINE (scm_make_asmob210, "make-asmob210", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob210, 0);
}

SCM_DEFINE (scm_make_asmob120, "make-asmob120", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob120, 0);
}

SCM_DEFINE (scm_make_asmob030, "make-asmob030", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob030, 0);
}

SCM_DEFINE (scm_make_asmob201, "make-asmob201", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob201, 0);
}

SCM_DEFINE (scm_make_asmob021, "make-asmob021", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob021, 0);
}

SCM_DEFINE (scm_make_asmob111, "make-asmob111", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob111, 0);
}

static SCM
apply0 (SCM smob)
{
  return SCM_EOL;
}

static SCM
apply1 (SCM smob, SCM a1)
{
  if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
  return scm_list_1 (a1);
}

static SCM
apply2 (SCM smob, SCM a1, SCM a2)
{
  if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
  if (SCM_UNBNDP (a2)) a2 = SCM_BOOL_F;
  return scm_list_2 (a1, a2);
}

static SCM
apply3 (SCM smob, SCM a1, SCM a2, SCM rest)
{
  if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
  if (SCM_UNBNDP (a2)) a2 = SCM_BOOL_F;
  if (SCM_UNBNDP (rest)) rest = SCM_BOOL_F;
  return scm_list_3 (a1, a2, rest);
}

void libtest_asmobs_init (void);

void
libtest_asmobs_init ()
{
  asmob000 = scm_make_smob_type ("asmob000", 0);
  scm_set_smob_apply (asmob000, apply0, 0, 0, 0);
  asmob100 = scm_make_smob_type ("asmob100", 0);
  scm_set_smob_apply (asmob100, apply1, 1, 0, 0);
  asmob010 = scm_make_smob_type ("asmob010", 0);
  scm_set_smob_apply (asmob010, apply1, 0, 1, 0);
  asmob001 = scm_make_smob_type ("asmob001", 0);
  scm_set_smob_apply (asmob001, apply1, 0, 0, 1);
  asmob200 = scm_make_smob_type ("asmob200", 0);
  scm_set_smob_apply (asmob200, apply2, 2, 0, 0);
  asmob110 = scm_make_smob_type ("asmob110", 0);
  scm_set_smob_apply (asmob110, apply2, 1, 1, 0);
  asmob020 = scm_make_smob_type ("asmob020", 0);
  scm_set_smob_apply (asmob020, apply2, 0, 2, 0);
  asmob101 = scm_make_smob_type ("asmob101", 0);
  scm_set_smob_apply (asmob101, apply2, 1, 0, 1);
  asmob011 = scm_make_smob_type ("asmob011", 0);
  scm_set_smob_apply (asmob011, apply2, 0, 1, 1);
  asmob300 = scm_make_smob_type ("asmob300", 0);
  scm_set_smob_apply (asmob300, apply3, 3, 0, 0);
  asmob210 = scm_make_smob_type ("asmob210", 0);
  scm_set_smob_apply (asmob210, apply3, 2, 1, 0);
  asmob120 = scm_make_smob_type ("asmob120", 0);
  scm_set_smob_apply (asmob120, apply3, 1, 2, 0);
  asmob030 = scm_make_smob_type ("asmob030", 0);
  scm_set_smob_apply (asmob030, apply3, 0, 3, 0);
  asmob201 = scm_make_smob_type ("asmob201", 0);
  scm_set_smob_apply (asmob201, apply3, 2, 0, 1);
  asmob021 = scm_make_smob_type ("asmob021", 0);
  scm_set_smob_apply (asmob021, apply3, 0, 2, 1);
  asmob111 = scm_make_smob_type ("asmob111", 0);
  scm_set_smob_apply (asmob111, apply3, 1, 1, 1);
# include "test-asmobs-lib.x"
}


code:
#!/bin/sh
exec guile -q -s "$0" "$@"
!#

;; The use of certain identifiers as variable or parameter names has
;; been found to cause build problems on particular platforms.  The
;; aim of this test is to cause "make check" to fail (on GNU/Linux,
;; which most Guile developers use) if we accidentally add new code
;; that uses those identifiers.

(define bad-identifiers
  '(
    ;; On AIX 5.2 and 5.3, /usr/include/sys/timer.h includes:
    ;;	 #ifndef  _LINUX_SOURCE_COMPAT
    ;;	 #define func_data       t_union.data
    ;;	 #endif
    ;; So we want to avoid using func_data in Guile source code.
    "func_data"

    ;; More troublesome identifiers can be added into the list here.
    ))

(use-modules (ice-9 regex) (ice-9 rdelim))

(define bad-id-regexp
  (make-regexp (string-append "\\<("
			      (string-join (map regexp-quote bad-identifiers) "|")
			      ")\\>")))

(define exit-status 0)

;; Non-exported code from (ice-9 ftw).
(define (directory-files dir)
  (let ((dir-stream (opendir dir)))
    (let loop ((new (readdir dir-stream))
               (acc '()))
      (if (eof-object? new)
	  (begin
	    (closedir dir-stream)
	    acc)
          (loop (readdir dir-stream)
                (if (or (string=? "."  new)             ;;; ignore
                        (string=? ".." new))            ;;; ignore
                    acc
                    (cons (in-vicinity dir new) acc)))))))

(define (directory-files-matching dir pattern)
  (let ((file-name-regexp (make-regexp pattern)))
    (filter (lambda (fn)
	      (regexp-exec file-name-regexp fn))
	    (directory-files dir))))

(let loop ((file-names (directory-files-matching "../../libguile"
						 "\\.[ch]$")))
  (or (null? file-names)
      (begin
	(with-input-from-file (car file-names)
	  (lambda ()
	    (let loop ((linenum 1) (line (read-line)))
	      (or (eof-object? line)
		  (begin
		    (if (regexp-exec bad-id-regexp line)
			(begin
			  (set! exit-status 1)
			  (format (current-error-port)
				  "~a:~a: ~a\n"
				  (car file-names)
				  linenum
				  line)))
		    (loop (+ linenum 1) (read-line)))))))
	(loop (cdr file-names)))))

(exit exit-status)

;; Local Variables:
;; mode: scheme
;; End: