Added tests for id-list

diff --git a/source/parse-utils.scm b/source/parse-utils.scm
index 528d855b0cbf474d8eda76bf45d0db653c20b7ab..4de12f3e34a3b329ba064cf74d254320584dfcf7 100644 (file)
--- 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 6816f3f16c157befca9e65172dc476d5d1747661..3a48f73a6e6c6f0b15c4043b4d939eb04dc70d1f 100644 (file)
--- 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 64083dcba4e34c99089fbb1c59a595ba5c772474..ffefdffaaee188c927fed4096fc4638fe78aefe7 100644 (file)
--- 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
+;------------------------------------------------------------------------------
+
+