From: Mike D. Lowis <mike@mdlowis.com>
Date: Mon, 9 Jul 2012 20:43:01 +0000 (-0400)
Subject: Checkpoint. Overrode error function for unit tests and rearranged source files
X-Git-Url: https://git.mdlowis.com/?a=commitdiff_plain;h=d708bc74f5b80248a1be0f805dc4db9cc993fe29;p=archive%2Fdlang-scm.git

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

diff --git a/source/buf.scm b/source/buf.scm
index d5b7713..80267a8 100644
--- 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
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 4b80c49..685490e 100644
--- 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 babf12d..a3dabd7 100644
--- 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
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 a309997..75a5ad0 100644
--- 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 002621f..8eb1430 100644
--- 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
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
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
index 0000000..7362bf4
--- /dev/null
+++ b/tests/test_parser.scm
@@ -0,0 +1,3 @@
+(include "test.scm")
+(declare (unit test_parser))
+