mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
88 lines
1.7 KiB
Scheme
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)
|
|
|