From bfb1d31493e824ae802675bc4bc4a5f898a9dfd5 Mon Sep 17 00:00:00 2001 From: "Mike D. Lowis" Date: Wed, 18 Jul 2012 16:18:26 -0400 Subject: [PATCH] Added tests for core forms and cleaned up some existing functions --- source/parse-utils.scm | 9 +++ source/parser.scm | 26 +++++--- tests/test_parser.scm | 141 +++++++++++++++++++++++++++++++++++++++-- 3 files changed, 161 insertions(+), 15 deletions(-) diff --git a/source/parse-utils.scm b/source/parse-utils.scm index 0d29e3d..4a7e60d 100644 --- a/source/parse-utils.scm +++ b/source/parse-utils.scm @@ -53,6 +53,15 @@ (and (not (eof-object? actual)) (equal? expect (token-type actual)))) +(define (keyword-match buf expect) + (define actual (buf-lookahead! buf 1)) + (if (and (token-matches? buf 'id) + (equal? expect (token-text actual))) + (buf-consume! buf) + (error + (string-append + "Expected '" expect "', received '" (token-text actual) "' instead")))) + (define (token->syntree tok) (syntree (token-type tok) (token-text tok) '())) diff --git a/source/parser.scm b/source/parser.scm index ab431ff..161b989 100644 --- a/source/parser.scm +++ b/source/parser.scm @@ -34,8 +34,8 @@ (append result (list (dlang/expression in))))) (define (dlang/expression in) - (if (core-form? in) - (core-form in) + (if (dlang/core-form? in) + (dlang/core-form in) (let ((result (dlang/basic-expr in))) (if (equal? 'lpar (buf-lookahead! in 1)) (begin @@ -54,13 +54,18 @@ (("begin") (dlang/begin in)) (("func") (dlang/func in)))) -(define (core-form? in) #f) +(define (dlang/core-form? in) #f) + ;(define tok (buf-lookahead! in 1)) + ;(cond (token-text tok) + ; (("def" "set!" "if" "begin" "func") #t) + ; (else #f))) (define (dlang/define in) (define node '()) (keyword-match in "def") (set! node - (syntree 'define "" (list (token-match in 'id) (dlang/expression in)))) + (syntree 'define "" + (list (token->syntree (token-match in 'id)) (dlang/expression in)))) (token-match in 'term) node) @@ -68,7 +73,8 @@ (define node '()) (keyword-match in "set!") (set! node - (syntree 'set "" (list (token-match in 'id) (dlang/expression in)))) + (syntree 'assign "" + (list (token->syntree (token-match in 'id)) (dlang/expression in)))) (token-match in 'term) node) @@ -86,15 +92,17 @@ (define (dlang/begin in) (define node '()) (keyword-match in "begin") - (set! node (dlang/block! in)) - (token-match 'term) + (set! node (dlang/expr-block in 'term)) + (token-match in 'term) + (syntree-type-set! node 'begin) node) (define (dlang/func in) (define node (syntree 'func "" '())) (keyword-match in "func") - (syntree-children-set! node (list (dlang/id-list in) (dlang/expr-block))) + (syntree-children-set! node (list (dlang/id-list in) (dlang/expr-block in 'term))) (token-match in 'term) + (syntree-type-set! node 'func) node) (define (dlang/basic-expr in) @@ -152,7 +160,7 @@ (define (dlang/expr-block in term) (define tree (syntree 'block "" '())) (define chldrn '()) - (while (equal? term (token-type (buf-lookahead! in 1))) + (while (not (token-matches? in term)) (set! chldrn (append chldrn (list (dlang/expression in))))) (syntree-children-set! tree chldrn) tree) diff --git a/tests/test_parser.scm b/tests/test_parser.scm index 92ad46f..65ccb44 100644 --- a/tests/test_parser.scm +++ b/tests/test_parser.scm @@ -12,30 +12,159 @@ ; dlang/expression ;------------------------------------------------------------------------------ -(def-test "dlang/expression should parse a literal" - (call-with-input-string "abc" - (lambda (input) - (define lxr (make-lexer input)) - (define result (dlang/expression lxr)) - (syntree=? result (syntree 'id "abc" '()))))) ; dlang/core-form ;------------------------------------------------------------------------------ ; dlang/define ;------------------------------------------------------------------------------ +(def-test "dlang/define should parse a variable definition" + (call-with-input-string "def foo 1.0;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/define lxr)) + (syntree=? result + (syntree 'define "" + (list + (syntree 'id "foo" '()) + (syntree 'number "1.0" '()))))))) ; dlang/assign ;------------------------------------------------------------------------------ +(def-test "dlang/assign should parse a variable definition" + (call-with-input-string "set! foo 1.0;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/assign lxr)) + (syntree=? result + (syntree 'assign "" + (list + (syntree 'id "foo" '()) + (syntree 'number "1.0" '()))))))) ; dlang/if ;------------------------------------------------------------------------------ +(def-test "dlang/if should parse an if statement with one branch" + (call-with-input-string "if cond result1;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/if lxr)) + (syntree=? result + (syntree 'if "" + (list + (syntree 'id "cond" '()) + (syntree 'id "result1" '()))))))) + +(def-test "dlang/if should parse an if statement with two branches" + (call-with-input-string "if cond result1 result2;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/if lxr)) + (syntree=? result + (syntree 'if "" + (list + (syntree 'id "cond" '()) + (syntree 'id "result1" '()) + (syntree 'id "result2" '()))))))) ; dlang/begin ;------------------------------------------------------------------------------ +(def-test "dlang/begin should parse a begin block with 0 expressions" + (call-with-input-string "begin;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/begin lxr)) + (syntree=? result + (syntree 'begin "" '()))))) + +(def-test "dlang/begin should parse a begin block with 1 expression" + (call-with-input-string "begin stm1;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/begin lxr)) + (syntree=? result + (syntree 'begin "" + (list + (syntree 'id "stm1" '()))))))) + +(def-test "dlang/begin should parse a begin block with 2 expressions" + (call-with-input-string "begin stm1 stm2;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/begin lxr)) + (syntree=? result + (syntree 'begin "" + (list + (syntree 'id "stm1" '()) + (syntree 'id "stm2" '()))))))) ; dlang/func ;------------------------------------------------------------------------------ +(def-test "dlang/func should parse an empty func" + (call-with-input-string "func();" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/func lxr)) + (syntree=? result + (syntree 'func "" + (list + (syntree 'args "" '()) + (syntree 'block "" '()))))))) + +(def-test "dlang/func should parse a func with one statement in the body" + (call-with-input-string "func() stm1;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/func lxr)) + (syntree=? result + (syntree 'func "" + (list + (syntree 'args "" '()) + (syntree 'block "" + (list + (syntree 'id "stm1" '()))))))))) + +(def-test "dlang/func should parse a func with two statements in the body" + (call-with-input-string "func() stm1 stm2;" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/func lxr)) + (syntree=? result + (syntree 'func "" + (list + (syntree 'args "" '()) + (syntree 'block "" + (list + (syntree 'id "stm1" '()) + (syntree 'id "stm2" '()))))))))) + +(def-test "dlang/func should parse a func with one param" + (call-with-input-string "func(a);" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/func lxr)) + (syntree=? result + (syntree 'func "" + (list + (syntree 'args "" + (list + (syntree 'id "a" '()) + )) + (syntree 'block "" '()))))))) + +(def-test "dlang/func should parse a func with two params" + (call-with-input-string "func(a,b);" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/func lxr)) + (syntree=? result + (syntree 'func "" + (list + (syntree 'args "" + (list + (syntree 'id "a" '()) + (syntree 'id "b" '()))) + (syntree 'block "" '()))))))) ; dlang/basic-expr ;------------------------------------------------------------------------------ -- 2.54.0