Added helper functions for comparing syntax trees and used those to refactor the...

diff --git a/source/parse-utils.scm b/source/parse-utils.scm
index 4de12f3e34a3b329ba064cf74d254320584dfcf7..0d29e3dfc2f8c8adac5c3c887dae92d31c2e2002 100644 (file)
--- a/source/parse-utils.scm
+++ b/source/parse-utils.scm
@@ -6,6 +6,22 @@
 (define-record syntree type text children)
 (define syntree make-syntree)
 
+(define (syntree=? tr1 tr2)
+  (and (equal? (syntree-type tr1) (syntree-type tr2))
+       (equal? (syntree-text tr1) (syntree-text tr2))
+       (syntree-children=? (syntree-children tr1) (syntree-children tr2))))
+
+(define (syntree-children=? ch1 ch2)
+  (and
+    (or
+      (and (null? ch1) (null? ch2))
+      (and (not (null? ch1)) (not (null? ch2))))
+    (if (null? ch1)
+      #t ; If we got here and one is null then BOTH must be, hence equal
+      (and
+        (syntree=? (car ch1) (car ch2))
+        (syntree-children=? (cdr ch1) (cdr ch2))))))
+
 (define (char-match buf expect)
   (define actual (buf-lookahead! buf 1))
   (if (eof-object? actual)

diff --git a/source/parser.scm b/source/parser.scm
index ac6acda441d923d90a79ca54be8afb2da312e590..5c0bdff00bce5507174d61d46bb38bdcf9c61040 100644 (file)
--- a/source/parser.scm
+++ b/source/parser.scm
@@ -108,11 +108,11 @@
         (parts '())
         (op '()))
     (token-match in 'lpar)
-    (set! parts (cons (dlang/expression in)))
-    (set! parts (cons (dlang/operator in)))
-    (set! parts (append parts (list (dlang/expression in))))
+    (set! parts (append (list (dlang/expression in)) parts))
+    ;(set! parts (cons parts (list (dlang/operator in))))
+    ;(set! parts (append parts (list (dlang/expression in))))
     (token-match in 'rpar)
-    (syntree-children-set! tree parts)
+    ;(syntree-children-set! tree parts)
     tree))
 
 (define (dlang/operator in)

diff --git a/tests/test_parser.scm b/tests/test_parser.scm
index 93ac5725029d01ff85fc0af2bdf352a2671abb27..05727ac60bbb1916e48f25f574cc0a523137fcf0 100644 (file)
--- a/tests/test_parser.scm
+++ b/tests/test_parser.scm
@@ -17,10 +17,7 @@
     (lambda (input)
       (define lxr (make-lexer input))
       (define result (dlang/expression lxr))
-      (and (syntree? result)
-           (equal? 'id (syntree-type result))
-           (equal? "abc" (syntree-text result))
-           (equal? '() (syntree-children result))))))
+      (syntree=? result (syntree 'id "abc" '())))))
 
 ; dlang/core-form
 ;------------------------------------------------------------------------------
@@ -47,10 +44,24 @@
     (lambda (input)
       (define lxr (make-lexer input))
       (define result (dlang/basic-expr lxr))
-      (and (syntree? result)
-           (equal? 'id (syntree-type result))
-           (equal? "abc" (syntree-text result))
-           (equal? '() (syntree-children result))))))
+      (syntree=? result (syntree 'id "abc" '())))))
+
+;(def-test "dlang/basic-expr should parse an infix operator application"
+;  (call-with-input-string "(1.0) * 2.0)"
+;    (lambda (input)
+;      (define lxr (make-lexer input))
+;      (define result (dlang/basic-expr lxr))
+;      (syntree=? result (syntree 'id "abc" '())
+;      (define expect
+;        (syntree 'apply "" (list
+;        ;  (syntree 'id "+" '())
+;          (syntree 'number "1.0" '()))))
+;        ;  (syntree 'number "1.0" '()))))
+;      (equal? result expect))))
+;      ;(and (syntree? result)
+;      ;     (equal? 'apply (syntree-type result))
+;      ;     (equal? "" (syntree-text result))
+;      ;     (equal? '() (syntree-children result))))))
 
 ; dlang/operator-app
 ;------------------------------------------------------------------------------
@@ -62,10 +73,7 @@
     (lambda (input)
       (define lxr (make-lexer input))
       (define result (dlang/operator lxr))
-      (and (syntree? result)
-           (equal? 'id (syntree-type result))
-           (equal? "abc" (syntree-text result))
-           (equal? '() (syntree-children result))))))
+      (syntree=? result (syntree 'id "abc" '())))))
 
 (def-test "dlang/operator should error if not an Id"
   (call-with-input-string "1.0"
@@ -88,51 +96,35 @@
     (lambda (input)
       (define lxr (make-lexer input))
       (define result (dlang/literal lxr))
-      (and (syntree? result)
-           (equal? 'id (syntree-type result))
-           (equal? "abc" (syntree-text result))
-           (equal? '() (syntree-children result))
-           (eof-object? (buf-lookahead! lxr 1))))))
+      (syntree=? result (syntree 'id "abc" '())))))
 
 (def-test "dlang/literal should parse a Character"
   (call-with-input-string "'a'"
     (lambda (input)
       (define lxr (make-lexer input))
       (define result (dlang/literal lxr))
-      (and (syntree? result)
-           (equal? 'character (syntree-type result))
-           (equal? "'a'" (syntree-text result))
-           (equal? '() (syntree-children result))))))
+      (syntree=? result (syntree 'character "'a'" '())))))
 
 (def-test "dlang/literal should parse a String"
   (call-with-input-string "\"abc\""
     (lambda (input)
       (define lxr (make-lexer input))
       (define result (dlang/literal lxr))
-      (and (syntree? result)
-           (equal? 'string (syntree-type result))
-           (equal? "\"abc\"" (syntree-text result))
-           (equal? '() (syntree-children result))))))
+      (syntree=? result (syntree 'string "\"abc\"" '())))))
 
 (def-test "dlang/literal should parse a Symbol"
   (call-with-input-string "$abc"
     (lambda (input)
       (define lxr (make-lexer input))
       (define result (dlang/literal lxr))
-      (and (syntree? result)
-           (equal? 'symbol (syntree-type result))
-           (equal? "$abc" (syntree-text result))
-           (equal? '() (syntree-children result))))))
+      (syntree=? result (syntree 'symbol "$abc" '())))))
 
 (def-test "dlang/literal should parse a Number"
   (call-with-input-string "1.0"
     (lambda (input)
       (define lxr (make-lexer input))
       (define result (dlang/literal lxr))
-      (and (syntree? result)
-           (equal? 'number (syntree-type result))
-           (equal? "1.0" (syntree-text result))
-           (equal? '() (syntree-children result))))))
+      (syntree=? result (syntree 'number "1.0" '())))))
 
 (def-test "dlang/literal should error when no literal found"
   (call-with-input-string "("
@@ -158,46 +150,39 @@
     (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))))))
+      (syntree=? result (syntree 'args "" '())))))
 
 (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" '())))))))
+      (syntree=? result
+        (syntree 'args ""
+          (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" '())))))))
+      (syntree=? result
+        (syntree 'args ""
+          (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" '())))))))
+      (syntree=? result
+        (syntree 'args ""
+          (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)"