Checkpoint. Overrode error function for unit tests and rearranged source files

diff --git a/source/buf.scm b/source/buf.scm
index d5b77131be8baf0f0381b35e00606228c994f9a5..80267a8061621354e5ae1365ab92eefdbda74931 100644 (file)
--- a/source/buf.scm
+++ b/source/buf.scm
@@ -1,14 +1,10 @@
 (declare (unit buf)
          (uses library))
 
-(use vector-lib)
+(require-extension vector-lib)
 
 (define-record buf
-  src
-  ldfn
-  pos
-  marks
-  data)
+  src ldfn pos marks data)
 
 (define (buf src fn)
   (make-buf src fn 0 '() (vector)))

diff --git a/source/lex.scm b/source/lex.scm
deleted file mode 100644 (file)
index 2bad620..0000000
--- a/source/lex.scm
+++ /dev/null
@@ -1,15 +0,0 @@
-(declare (unit lex))
-
-(define-record token type text)
-
-(define token make-token)
-
-(define (match buf expect)
-  (define actual (buf-lookahead! buf 1))
-  (if (equal? expect actual)
-    (buf-consume! buf)
-    (error
-      (string-append
-        "Expected '" expect "', received '" actual "'")))
-  actual)
-

diff --git a/source/lexer.scm b/source/lexer.scm
index 4b80c49b9f7152ad0755fd2055eee681c4ae2c3b..685490e167a18c2873781519e9b8af4ab4e4f6f7 100644 (file)
--- a/source/lexer.scm
+++ b/source/lexer.scm
@@ -1,6 +1,7 @@
+(include "loop.scm")
 (declare (unit lexer)
+         (uses parse-utils)
          (uses buf))
-(include "loop.scm")
 
 (define (dlang/tokenize in)
   (let ((ch (buf-lookahead! in 1)))
@@ -105,6 +106,8 @@
     (if
       (and (not (char-whitespace? ch))
            (not (eof-object? ch)))
-      (loop (string-append acc (buf-consume! in)) (buf-lookahead! in 1))
-      (token 'id acc))))
+      (loop (string-append acc (string (buf-consume! in))) (buf-lookahead! in 1))
+      (if (> (string-length acc) 0)
+        (token 'id acc)
+        (error "An Id was expected but none found.")))))
 

diff --git a/source/main.scm b/source/main.scm
index babf12d9e93fa66e7e7dc4e4644f4390f6a011c3..a3dabd70cdc2f8bae2d226be2c28333e88237b58 100644 (file)
--- a/source/main.scm
+++ b/source/main.scm
@@ -1,4 +1,17 @@
-(declare (uses buf))
+(declare (uses buf)
+         (uses lexer)
+         (uses parser))
 
-(print (buf (current-input-port) (lambda () '())))
+(define program-parser
+  (buf
+    (buf (current-input-port) dlang/tokenize)
+    dlang/program))
+
+(define expression-parser
+  (buf
+    (buf (current-input-port) dlang/tokenize)
+    dlang/program))
+
+(print program-parser)
+(print expression-parser)
 

diff --git a/source/parse-utils.scm b/source/parse-utils.scm
new file mode 100644 (file)
index 0000000..3f1bcf7
--- /dev/null
+++ b/source/parse-utils.scm
@@ -0,0 +1,26 @@
+(declare (unit parse-utils))
+
+(define-record token type text)
+(define token make-token)
+
+(define-record syntree type text children)
+(define syntree make-syntree)
+
+(define (char-match buf expect)
+  (define actual (buf-lookahead! buf 1))
+  (if (equal? expect actual)
+    (buf-consume! buf)
+    (error
+      (string-append
+        "Expected '" expect "', received '" actual "' instead.")))
+  actual)
+
+(define (token-match buf expect)
+  (define actual (buf-lookahead! buf 1))
+  (if (equal? expect (token-type actual))
+    (buf-consume! buf)
+    (error
+      (string-append
+        "Expected a " expect ", received a " actual " instead.")))
+  actual)
+

diff --git a/tests/main.scm b/tests/main.scm
index a3099970ca90a72ee9fe34ad7cb8c4c688b9a299..75a5ad055d813c8cb127ce0c829ec573b388758d 100644 (file)
--- a/tests/main.scm
+++ b/tests/main.scm
@@ -1,6 +1,9 @@
 (declare
   (uses library)
   (uses test_buf)
+  (uses test_lexer)
+  (uses test_parser)
+  (uses test_parse_utils)
   (uses test))
 
 (run-all-unit-tests)

diff --git a/tests/test.scm b/tests/test.scm
index 002621f64a5d6202211f7afe3bcc6172ec9f37d9..8eb1430f05dcf14acc8f9e1342b4451307c9cd55 100644 (file)
--- a/tests/test.scm
+++ b/tests/test.scm
@@ -6,6 +6,8 @@
 (define (register-test! test)
   (set! unit-tests (append unit-tests (list test))))
 
+(define (error msg) msg)
+
 (define (print-summary pass fail)
   (if (zero? fail)
     (print "Success: " pass " tests passed.")

diff --git a/tests/test_lexer.scm b/tests/test_lexer.scm
new file mode 100644 (file)
index 0000000..0482f8d
--- /dev/null
+++ b/tests/test_lexer.scm
@@ -0,0 +1,115 @@
+(include "test.scm")
+(declare (unit test_lexer)
+         (uses lexer))
+
+; dlang/tokenize
+;------------------------------------------------------------------------------
+
+; dlang/whitespace
+;------------------------------------------------------------------------------
+
+; dlang/comment
+;------------------------------------------------------------------------------
+
+; dlang/number
+;------------------------------------------------------------------------------
+
+; dlang/integer
+;------------------------------------------------------------------------------
+
+; dlang/decimal
+;------------------------------------------------------------------------------
+
+; dlang/exponent
+;------------------------------------------------------------------------------
+
+; dlang/character
+;------------------------------------------------------------------------------
+
+; dlang/string
+;------------------------------------------------------------------------------
+
+; dlang/symbol
+;------------------------------------------------------------------------------
+(def-test "dlang/symbol should error when no name given for a symbol"
+  (call-with-input-string "$"
+    (lambda (input) '())))
+
+(def-test "dlang/symbol should error when not a symbol"
+  (call-with-input-string "abc"
+    (lambda (input) '())))
+
+(def-test "dlang/symbol should recognize a symbol of length one"
+  (call-with-input-string "$a"
+    (lambda (input) '())))
+
+(def-test "dlang/symbol should recognize a symbol of length two"
+  (call-with-input-string "$ab"
+    (lambda (input) '())))
+
+(def-test "dlang/symbol should recognize a symbol of length three"
+  (call-with-input-string "$abc"
+    (lambda (input) '())))
+
+(def-test "dlang/symbol should stop recognition on EOF"
+  (call-with-input-string "$abc"
+    (lambda (input) '())))
+
+(def-test "dlang/symbol should stop recognition on whitespace"
+  (call-with-input-string "$abc "
+    (lambda (input) '())))
+
+; dlang/id
+;------------------------------------------------------------------------------
+(def-test "dlang/id should recognize an id of length one"
+  (call-with-input-string "a"
+    (lambda (input)
+      (define buffer (buf input read-char))
+      (define result (dlang/id buffer))
+      (and (token? result)
+           (equal? 'id (token-type result))
+           (equal? "a" (token-text result))))))
+
+(def-test "dlang/id should recognize an id of length two"
+  (call-with-input-string "ab"
+    (lambda (input)
+      (define buffer (buf input read-char))
+      (define result (dlang/id buffer))
+      (and (token? result)
+           (equal? 'id (token-type result))
+           (equal? "ab" (token-text result))))))
+
+(def-test "dlang/id should recognize an id of length three"
+  (call-with-input-string "abc"
+    (lambda (input)
+      (define buffer (buf input read-char))
+      (define result (dlang/id buffer))
+      (and (token? result)
+           (equal? 'id (token-type result))
+           (equal? "abc" (token-text result))))))
+
+(def-test "dlang/id should stop recognition on whitepsace"
+  (call-with-input-string "abc abc"
+    (lambda (input)
+      (define buffer (buf input read-char))
+      (define result (dlang/id buffer))
+      (and (token? result)
+           (equal? 'id (token-type result))
+           (equal? "abc" (token-text result))))))
+
+(def-test "dlang/id should stop recognition on EOF"
+  (call-with-input-string "abc"
+    (lambda (input)
+      (define buffer (buf input read-char))
+      (define result (dlang/id buffer))
+      (and (token? result)
+           (equal? 'id (token-type result))
+           (equal? "abc" (token-text result))))))
+
+(def-test "dlang/id should error when no id recognized"
+  (call-with-input-string ""
+    (lambda (input)
+      (define buffer (buf input read-char))
+      (define result (dlang/id buffer))
+      (equal? result "An Id was expected but none found.") )))
+

diff --git a/tests/test_parse_utils.scm b/tests/test_parse_utils.scm
new file mode 100644 (file)
index 0000000..5cc804f
--- /dev/null
+++ b/tests/test_parse_utils.scm
@@ -0,0 +1,3 @@
+(include "test.scm")
+(declare (unit test_parse_utils))
+

diff --git a/tests/test_parser.scm b/tests/test_parser.scm
new file mode 100644 (file)
index 0000000..7362bf4
--- /dev/null
+++ b/tests/test_parser.scm
@@ -0,0 +1,3 @@
+(include "test.scm")
+(declare (unit test_parser))
+