From 4102d7c5a94f3ba0d491599aaa0d4d9b9bd8a16a Mon Sep 17 00:00:00 2001 From: "Michael D. Lowis" Date: Sat, 14 Jul 2012 02:54:37 -0400 Subject: [PATCH] Added tests for id-list --- source/parse-utils.scm | 8 +++ source/parser.scm | 78 +++++++++++++++++++++++------ tests/test_parser.scm | 110 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 182 insertions(+), 14 deletions(-) diff --git a/source/parse-utils.scm b/source/parse-utils.scm index 528d855..4de12f3 100644 --- a/source/parse-utils.scm +++ b/source/parse-utils.scm @@ -32,3 +32,11 @@ " received '" (symbol->string (token-type actual)) " instead")))) actual) +(define (token-matches? buf expect) + (define actual (buf-lookahead! buf 1)) + (and (not (eof-object? actual)) + (equal? expect (token-type actual)))) + +(define (token->syntree tok) + (syntree (token-type tok) (token-text tok) '())) + diff --git a/source/parser.scm b/source/parser.scm index 6816f3f..3a48f73 100644 --- a/source/parser.scm +++ b/source/parser.scm @@ -1,3 +1,4 @@ +(include "loop.scm") (declare (unit parser) (uses buf)) @@ -7,12 +8,11 @@ ; Program := Expression* ; ; Expression := CoreForm -; | BasicExpr -; | BasicExpr ArgList +; | BasicExpr (ArgList)? ; ; CoreForm := 'def' ID Expression TERM ; | 'set!' ID Expression TERM -; | 'if' Expression Expression Expression TERM +; | 'if' Expression Expression (Expression)? TERM ; | 'begin' ExpBlock TERM ; | 'func' IdList ExpBlock TERM ; @@ -25,11 +25,9 @@ ; ; IdList := '(' ID (',' ID)* ')' ; -; ExpBlock := Expression* +; ExpBlock := (Expression)* ;------------------------------------------------------------------------------ -(define (core-form? in) #f) - (define (dlang/program in) (define result '()) (while (not (eof-object? (buf-lookahead! in 1))) @@ -47,7 +45,57 @@ (match in 'rpar))) ret))) -(define (dlang/core-form in) '()) +(define (dlang/core-form in) + (define tok (buf-lookahead! in 1)) + (cond (token-text tok) + (("def") (dlang/define in)) + (("set!") (dlang/assign in)) + (("if") (dlang/if in)) + (("begin") (dlang/begin in)) + (("func") (dlang/func in)))) + +(define (core-form? in) #f) + +(define (dlang/define in) + (define node '()) + (keyword-match in "def") + (set! node + (syntree 'define "" (list (token-match in 'id) (dlang/expression in)))) + (token-match in 'term) + node) + +(define (dlang/assign in) + (define node '()) + (keyword-match in "set!") + (set! node + (syntree 'set "" (list (token-match in 'id) (dlang/expression in)))) + (token-match in 'term) + node) + +(define (dlang/if in) + (define node '()) + (keyword-match in "if") + (set! node + (syntree 'if "" (list (dlang/expression in) (dlang/expression in)))) + (if (not (token-matches? in 'term)) + (syntree-children-set! node + (append (syntree-children node) (list (dlang/expression in))))) + (token-match in 'term) + node) + +(define (dlang/begin in) + (define node '()) + (keyword-match in "begin") + (set! node (dlang/block! in)) + (token-match 'term) + 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))) + (token-match in 'term) + node) (define (dlang/basic-expr in) (define tok (buf-lookahead! in 1)) @@ -86,19 +134,21 @@ (define (dlang/arg-list in) '()) (define (dlang/id-list in) - (define tree (syntree 'list "" '())) + (define tree (syntree 'args "" '())) (define chldrn '()) (token-match in 'lpar) - (while (equal? 'id (token-type (buf-lookahead! in 1))) - (define tok (buf-consume! in)) - (set! tok (syntree (token-type tok) (token-text tok) '())) - (set! chldrn (append chldrn (list tok)))) + (if (not (token-matches? in 'rpar)) + (begin + (set! chldrn (append chldrn (list (token->syntree (token-match in 'id))))) + (while (not (token-matches? in 'rpar)) + (token-match in 'comma) + (set! chldrn (append chldrn (list (token->syntree (token-match in 'id)))))))) (token-match in 'rpar) (syntree-children-set! tree chldrn) tree) -(define (dlang/expr-list in term) - (define tree (syntree 'list "" '())) +(define (dlang/expr-block in term) + (define tree (syntree 'block "" '())) (define chldrn '()) (while (equal? term (token-type (buf-lookahead! in 1))) (set! chldrn (append chldrn (list (dlang/expression in))))) diff --git a/tests/test_parser.scm b/tests/test_parser.scm index 64083dc..ffefdff 100644 --- a/tests/test_parser.scm +++ b/tests/test_parser.scm @@ -7,6 +7,33 @@ (define (make-lexer input) (buf (buf input read-char) dlang/tokenize)) +; dlang/program +;------------------------------------------------------------------------------ + +; dlang/expression +;------------------------------------------------------------------------------ + +; dlang/core-form +;------------------------------------------------------------------------------ + +; dlang/define +;------------------------------------------------------------------------------ + +; dlang/assign +;------------------------------------------------------------------------------ + +; dlang/if +;------------------------------------------------------------------------------ + +; dlang/begin +;------------------------------------------------------------------------------ + +; dlang/func +;------------------------------------------------------------------------------ + +; dlang/basic-expr +;------------------------------------------------------------------------------ + ; dlang/operator-app ;------------------------------------------------------------------------------ @@ -103,3 +130,86 @@ (check-error "Expected a literal" (dlang/literal lxr))))) +; dlang/arg-list +;------------------------------------------------------------------------------ + +; dlang/id-list +;------------------------------------------------------------------------------ +(def-test "dlang/id-list should recognize an empty id list" + (call-with-input-string "()" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/id-list lxr)) + (and (syntree? result) + (equal? 'args (syntree-type result)) + (equal? "" (syntree-text result)) + (equal? '() (syntree-children result)))))) + +(def-test "dlang/id-list should recognize an id list of length 1" + (call-with-input-string "( a )" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/id-list lxr)) + (and (syntree? result) + (equal? 'args (syntree-type result)) + (equal? "" (syntree-text result)) + (equal? (syntree-children result) + (list (syntree 'id "a" '()))))))) + +(def-test "dlang/id-list should recognize an id list of length 2" + (call-with-input-string "( a , b )" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/id-list lxr)) + (and (syntree? result) + (equal? 'args (syntree-type result)) + (equal? "" (syntree-text result)) + (equal? (syntree-children result) + (list (syntree 'id "a" '()) + (syntree 'id "b" '()))))))) + +(def-test "dlang/id-list should recognize an id list of length 3" + (call-with-input-string "( a , b , c )" + (lambda (input) + (define lxr (make-lexer input)) + (define result (dlang/id-list lxr)) + (and (syntree? result) + (equal? 'args (syntree-type result)) + (equal? "" (syntree-text result)) + (equal? (syntree-children result) + (list (syntree 'id "a" '()) + (syntree 'id "b" '()) + (syntree 'id "c" '()))))))) + +(def-test "dlang/id-list should error when non-id recieved" + (call-with-input-string "(1.0)" + (lambda (input) + (define lxr (make-lexer input)) + (check-error "Expected a token of type 'id, received 'number instead" + (dlang/id-list lxr))))) + +(def-test "dlang/id-list should error when no comma in between ids" + (call-with-input-string "(a b)" + (lambda (input) + (define lxr (make-lexer input)) + (check-error "Expected a token of type 'comma, received 'id instead" + (dlang/id-list lxr))))) + +(def-test "dlang/id-list should error when left paren missing" + (call-with-input-string ")" + (lambda (input) + (define lxr (make-lexer input)) + (check-error "Expected a token of type 'lpar, received 'rpar instead" + (dlang/id-list lxr))))) + +(def-test "dlang/id-list should error when right paren missing" + (call-with-input-string "(" + (lambda (input) + (define lxr (make-lexer input)) + (check-error "Expected a token of type 'id, received EOF instead" + (dlang/id-list lxr))))) + +; dlang/expr-block +;------------------------------------------------------------------------------ + + -- 2.54.0