Added macro for checking exceptions and switched all rules to use the abort exception...

diff --git a/inc/test.scm b/inc/test.scm
index 3ae10114a53e33dd2b259fcec811bb95ce1b681e..204706fbcf1bb85a3c5ea1fa8af16d960919c015 100644 (file)
--- a/inc/test.scm
+++ b/inc/test.scm
@@ -18,4 +18,13 @@
         (set! error prev)
         (equal? expect result)))))
 
+(define-syntax check-exception
+  (syntax-rules ()
+    ((_ expect expr)
+      (equal? expect
+        (call/cc
+          (lambda (cont)
+            (with-exception-handler
+              (lambda (x) (cont x))
+              (lambda ()  expr))))))))
 

diff --git a/source/lexer.scm b/source/lexer.scm
index 1bdfeef6559355e08d848a5acfcf640b8eb6f585..c1426c939bd86c2e01031605973b49e08459bc66 100644 (file)
--- a/source/lexer.scm
+++ b/source/lexer.scm
@@ -85,7 +85,7 @@
         (char-numeric? (buf-lookahead! in 1)))
     (while (char-numeric? (buf-lookahead! in 1))
       (set! text (string-append text (string (buf-consume! in)))))
-    (error "Expected an integer"))
+    (abort "Expected an integer"))
   text)
 
 (define (dlang/decimal in)
@@ -108,7 +108,7 @@
     (string-append
       (string (char-match in #\'))
       (if (eof-object? (buf-lookahead! in 1))
-        (error "Unexpected EOF while parsing character literal")
+        (abort "Unexpected EOF while parsing character literal")
         (string (buf-consume! in)))
       (string (char-match in #\')) )))
 
@@ -130,11 +130,10 @@
 (define (dlang/id in)
   (define acc "")
   (while (dlang/id-char? in)
-    (set! acc (string-append acc (string (buf-consume! in))))
-    )
+    (set! acc (string-append acc (string (buf-consume! in)))))
   (if (> (string-length acc) 0)
     (token 'id acc)
-    (error "An Id was expected but none found.")))
+    (abort "An Id was expected but none found.")))
 
 (define (dlang/id-char? in)
   (define ch (buf-lookahead! in 1))

diff --git a/source/parse-utils.scm b/source/parse-utils.scm
index 4a7e60d0b89fa68e18f8ec99d4f51b9eba402c23..5b7053391e810c84d6061e24e64db35d7bd9b427 100644 (file)
--- a/source/parse-utils.scm
+++ b/source/parse-utils.scm
@@ -25,10 +25,10 @@
 (define (char-match buf expect)
   (define actual (buf-lookahead! buf 1))
   (if (eof-object? actual)
-    (error (string-append "Expected '" (string expect) "', received EOF instead"))
+    (abort (string-append "Expected '" (string expect) "', received EOF instead"))
     (if (equal? expect actual)
       (buf-consume! buf)
-      (error
+      (abort
         (string-append
           "Expected '" (string expect) "', received '" (string actual) "' instead"))))
   actual)
@@ -36,13 +36,13 @@
 (define (token-match buf expect)
   (define actual (buf-lookahead! buf 1))
   (if (eof-object? actual)
-    (error
+    (abort
       (string-append
         "Expected a token of type '" (symbol->string expect) ","
         " received EOF instead"))
     (if (equal? expect (token-type actual))
       (buf-consume! buf)
-      (error
+      (abort
         (string-append
           "Expected a token of type '" (symbol->string expect) ","
           " received '" (symbol->string (token-type actual)) " instead"))))
@@ -58,10 +58,20 @@
   (if (and (token-matches? buf 'id)
            (equal? expect (token-text actual)))
     (buf-consume! buf)
-    (error
+    (abort
       (string-append
-      "Expected '" expect "', received '" (token-text actual) "' instead"))))
+        "Expected '" expect "', received '" (token-text actual) "' instead"))))
 
 (define (token->syntree tok)
   (syntree (token-type tok) (token-text tok) '()))
 
+(define (test-apply fn buf . args)
+  (define result '())
+  (buf-mark! buf)
+  (call/cc
+    (lambda (cont)
+      (with-exception-handler
+        (lambda (x) (cont '()))
+        (lambda ()  (set! result (apply fn (append buf args)))))))
+  (buf-release! buf)
+  (not (null? result)))

diff --git a/source/parser.scm b/source/parser.scm
index 57e240546d400c467741cc9e6003b24f1c5d2f7c..be2aa556220f14894547bf56ba77c82f1152f9ad 100644 (file)
--- a/source/parser.scm
+++ b/source/parser.scm
@@ -37,13 +37,7 @@
   (if (dlang/core-form? in)
     (dlang/core-form in)
     (let ((result (dlang/basic-expr in)))
-      (if (equal? 'lpar (buf-lookahead! in 1))
-        (begin
-          (match in 'lpar)
-          (set! result
-            (syntree 'apply (list result (dlang/expr-list in))))
-          (match in 'rpar)))
-      result)))
+      (if (dlang/arg-list? in) (dlang/arg-list? in result) result))))
 
 (define (dlang/core-form in)
   (define tok (buf-lookahead! in 1))
@@ -105,7 +99,8 @@
 (define (dlang/func in)
   (define node (syntree 'func "" '()))
   (keyword-match in "func")
-  (syntree-children-set! node (list (dlang/id-list in) (dlang/expr-block in 'term)))
+  (syntree-children-set! node
+    (list (dlang/id-list in) (dlang/expr-block in 'term)))
   (token-match in 'term)
   (syntree-type-set! node 'func)
   node)
@@ -141,11 +136,14 @@
           (equal? 'symbol type)
           (equal? 'number type))
     (set! tok (buf-consume! in))
-    (error "Expected a literal"))
+    (abort "Expected a literal"))
   (syntree (token-type tok) (token-text tok) '()))
 
 (define (dlang/arg-list in) '())
 
+(define (dlang/arg-list? in)
+  (test-apply dlang/arg-list in))
+
 (define (dlang/id-list in)
   (define tree (syntree 'args "" '()))
   (define chldrn '())

diff --git a/tests/test_lexer.scm b/tests/test_lexer.scm
index 014431835bda9015d6300cbfe63beeb2e55a877c..ac4d7d8d688d19488f1522a36b284b53c9988c74 100644 (file)
--- a/tests/test_lexer.scm
+++ b/tests/test_lexer.scm
@@ -334,14 +334,14 @@
   (call-with-input-string "abc"
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected an integer"
+      (check-exception "Expected an integer"
         (dlang/integer buffer)))))
 
 (def-test "dlang/integer should error when EOF"
   (call-with-input-string ""
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected an integer"
+      (check-exception "Expected an integer"
         (dlang/integer buffer)))))
 
 ; dlang/decimal
@@ -374,14 +374,14 @@
   (call-with-input-string ". "
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected an integer"
+      (check-exception "Expected an integer"
         (dlang/decimal buffer)))))
 
 (def-test "dlang/decimal should error when EOF"
   (call-with-input-string ""
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected '.', received EOF instead"
+      (check-exception "Expected '.', received EOF instead"
         (dlang/decimal buffer)))))
 
 ; dlang/exponent
@@ -430,14 +430,14 @@
   (call-with-input-string "e "
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected an integer"
+      (check-exception "Expected an integer"
         (dlang/exponent buffer)))))
 
 (def-test "dlang/exponent should error when EOF"
   (call-with-input-string ""
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected 'E', received EOF instead"
+      (check-exception "Expected 'E', received EOF instead"
         (dlang/exponent buffer)))))
 
 ; dlang/character
@@ -455,21 +455,21 @@
   (call-with-input-string "a'"
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected ''', received 'a' instead"
+      (check-exception "Expected ''', received 'a' instead"
         (dlang/character buffer)))))
 
 (def-test "dlang/character should error when missing second single quote"
   (call-with-input-string "'a"
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected ''', received EOF instead"
+      (check-exception "Expected ''', received EOF instead"
         (dlang/character buffer)))))
 
 (def-test "dlang/character should error when EOF reached"
   (call-with-input-string "'"
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Unexpected EOF while parsing character literal"
+      (check-exception "Unexpected EOF while parsing character literal"
         (dlang/character buffer)))))
 
 ; dlang/string
@@ -514,21 +514,21 @@
   (call-with-input-string "a\""
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected '\"', received 'a' instead"
+      (check-exception "Expected '\"', received 'a' instead"
         (dlang/string buffer)))))
 
 (def-test "dlang/string should error when missing second double quote"
   (call-with-input-string "\"a"
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected '\"', received EOF instead"
+      (check-exception "Expected '\"', received EOF instead"
         (dlang/string buffer)))))
 
 (def-test "dlang/string should error when EOF reached"
   (call-with-input-string "\""
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected '\"', received EOF instead"
+      (check-exception "Expected '\"', received EOF instead"
         (dlang/string buffer)))))
 
 ; dlang/symbol
@@ -582,14 +582,14 @@
   (call-with-input-string "$"
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "An Id was expected but none found."
+      (check-exception "An Id was expected but none found."
         (dlang/symbol buffer)))))
 
 (def-test "dlang/symbol should error when EOF"
   (call-with-input-string ""
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "Expected '$', received EOF instead"
+      (check-exception "Expected '$', received EOF instead"
         (dlang/symbol buffer)))))
 
 ; dlang/id
@@ -643,7 +643,7 @@
   (call-with-input-string ""
     (lambda (input)
       (define buffer (buf input read-char))
-      (check-error "An Id was expected but none found."
+      (check-exception "An Id was expected but none found."
         (dlang/id buffer)))))
 
 (def-test "dlang/id should stop recognition when comment encountered"

diff --git a/tests/test_parser.scm b/tests/test_parser.scm
index f8ad857a2431c17a54624dd8ad9793450a9db2ff..0bb8f269c858e5dd06f0650f93e504427192de3f 100644 (file)
--- a/tests/test_parser.scm
+++ b/tests/test_parser.scm
@@ -303,14 +303,14 @@
   (call-with-input-string "1.0"
     (lambda (input)
       (define lxr (make-lexer input))
-     (check-error "Expected a token of type 'id, received 'number instead"
+     (check-exception "Expected a token of type 'id, received 'number instead"
         (dlang/operator lxr)))))
 
 (def-test "dlang/operator should error if EOF"
   (call-with-input-string ""
     (lambda (input)
       (define lxr (make-lexer input))
-      (check-error "Expected a token of type 'id, received EOF instead"
+      (check-exception "Expected a token of type 'id, received EOF instead"
         (dlang/operator lxr)))))
 
 ; dlang/literal
@@ -354,14 +354,14 @@
   (call-with-input-string "("
     (lambda (input)
       (define lxr (make-lexer input))
-      (check-error "Expected a literal"
+      (check-exception "Expected a literal"
         (dlang/literal lxr)))))
 
 (def-test "dlang/literal should error when EOF"
   (call-with-input-string ""
     (lambda (input)
       (define lxr (make-lexer input))
-      (check-error "Expected a literal"
+      (check-exception "Expected a literal"
         (dlang/literal lxr)))))
 
 ; dlang/arg-list
@@ -412,31 +412,56 @@
   (call-with-input-string "(1.0)"
     (lambda (input)
       (define lxr (make-lexer input))
-      (check-error "Expected a token of type 'id, received 'number instead"
+      (check-exception "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"
+      (check-exception "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"
+      (check-exception "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"
+      (check-exception "Expected a token of type 'id, received EOF instead"
         (dlang/id-list lxr)))))
 
 ; dlang/expr-block
 ;------------------------------------------------------------------------------
+(def-test "dlang/expr-block should parse a block of 0 expressions"
+  (call-with-input-string ";"
+    (lambda (input)
+      (define lxr (make-lexer input))
+      (define result (dlang/expr-block lxr 'term))
+      (syntree=? result (syntree 'block "" '())))))
 
+(def-test "dlang/expr-block should parse a block of 1 expression"
+  (call-with-input-string "1.0;"
+    (lambda (input)
+      (define lxr (make-lexer input))
+      (define result (dlang/expr-block lxr 'term))
+      (syntree=? result
+        (syntree 'block ""
+          (list
+            (syntree 'number "1.0" '())))))))
 
+(def-test "dlang/expr-block should parse a block of 2 expressions"
+  (call-with-input-string "1.0 2.0;"
+    (lambda (input)
+      (define lxr (make-lexer input))
+      (define result (dlang/expr-block lxr 'term))
+      (syntree=? result
+        (syntree 'block ""
+          (list
+            (syntree 'number "1.0" '())
+            (syntree 'number "2.0" '())))))))