Added tests for core forms and cleaned up some existing functions

diff --git a/source/parse-utils.scm b/source/parse-utils.scm
index 0d29e3dfc2f8c8adac5c3c887dae92d31c2e2002..4a7e60d0b89fa68e18f8ec99d4f51b9eba402c23 100644 (file)
--- 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 ab431fff74cd5d23e15ba5b0f9806a4c13c470ea..161b98923312aa4284d3c1fc8299ae6d5ee1724f 100644 (file)
--- 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 92ad46f0164a172ab9e0160ffa919a8671c6d0ef..65ccb44a305361231b85844a2b2d30841fabb5e0 100644 (file)
--- 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
 ;------------------------------------------------------------------------------