1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
guile/test-suite/lalr/glr-test.scm
Ludovic Courtès 1b10152215 Add Boucher's lalr-scm' as the (system base lalr)' module.
Taken from r51 of <http://lalr-scm.googlecode.com/svn/trunk>.

* module/Makefile.am (SYSTEM_BASE_SOURCES): Add `system/base/lalr.scm'.
  (NOCOMP_SOURCES): Add `system/base/lalr.upstream.scm'.

* module/system/base/lalr.scm, module/system/base/lalr.upstream.scm: New
  files.

* test-suite/Makefile.am (LALR_TESTS, LALR_EXTRA, TESTS,
  TESTS_ENVIRONMENT): New variables.
  (EXTRA_DIST): Add $(LALR_EXTRA).

* test-suite/lalr/common-test.scm,
  test-suite/lalr/glr-test.scm,
  test-suite/lalr/test-glr-associativity.scm,
  test-suite/lalr/test-glr-basics-01.scm,
  test-suite/lalr/test-glr-basics-02.scm,
  test-suite/lalr/test-glr-basics-03.scm,
  test-suite/lalr/test-glr-basics-04.scm,
  test-suite/lalr/test-glr-basics-05.scm,
  test-suite/lalr/test-glr-script-expression.scm,
  test-suite/lalr/test-glr-single-expressions.scm,
  test-suite/lalr/test-lr-associativity-01.scm,
  test-suite/lalr/test-lr-associativity-02.scm,
  test-suite/lalr/test-lr-associativity-03.scm,
  test-suite/lalr/test-lr-associativity-04.scm,
  test-suite/lalr/test-lr-basics-01.scm,
  test-suite/lalr/test-lr-basics-02.scm,
  test-suite/lalr/test-lr-basics-03.scm,
  test-suite/lalr/test-lr-basics-04.scm,
  test-suite/lalr/test-lr-basics-05.scm,
  test-suite/lalr/test-lr-error-recovery-01.scm,
  test-suite/lalr/test-lr-error-recovery-02.scm,
  test-suite/lalr/test-lr-no-clause.scm,
  test-suite/lalr/test-lr-script-expression.scm,
  test-suite/lalr/test-lr-single-expressions.scm: New files.
2010-03-31 00:41:59 +02:00

88 lines
1.7 KiB
Scheme

":";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)