test-suite/lalr/common-test.scm

   1 ;;; common-test.scm --
   2 ;;;
   3
   4 ;; Slightly modified for Guile by Ludovic Courtès <ludo@gnu.org>, 2010.
   5
   6 (use-modules (system base lalr)
   7              (ice-9 pretty-print))
   8
   9 (define *error* '())
  10
  11 (define-syntax check
  12   (syntax-rules (=>)
  13     ((_ ?expr => ?expected-result)
  14      (check ?expr (=> equal?) ?expected-result))
  15
  16     ((_ ?expr (=> ?equal) ?expected-result)
  17      (let ((result      ?expr)
  18            (expected    ?expected-result))
  19        (set! *error* '())
  20        (when (not (?equal result expected))
  21          (display "Failed test: \n")
  22          (pretty-print (quote ?expr))(newline)
  23          (display "\tresult was: ")
  24          (pretty-print result)(newline)
  25          (display "\texpected: ")
  26          (pretty-print expected)(newline)
  27          (exit 1))))))
  28
  29 ;;; --------------------------------------------------------------------
  30
  31 (define (display-result v)
  32   (if v
  33       (begin
  34         (display "==> ")
  35         (display v)
  36         (newline))))
  37
  38 (define eoi-token
  39   (make-lexical-token '*eoi* #f #f))
  40
  41 (define (make-lexer tokens)
  42   (lambda ()
  43     (if (null? tokens)
  44         eoi-token
  45       (let ((t (car tokens)))
  46         (set! tokens (cdr tokens))
  47         t))))
  48
  49 (define (error-handler message . args)
  50   (set! *error* (cons `(error-handler ,message . ,(if (pair? args)
  51                                                       (lexical-token-category (car args))
  52                                                     '()))
  53                       *error*))
  54   (cons message args))
  55
  56 ;;; end of file