Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
110 lines (104 sloc) 3.25 KB
(define *eof* '*eof*)
(defmacro get-char (c body)
(list 'if '(< i len)
(list 'let (list (list c '(string-ref str i))) body)
'(error "end of file")))
(defmacro call-read (v i read body)
(list 'let* (list (list '*result* read)
(list v '(car *result*))
(list i '(cdr *result*)))
(define (internal-read-from-string str)
(let ((len (string-length str)))
(letrec ((return (lambda (v i)
(cons v i)))
(consume (lambda (i pred)
(if (< i len)
(if (pred (string-ref str i))
(consume (+ i 1) pred)
(consume-ws (lambda (i)
(consume i char-whitespace?)))
(accept (lambda (i c)
(let ((i (consume-ws i)))
(if (< i len)
(if (eq? (string-ref str i) c)
(+ i 1)
(error "expected " c))
(error "expected " c)))))
(read-list (lambda (i)
(get-char c
(case c
(return '() (+ i 1)))
(call-read v i (read-at-i (consume-ws (+ i 1)))
(return v (accept i #\)))))
(call-read v i (read-at-i i)
(call-read rest i (read-list (consume-ws i))
(return (cons v rest) i))))))))
(read-symbol (lambda (i)
(let ((j (consume i (lambda (c)
(and (not (char-whitespace? c))
(not (memq c '(#\( #\)))))))))
(return (string->symbol (substring str i j)) j))))
(read-char-name (lambda (i)
(let ((j (consume i char-alphabetic?)))
(if (= (- j i) 1)
(return (string-ref str i) j)
(let* ((name (substring str i j))
(entry (assoc name '(("space" . #\space)
("newline" . #\newline)
("ht" . #\ht)))))
(if entry
(return (cdr entry) j)
(error "unknown char " name)))))))
(read-char (lambda (i)
(get-char c
(if (char-alphabetic? c)
(read-char-name i)
(return c (+ i 1))))))
(read-special (lambda (i)
(get-char c
(case c
((#\t) (return #t (+ i 1)))
((#\f) (return #f (+ i 1)))
((#\\) (read-char (+ i 1)))
(else (error "invalid special " c))))))
(read-number (lambda (i)
(let ((j (consume i char-numeric?)))
(return (string->number (substring str i j)) j))))
(read-string (lambda (i)
(let ((j (consume i (lambda (c) (not (eq? c #\"))))))
(return (substring str i j) (+ j 1)))))
(read-at-i (lambda (i)
(get-char c
(case c
((#\() (read-list (consume-ws (+ i 1))))
((#\#) (read-special (+ i 1)))
((#\') (call-read v ii (read-at-i (consume-ws (+ i 1)))
(return (list 'quote v) ii)))
((#\") (read-string (+ i 1)))
(if (char-numeric? c)
(read-number i)
(read-symbol i))))))))
(let ((i (consume-ws 0)))
(if (< i len)
(read-at-i i)
(define (read-from-string str)
(let ((result (internal-read-from-string str)))
(if (eq? result *eof*)
(car result))))
(define (read-exprs-from-string str)
(letrec ((recur (lambda (str)
(let ((result (internal-read-from-string str)))
(if (eq? result *eof*)
(cons (car result)
(recur (substring str (cdr result) (string-length str)))))))))
(recur str)))