(define (buf? obj)
(and (buf-struct? obj)
(procedure? (buf-ldfn obj))
- (integer? (buf-pos obj))
- (list? (buf-marks obj))
- (vector? (buf-data obj))))
+ (integer? (buf-pos obj))
+ (list? (buf-marks obj))
+ (vector? (buf-data obj))))
(define (vector-append v1 v2 . vN)
(define new-vec (list->vector (append (vector->list v1) (vector->list v2))))
(buf (charport input) charport-read))
(define (dlang/tokenize in)
- (define location (buf-posdata in))
+ (define location (current-buf-posdata in))
(let ((ch (buf-lookahead! in 1)))
(define tok
(cond
(not (chobj-char=? (buf-lookahead! in 1) #\newline))))
(define (dlang/number in)
- (define location (buf-posdata in))
+ (define location (current-buf-posdata in))
(token 'number
(string-append
(if (chobj-char=? (buf-lookahead! in 1) #\-)
(dlang/integer in)))
(define (dlang/character in)
- (define location (buf-posdata in))
+ (define location (current-buf-posdata in))
(token 'character
(string-append
(string (char-match in #\'))
(if (eof-object? (buf-lookahead! in 1))
- (abort "Unexpected EOF while parsing character literal")
- (string (chobj-char (buf-consume! in))))
+ (abort "Unexpected EOF while parsing character literal")
+ (string (chobj-char (buf-consume! in))))
(string (char-match in #\')))
location))
(define (dlang/string in)
- (define location (buf-posdata in))
+ (define location (current-buf-posdata in))
(define text
(string-append
(string (char-match in #\"))
(not (chobj-char=? ch #\"))))
(define (dlang/symbol in)
- (define location (buf-posdata in))
+ (define location (current-buf-posdata in))
(token 'symbol
(string-append
(string (char-match in #\$))
location))
(define (dlang/id in)
- (define location (buf-posdata in))
+ (define location (current-buf-posdata in))
(define str (collect-char in dlang/id-char?))
(if (> (string-length str) 0)
- (token 'id str location)
- (abort "An Id was expected but none found.")))
+ (token 'id str location)
+ (abort "An Id was expected but none found.")))
(define (dlang/id-char? in)
(define ch (buf-lookahead! in 1))
(and (not (eof-object? ch))
(not (chobj-whitespace? ch))
(case (chobj-char ch)
- ((#\( #\) #\; #\, #\' #\" #\$ #\#) #f)
- (else #t))))
+ ((#\( #\) #\; #\, #\' #\" #\$ #\#) #f)
+ (else #t))))
(define (charport-read chprt)
(define ch (read-char (charport-port chprt)))
+ (define pos (charport-posdata chprt))
(cond
((eof-object? ch)) ; Do nothing for EOFs
((char=? ch #\newline)
(charport-column-set! chprt 1))
(else
(charport-column-set! chprt (+ 1 (charport-column chprt)))))
- (if (eof-object? ch) ch (chobj ch (charport-posdata chprt))))
+ (if (eof-object? ch) ch (chobj ch pos)))
(define (charport-posdata chprt)
(posdata
(charport-line chprt)
(charport-column chprt)))
+(define (current-buf-posdata in)
+ (define itm (buf-lookahead! in 1))
+ (cond
+ ((eof-object? itm) (buf-posdata in))
+ ((token? itm) (token-pos itm))
+ ((chobj? itm) (chobj-pos itm))
+ (else (abort "Argument was not a buf or a charport"))))
+
(define (buf-posdata in)
(cond
((buf? in) (buf-posdata (buf-src in)))
(define (dlang/expression in)
(if (dlang/core-form? in)
- (dlang/core-form in)
- (let ((result (dlang/basic-expr in)))
- (if (dlang/arg-list? in)
- (syntree 'apply ""
- (append (list result) (syntree-children (dlang/arg-list in))))
- result))))
+ (dlang/core-form in)
+ (let ((result (dlang/basic-expr in)))
+ (if (dlang/arg-list? in)
+ (syntree 'apply ""
+ (append (list result) (syntree-children (dlang/arg-list in))))
+ result))))
(define (dlang/core-form in)
(define tok (buf-lookahead! in 1))
(define (dlang/core-form? in)
(define tok (buf-lookahead! in 1))
(define text (if (eof-object? tok) "" (token-text tok)))
- (or (string=? text "def")
- (string=? text "set!")
- (string=? text "if")
- (string=? text "begin")
- (string=? text "func")))
+ (list? (member text '("def" "set!" "if" "begin" "func"))))
(define (dlang/define in)
(define node '())
(define (dlang/literal in)
(define tok (buf-lookahead! in 1))
(define type (if (eof-object? tok) '() (token-type tok)))
- (if (or (equal? 'id type)
- (equal? 'character type)
- (equal? 'string type)
- (equal? 'symbol type)
- (equal? 'number type))
- (set! tok (buf-consume! in))
- (abort "Expected a literal"))
+ (if (list? (member type '(id character string symbol number)))
+ (set! tok (buf-consume! in))
+ (abort "Expected a literal"))
(syntree (token-type tok) (token-text tok) '()))
(define (dlang/arg-list in)
(define (dlang/expr-block in term)
(syntree 'block ""
- (collect
- in
+ (collect in
(lambda (buf) (not (token-matches? buf term)))
dlang/expression)))
(define buffer (dlang/char-buf input))
(define result (dlang/tokenize buffer))
(token=? result
- (token 'number "12" (posdata "(string)" 1 2))))))
+ (token 'number "12" (posdata "(string)" 1 1))))))
(def-test "dlang/tokenize should recognize a character"
(call-with-input-string "'a'"
(define buffer (dlang/char-buf input))
(define result (dlang/tokenize buffer))
(token=? result
- (token 'character "'a'" (posdata "(string)" 1 2))))))
+ (token 'character "'a'" (posdata "(string)" 1 1))))))
(def-test "dlang/tokenize should recognize a string"
(call-with-input-string "\"\""
(define buffer (dlang/char-buf input))
(define result (dlang/tokenize buffer))
(token=? result
- (token 'string "\"\"" (posdata "(string)" 1 2))))))
+ (token 'string "\"\"" (posdata "(string)" 1 1))))))
(def-test "dlang/tokenize should recognize a symbol"
(call-with-input-string "$foobar"
(define buffer (dlang/char-buf input))
(define result (dlang/tokenize buffer))
(token=? result
- (token 'symbol "$foobar" (posdata "(string)" 1 2))))))
+ (token 'symbol "$foobar" (posdata "(string)" 1 1))))))
(def-test "dlang/tokenize should recognize an id"
(call-with-input-string "foobar"
(define buffer (dlang/char-buf input))
(define result (dlang/tokenize buffer))
(token=? result
- (token 'id "foobar" (posdata "(string)" 1 2))))))
+ (token 'id "foobar" (posdata "(string)" 1 1))))))
(def-test "dlang/tokenize should recognize the EOF"
(call-with-input-string ""
(define buffer (dlang/char-buf input))
(define result (dlang/tokenize buffer))
(token=? result
- (token 'term "end" (posdata "(string)" 1 2))))))
+ (token 'term "end" (posdata "(string)" 1 1))))))
; dlang/whitespace
;------------------------------------------------------------------------------
(define buffer (dlang/char-buf input))
(define result (dlang/whitespace buffer))
(token=? result
- (token 'id "foo" (posdata "(string)" 2 2))))))
+ (token 'id "foo" (posdata "(string)" 2 1))))))
; dlang/comment
;------------------------------------------------------------------------------
(define buffer (dlang/char-buf input))
(define result (dlang/comment buffer))
(token=? result
- (token 'id "bar" (posdata "(string)" 2 2)))
- )))
+ (token 'id "bar" (posdata "(string)" 2 1))))))
; dlang/number
;------------------------------------------------------------------------------
(lambda (input)
(define port (charport input))
(define result (charport-read port))
- (and (chobj=? (chobj #\a (posdata "(string)" 1 2)) result)
+ (and (chobj=? (chobj #\a (posdata "(string)" 1 1)) result)
(equal? 1 (charport-line port))
(equal? 2 (charport-column port))))))
(lambda (input)
(define port (charport input))
(define result (charport-read port))
- (and (chobj=? (chobj #\newline (posdata "(string)" 2 1)) result)
+ (and (chobj=? (chobj #\newline (posdata "(string)" 1 1)) result)
(equal? 2 (charport-line port))
(equal? 1 (charport-column port))))))
(define buffer (dlang/lexer input))
(token=?
(token-match buffer 'id)
- (token 'id "a" (posdata "(string)" 1 2))))))
+ (token 'id "a" (posdata "(string)" 1 1))))))
(def-test "token-match should error when EOF received"
(call-with-input-string ""
(define buffer (dlang/lexer input))
(token=?
(keyword-match buffer "abc")
- (token 'id "abc" (posdata "(string)" 1 2))))))
+ (token 'id "abc" (posdata "(string)" 1 1))))))
(def-test "keyword-match should error if next token not an id"
(call-with-input-string "1.0"
(lambda (input)
(define buffer (buf (charport input) charport-read))
(consume-all buffer dlang/integer?)
- (chobj=? (chobj #\a (posdata "(string)" 1 2))
+ (chobj=? (chobj #\a (posdata "(string)" 1 1))
(buf-lookahead! buffer 1)))))
(def-test "should consume an item at a time until predicate returns false"
(lambda (input)
(define buffer (buf (charport input) charport-read))
(consume-all buffer dlang/integer?)
- (chobj=? (chobj #\a (posdata "(string)" 1 5))
+ (chobj=? (chobj #\a (posdata "(string)" 1 4))
(buf-lookahead! buffer 1)))))
; collect
projects / archive / dlang-scm.git / commitdiff