Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
268 lines (229 sloc) 9.457 kb
; Copyright (c) 2005-2009 by Juliusz Chroboczek
; Permission is hereby granted, free of charge, to any person obtaining a copy
; of this software and associated documentation files (the "Software"), to deal
; in the Software without restriction, including without limitation the rights
; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
; copies of the Software, and to permit persons to whom the Software is
; furnished to do so, subject to the following conditions:
; The above copyright notice and this permission notice shall be included in
; all copies or substantial portions of the Software.
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
; THE SOFTWARE.
(defpackage #:yacc-tests
(:export tests)
(:use #:cl #:yacc))
(in-package #:yacc-tests)
(defmacro expect (form expected)
(let ((value (gensym "VALUE")) (e-value (gensym "EXPECTED")))
`(let ((,value ,form) (,e-value ,expected))
(unless (equal ,value ,e-value)
(error "Test failed: ~S yielded ~S, expected ~S"
',form ,value ,e-value)))))
(defmacro expect-condition (class &body body)
(let ((name (gensym "EXPECT-CONDITION")))
`(block ,name
(handler-case (progn ,@body)
(,class () (return-from ,name nil)))
(error "~S didn't signal a ~S" ',body ',class))))
;;;; Tests of the low-level interface, which is not meant for human beings.
;;;; See the high-level interface below if you are looking for examples.
;;; A trivial lexer
(defun list-lexer (list)
#'(lambda ()
(let ((x (pop list)))
(values x x))))
;;; A few grammars from the Dragon book
(defun make-grammar-4-31 ()
(make-grammar :terminals '(+ * id lb rb)
:start-symbol 'e
:productions
(list (make-production 'e '(e + tt))
(make-production 'e '(tt) :action #'identity)
(make-production 'tt '(tt * f))
(make-production 'tt '(f) :action #'identity)
(make-production 'f '(lb e rb))
(make-production 'f '(id) :action #'identity))))
;; This grammar is LALR(1) but not SLR
(defun make-grammar-4-20 ()
(make-grammar :terminals '(id * =)
:start-symbol 's
:productions
(list (make-production 's '(l = r))
(make-production 's '(r))
(make-production 'l '(* r))
(make-production 'l '(id))
(make-production 'r '(l)))))
(defun make-grammar-4-21 ()
(make-grammar :terminals '(c d)
:start-symbol 's
:productions
(list (make-production 's '(cc cc))
(make-production 'cc '(c cc))
(make-production 'cc '(d)))))
;;; Epsilon-reductions on the left and right side
(defun make-grammar-epsilon-left ()
(make-grammar :terminals '(id)
:start-symbol 's
:productions
(list (make-production 's '())
(make-production 's '(s id)))))
(defun make-grammar-epsilon-right ()
(make-grammar :terminals '(id)
:start-symbol 's
:productions
(list (make-production 's '())
(make-production 's '(id s)))))
(defun tests-low ()
(let ((parser-4-31 (make-parser (make-grammar-4-31)))
(parser-4-20 (make-parser (make-grammar-4-20)))
(parser-4-21 (make-parser (make-grammar-4-21)))
(parser-epsilon-left (make-parser (make-grammar-epsilon-left)))
(parser-epsilon-right (make-parser (make-grammar-epsilon-right))))
(flet ((parse (parser list) (parse-with-lexer (list-lexer list) parser)))
(expect (parse parser-4-31 '(lb id + id * id rb))
'(lb (id + (id * id)) rb))
(expect (parse parser-4-31 '(lb id * id + id rb))
'(lb ((id * id) + id) rb))
(expect (parse parser-4-20 '(* id = * * id))
'((* ((id))) = ((* ((* ((id))))))))
(expect (parse parser-4-21 '(c d c d))
'((c (d)) (c (d))))
(expect (parse parser-epsilon-left '()) '())
(expect (parse parser-epsilon-left '(id)) '(nil id))
(expect (parse parser-epsilon-left '(id id)) '((nil id) id))
(expect (parse parser-epsilon-right '()) '())
(expect (parse parser-epsilon-right '(id)) '(id nil))
(expect (parse parser-epsilon-right '(id id)) '(id (id nil)))
t)))
;;;; Tests of the high-level interface
(defun digitp (c) (member c '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0)))
(defun simple-lexer (stream)
(let ((c (read-char stream nil nil)))
(cond
((null c) (values nil nil))
((member c '(#\Space #\Tab #\Newline)) (simple-lexer stream))
((member c '(#\+ #\- #\* #\/ #\( #\)))
(let ((v (intern (string c))))
(values v v)))
((digitp c)
(let ((buffer (make-array 10 :element-type 'character
:fill-pointer 0)))
(do ((c c (read-char stream nil nil)))
((or (null c) (not (digitp c)))
(unless (null c) (unread-char c stream))
(values 'int (read-from-string buffer)))
(vector-push-extend c buffer))))
((alpha-char-p c)
(let ((buffer (make-array 10 :element-type 'character
:fill-pointer 0)))
(do ((c c (read-char stream nil nil)))
((or (null c) (not (alphanumericp c)))
(unless (null c) (unread-char c stream))
(values 'id (copy-seq buffer)))
(vector-push-extend c buffer))))
(t (error "Lexing error")))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun k-2-3 (a b c) (declare (ignore a c)) b)
)
(define-parser *left-expression-parser*
(:start-symbol expression)
(:terminals (int id + - * / |(| |)|))
(expression
(expression + term)
(expression - term)
term)
(term
(term * factor)
(term / factor)
factor)
(factor
id
int
(|(| expression |)| #'k-2-3)))
(define-parser *ambiguous-expression-parser*
(:start-symbol expression)
(:terminals (int id + - * / |(| |)|))
(:muffle-conflicts (16 0))
(expression
(expression + expression)
(expression - expression)
(expression * expression)
(expression / expression)
id
int
(|(| expression |)| #'k-2-3)))
(define-parser *precedence-left-expression-parser*
(:start-symbol expression)
(:terminals (int id + - * / |(| |)|))
(:precedence ((:left * /) (:left + -)))
(expression
(expression + expression)
(expression - expression)
(expression * expression)
(expression / expression)
id
int
(|(| expression |)| #'k-2-3)))
(define-parser *precedence-right-expression-parser*
(:start-symbol expression)
(:terminals (int id + - * / |(| |)|))
(:precedence ((:right * /) (:right + -)))
(expression
(expression + expression)
(expression - expression)
(expression * expression)
(expression / expression)
id
int
(|(| expression |)| #'k-2-3)))
(define-parser *precedence-nonassoc-expression-parser*
(:start-symbol expression)
(:terminals (int id + - * / |(| |)|))
(:precedence ((:nonassoc * /) (:nonassoc + -)))
(expression
(expression + expression)
(expression - expression)
(expression * expression)
(expression / expression)
id
int
(|(| expression |)| #'k-2-3)))
(defun tests-hi ()
(flet ((parse (parser e)
(with-input-from-string (s e)
(parse-with-lexer #'(lambda () (simple-lexer s)) parser))))
(let ((*package* (find-package '#:yacc-tests)))
(let ((e "(x+3)+y*z") (v '(("x" + 3) + ("y" * "z"))))
(expect (parse *left-expression-parser* e) v)
(expect (parse *precedence-left-expression-parser* e) v)
(expect (parse *precedence-right-expression-parser* e) v)
(expect (parse *precedence-nonassoc-expression-parser* e) v))
(let ((e "x+5/3*(12+y)/3+z"))
(let ((v '(("x" + (((5 / 3) * (12 + "y")) / 3)) + "z")))
(expect (parse *left-expression-parser* e) v)
(expect (parse *precedence-left-expression-parser* e) v))
(let ((v '("x" + ((5 / (3 * ((12 + "y") / 3))) + "z"))))
(expect (parse *precedence-right-expression-parser* e) v))
(let ((v '("x" + (5 / (3 * ((12 + "y") / (3 + "z")))))))
(expect (parse *ambiguous-expression-parser* e) v))
(expect-condition yacc-parse-error
(parse *precedence-nonassoc-expression-parser* e)))
(dolist (e '("5/3*(" "5/3)"))
(expect-condition yacc-parse-error
(parse *left-expression-parser* e))
(expect-condition yacc-parse-error
(parse *ambiguous-expression-parser* e))
(expect-condition yacc-parse-error
(parse *precedence-left-expression-parser* e))
(expect-condition yacc-parse-error
(parse *precedence-right-expression-parser* e)))))
t)
(defun tests ()
(tests-low)
(tests-hi)
t)
Jump to Line
Something went wrong with that request. Please try again.