Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
285 lines (245 sloc) 8.68 KB
(require (fs "fs")
(ast "./ast"))
(define chars-whitespace " \n\t\r")
(define chars-special "(){}[],@'`:")
(define chars-delim (str chars-whitespace chars-special ";"))
(define (in str char)
(number? (vector-find str char)))
(define (vec-getter i)
(lambda (vec)
(vector-ref vec i)))
(define (read src)
(define index 0)
(define len (vector-length src))
(define lineno 0)
(define colno 0)
(define (current)
(if (finished)
""
(vector-ref src index)))
(define (previous)
(vector-ref src (- index 1)))
(define (forward)
(set! index (+ index 1))
(if (== (previous) "\n")
(begin
(set! lineno (+ lineno 1))
(set! colno 0))
(set! colno (+ colno 1))))
(define (back)
(set! index (- index 1))
(if (== (current) "\n")
(set! lineno (- lineno 1))))
(define (finished)
(>= index len))
(define (skip-whitespace)
(let loop ()
(if (in chars-whitespace (current))
(begin
(forward)
(loop)))))
(define (parse-string lineno colno)
(let loop ((s ""))
(forward)
(cond
((== (current) "\\")
(forward)
(loop
(str s (let ((c (current)))
(cond
((== c "n") "\n")
((== c "t") "\t")
((== c "r") "\r")
(else c))))))
((== (current) "\"") (make-token 'STRING s lineno colno))
(else (loop (str s (current)))))))
(define (parse-token s lineno colno)
(cond
((s.match (RegExp "^[-+]?[0-9]+$")) (make-token 'INTEGER s lineno colno))
((s.match (RegExp "^[-+]?[0-9]+\\.[0-9]*$")) (make-token 'FLOAT s lineno colno))
((s.match (RegExp "^[-+]?0x"))
(let ((m (s.match (RegExp "0x([0-9a-fA-F]+)$")))
(prefix (if (== (vector-ref s 0) "-") "-" "")))
(if m
(make-token 'HEX (str prefix (vector-ref m 1)) lineno colno)
(throw (str "invalid hex value: " s)))))
((or (== s "#f") (== s "#t")) (make-token 'BOOLEAN s lineno colno))
(else (make-token 'SYMBOL s lineno colno))))
(define (parse-comment lineno colno)
(let loop ((s ""))
(forward)
(if (or (finished)
(== (current) "\n"))
(make-token 'COMMENT s lineno colno)
(loop (str s (current))))))
;; tokens
;; create a unique reference to disambiguate internal objects in the
;; reader
(define unique-obj (list #t))
(define (make-token type data lineno colno)
[unique-obj type data lineno colno])
(define token-type (vec-getter 1))
(define token-data (vec-getter 2))
(define token-lineno (vec-getter 3))
(define token-colno (vec-getter 4))
(define (token? tok)
(and (vector? tok)
(== (vector-ref tok 0) unique-obj)))
(define (get-token)
(skip-whitespace)
(let ((c (current))
(lineno lineno)
(colno colno))
(cond
((in chars-special c)
(forward)
(make-token 'SPECIAL c lineno colno))
((== c "\"")
(let ((s (parse-string lineno colno)))
(forward)
s))
((== c ";")
(parse-comment lineno colno))
((== c "") #f)
((finished) #f)
(else
(let loop ((s ""))
(if (or (in chars-delim (current))
(finished))
(parse-token s lineno colno)
(begin
(forward)
(loop (str s (previous))))))))))
;; parser
(define (token->exp token)
(let ((type (token-type token))
(data (token-data token)))
(cond
((== type 'STRING) data)
((== type 'SYMBOL) (string->symbol data))
((== type 'BOOLEAN) (if (== data "#f") #f #t))
((== type 'INTEGER) (parseInt data))
((== type 'FLOAT) (parseFloat data))
((== type 'HEX) (parseInt data 16))
(else
(throw (str "cannot convert token to exp: " token))))))
(define (special? t chars)
(and (token? t)
(== (token-type t) 'SPECIAL)
(in chars (token-data t))))
(define (compound-start? t)
(or (special? t "(")
(special? t "[")
(special? t "{")))
(define (compound-end? t)
(or (special? t ")")
(special? t "]")
(special? t "}")))
(define (end? t)
(and (token? t)
(== (token-type t) 'END)))
(define (read-exp)
(let ((token (get-token)))
(cond
((not token)
(make-token 'END #f #f #f))
((compound-end? token)
;; we simply return the token so the list/vector/dict loop
;; knows when to end
token)
((compound-start? token)
(let loop ((lst '())
(exp (read-exp)))
(if (or (end? exp)
(compound-end? exp))
(begin
;; the loop will only break when it hits the end of
;; file or an end delimiter, so we check the current
;; character and move forward
(define in-list? (special? token "("))
(define in-vector? (special? token "["))
(define in-dict? (special? token "{"))
(cond
((and in-list? (special? exp ")")) (ast.make-node 'LIST (reverse lst)
(token-lineno token)
(token-colno token)))
((and in-vector? (special? exp "]")) (ast.make-node 'VECTOR (reverse lst)
(token-lineno token)
(token-colno token)))
((and in-dict? (special? exp "}")) (ast.make-node 'DICT (reverse lst)
(token-lineno token)
(token-colno token)))
(else
(throw (str "unterminated "
(cond
(list? "list")
(vector? "vector")
(dict? "dict")))))))
(begin
(loop (cons exp lst) (read-exp))))))
((special? token "'")
(ast.make-node
'LIST
(list (ast.make-node 'ATOM 'quote
(token-lineno token)
(token-colno token))
(read-exp))
(token-lineno token)
(token-colno token)))
((special? token ":")
(let ((e (read-exp)))
(if (or (not (ast.atom? e))
(not (symbol? (ast.node-data e))))
(throw (str "invalid key expression: " (ast.node-data e))))
(ast.make-node 'ATOM (symbol->key (ast.node-data e))
(token-lineno token)
(token-colno token))))
((special? token "`")
(ast.make-node
'LIST
(list (ast.make-node 'ATOM 'quasiquote
(token-lineno token)
(token-colno token))
(read-exp))
(token-lineno token)
(token-colno token)))
((special? token ",")
(let ((next (current)))
(if (== next "@")
(begin
(forward)
(ast.make-node
'LIST
(list (ast.make-node 'ATOM 'unquote-splicing
(token-lineno token)
(token-colno token))
(read-exp))
(token-lineno token)
(token-colno token)))
(begin
(ast.make-node
'LIST
(list (ast.make-node 'ATOM 'unquote
(token-lineno token)
(token-colno token))
(read-exp))
(token-lineno token)
(token-colno token))))))
(else
(if (== (token-type token) 'COMMENT)
(read-exp)
(ast.make-node 'ATOM
(token->exp token)
(token-lineno token)
(token-colno token)))))))
(let loop ((e* '())
(e (read-exp)))
(if (end? e)
(if (== (length e*) 1)
(car e*)
(ast.make-node 'LIST
(cons (ast.make-node 'ATOM 'begin 0 1)
(reverse e*))
0 0))
(loop (cons e e*) (read-exp)))))
(set! module.exports {:read read})