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

sread-c1-dot.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"))
           (skip-spaces)
           (if (null? t) (loop (get-c1) t) (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))))
            ((equal? t ".") (car (slist)))
            (else (cons t (slist))))))
  (let ((t (get-token)))
    (if (equal? t "(") (slist) t)))

(write (sread)) (newline)