Added struct for encapsulating position data and added functions for retrieving posit...

diff --git a/source/parse-utils.scm b/source/parse-utils.scm
index e0c2f539d4907ee6059b916119d099a66920dba7..03ed37d9fd9525705877f59bc5f1edd99534caff 100644 (file)
--- a/source/parse-utils.scm
+++ b/source/parse-utils.scm
@@ -3,13 +3,19 @@
 (define-record token type text)
 (define token make-token)
 
+(define-record syntree type text children)
+(define syntree make-syntree)
+
+(define-record charport port line column)
+(define (charport port) (make-charport port 1 1))
+
+(define-record posdata name line column)
+(define posdata make-posdata)
+
 (define (token=? tok1 tok2)
   (and (equal? (token-type tok1) (token-type tok2))
        (equal? (token-text tok1) (token-text tok2))))
 
-(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))
@@ -26,9 +32,6 @@
         (syntree=? (car ch1) (car ch2))
         (syntree-children=? (cdr ch1) (cdr ch2))))))
 
-(define-record charport port line column)
-(define (charport port) (make-charport port 1 1))
-
 (define (charport-read chprt)
   (define ch (read-char (charport-port chprt)))
   (if (char=? ch #\newline)
@@ -38,6 +41,18 @@
     (charport-column-set! chprt (+ 1 (charport-column chprt))))
   ch)
 
+(define (charport-posdata chprt)
+  (posdata
+    (port-name (charport-port chprt))
+    (charport-line chprt)
+    (charport-column chprt)))
+
+(define (buf-posdata in)
+  (cond
+    ((buf? in)      (buf-posdata (buf-src in)))
+    ((charport? in) (charport-posdata in))
+    (else           (abort "Argument was not a buf or a charport"))))
+
 (define (char-match buf expect)
   (define actual (buf-lookahead! buf 1))
   (if (eof-object? actual)

diff --git a/tests/test_parse_utils.scm b/tests/test_parse_utils.scm
index 81304ec13585092820a209ee13cd9706ab484330..b53ba74006628c33a61d58b68d8b3cd6b350e39e 100644 (file)
--- a/tests/test_parse_utils.scm
+++ b/tests/test_parse_utils.scm
@@ -16,6 +16,30 @@
        (procedure? syntree-type)
        (procedure? syntree-children)))
 
+(def-test "functions for charport creation and usage should be created"
+  (and (procedure? make-charport)
+       (procedure? charport)
+       (procedure? charport-port)
+       (procedure? charport-line)
+       (procedure? charport-column)))
+
+(def-test "functions for posdata creation and usage should be created"
+  (and (procedure? make-syntree)
+       (procedure? posdata)
+       (procedure? posdata-name)
+       (procedure? posdata-line)
+       (procedure? posdata-column)))
+
+; charport
+;------------------------------------------------------------------------------
+(def-test "charport should initialize a charport properly"
+  (call-with-input-string "a"
+    (lambda (input)
+      (define port (charport input))
+      (and (equal? input (charport-port port))
+           (equal? 1 (charport-line port))
+           (equal? 1 (charport-column port))))))
+
 ; token=?
 ;------------------------------------------------------------------------------
 (def-test "token=? should return true if trees are equal"
@@ -79,16 +103,6 @@
       (list (syntree 'foo "" '()))
       (list (syntree 'bar "" '())))))
 
-; charport
-;------------------------------------------------------------------------------
-(def-test "charport should initialize a charport properly"
-  (call-with-input-string "a"
-    (lambda (input)
-      (define port (charport input))
-      (and (equal? input (charport-port port))
-           (equal? 1 (charport-line port))
-           (equal? 1 (charport-column port))))))
-
 ; charport-read
 ;------------------------------------------------------------------------------
 (def-test "charport-read should increment column when character is not newline"
@@ -107,6 +121,52 @@
            (equal? 2 (charport-line port))
            (equal? 1 (charport-column port))))))
 
+; charport-pos
+;------------------------------------------------------------------------------
+(def-test "charport-pos should return psodata for given charport"
+  (call-with-input-string "a"
+    (lambda (input)
+      (define prt (charport input))
+      (define pos (charport-posdata prt))
+      (and (equal? "(string)" (posdata-name pos))
+           (equal? 1 (posdata-line pos))
+           (equal? 1 (posdata-column pos))))))
+
+; buf-posdata
+;------------------------------------------------------------------------------
+(def-test "buf-posdata should return posdata from charport"
+  (call-with-input-string ""
+    (lambda (input)
+      (define prt (charport input))
+      (define pos (buf-posdata prt))
+      (and (equal? "(string)" (posdata-name pos))
+           (equal? 1 (posdata-line pos))
+           (equal? 1 (posdata-column pos))))))
+
+(def-test "buf-posdata should return posdata from buf"
+  (call-with-input-string ""
+    (lambda (input)
+      (define prt (buf (charport input) charport-read))
+      (define pos (buf-posdata prt))
+      (and (equal? "(string)" (posdata-name pos))
+           (equal? 1 (posdata-line pos))
+           (equal? 1 (posdata-column pos))))))
+
+(def-test "buf-posdata should return posdata from multi layer buf"
+  (call-with-input-string ""
+    (lambda (input)
+      (define prt (buf (buf (charport input) charport-read) dlang/tokenize))
+      (define pos (buf-posdata prt))
+      (and (equal? "(string)" (posdata-name pos))
+           (equal? 1 (posdata-line pos))
+           (equal? 1 (posdata-column pos))))))
+
+(def-test "buf-posdata should error when an invalid object is encountered"
+  (call-with-input-string ""
+    (lambda (input)
+      (check-exception "Argument was not a buf or a charport"
+        (buf-posdata '())))))
+
 ; char-match
 ;------------------------------------------------------------------------------
 (def-test "char-match should consume and return char if the next char matches"