Parser for simplest S-expression by using 1-character input in Scheme

sread-c1.scm

(define *lh* #f)
(define (get-token)
  (define (put-c1 x) (set! *lh* x))
  (define (null-c1) (set! *lh* #f))
  (define (get-c1) (if *lh* (let ((lh *lh*)) (null-c1) lh) (read-char)))
  (define (tstring t) (list->string (reverse t)))
  (define (skip-spaces)
    (do ((c (get-c1) (get-c1)))
        ((not (member c (string->list " \n\r"))) (put-c1 c))))
  (let loop ((c (get-c1)) (t '()))
    (cond ((member c (string->list " \n\r"))
           (cond ((null? t)
                  (skip-spaces)
                  (loop (get-c1) t))
                 (else (tstring t))))
          ((eq? c #\() (skip-spaces) (string c))
          ((eq? c #\))
           (if (null? t) (string c) (begin (put-c1 c) (tstring t))))
          (else (loop (get-c1) (cons c t))))))

(define (sread)
  (define (slist)
    (let ((t (get-token)))
      (cond ((equal? t ")") '())
            ((equal? t "(") (let ((h (slist))) (cons h (slist))))
            (else (cons t (slist))))))
  (let ((t (get-token)))
    (if (equal? t "(") (slist) t)))

(write (sread)) (newline)