reader.scm

;; from https://www.cs.rpi.edu/academics/courses/fall00/ai/scheme/reference/schintro-v14/schintro_115.html#SEC137

(define peeks '())

(define (assq k m)
  (if (null? m)
      #f
      (if (eq? k (car (car m)))
          (car m)
          (assq k (cdr m)))))

(define (del-assq k m)
  (if (null? m)
      m
      (if (eq? k (car (car m)))
          (cdr m)
          (cons (car m) (del-assq k (cdr m))))))

(define (read1-char port)
  (let ((pc (assq port peeks)))
    (if pc
        (begin
          (set! peeks (del-assq port peeks))
          (cdr pc))
        (read-char port))))

(define (peek-char port)
  (let ((c (read1-char port)))
    (set! peeks (cons (cons port c) peeks))
    c))

(define (char-numeric? c)
  (and (<= (char->fixnum #\0) (char->fixnum c))
       (<= (char->fixnum c) (char->fixnum #\9))))

(define (char-alphabetic? c)
  (or
   (and (<= (char->fixnum #\A) (char->fixnum c))
        (<= (char->fixnum c) (char->fixnum #\z)))
   (eq? #\+ c)
   (eq? #\- c)
   (eq? #\* c)
   (eq? #\? c)
   (eq? #\! c)
   (eq? #\> c)
   (eq? #\< c)
   (eq? #\= c)
   (eq? #\. c)))

(define (list->string xs)
  (apply string xs))

(define (list->vector xs)
  (apply vector xs))

(define (list->number xs (neg #f))
  (define (iter xs r)
    (if (null? xs)
        r
        (iter (cdr xs)
              (+ ((if neg - +)
                  0
                  (- (char->fixnum (car xs)) (char->fixnum #\0)))
                 (* 10 r)))))
  (iter xs 0))

(define (read-token port)
   (let ((first-char (read1-char port)))
     (cond  ((eof-object? first-char)
             first-char)
            ((char-whitespace? first-char)
             (read-token port))
            ((or (eq? first-char #\( ) (eq? first-char #\[ ))
             left-paren-token)
            ((or (eq? first-char #\)) (eq? first-char #\] ))
             right-paren-token)
            ((and (eq? first-char #\.) (char-whitespace? (peek-char port)))
             dot-token)
            ((eq? first-char #\-)
             (let ((next-char (peek-char port)))
               (if (char-numeric? next-char)
                   (read-number #t (read1-char port) port)
                   (read-identifier first-char port))))
            ((char-alphabetic? first-char)
             (read-identifier first-char port))
            ((char-numeric? first-char)
             (read-number #f first-char port))
            ((eq? #\" first-char)
             (read-string first-char port))
            ((eq? #\' first-char)
             (list 'quote (read port)))
            ((eq? first-char #\#)
             (read-character first-char port))
            ((eq? first-char #\;)
             (read-comment first-char port)
             (read-token port))
            (else
             (error 'read-token (format "illegal lexical syntax: ~s" first-char))))))

(define (char-whitespace? char)
  (or (eq? char #\space)
      (eq? char #\newline)
      (eq? char #\tab)
      (eq? char #\return)))

(define left-paren-token (list '*left-paren-token*))
(define right-paren-token (list '*right-paren-token*))
(define dot-token (list '*dot-token*))
(define (token-leftpar? thing)
  (eq? thing left-paren-token))
(define (token-rightpar? thing)
  (eq? thing right-paren-token))
(define (token-dot? thing)
  (eq? thing dot-token))

(define (read-string chr port)
  (define (helper list-so-far)
    (let ((next-char (read1-char port)))
      (if (eq? #\\ next-char)
          (helper (cons (read1-char port) list-so-far))
          (if (eq? #\" next-char)
              (list->string (reverse list-so-far))
              (helper (cons next-char list-so-far))))))
  (helper '()))

(define (read-character chr port)
  (let ((next-char (read1-char port)))
    (if (eq? next-char #\\)
        (let ((first-char (read1-char port)))
          (let ((s (read-identifier first-char port)))
            (cond ((eq? s 'space) #\space)
                  ((eq? s 'newline) #\newline)
                  ((eq? s 'tab) #\tab)
                  ((eq? s 'return) #\return)
                  (else first-char))))
        (if (eq? next-char #\t)
            #t
            (if (eq? next-char #\f)
                #f
                (if (eq? next-char #\()
                    (list->vector (read-list '() port))
                    (error 'read-character "expected bool, char or vector")))))))

(define (read-identifier chr port)
  (define (read-identifier-helper list-so-far)
    (let ((next-char (peek-char port)))
     (if (or (char-alphabetic? next-char)
              (char-numeric? next-char))
          (read-identifier-helper (cons (read1-char port) list-so-far))
          (reverse list-so-far))))
  (string->symbol (list->string (read-identifier-helper (list chr)))))

(define (read-number neg chr port)
  (define (read-number-helper list-so-far)
    (let ((next-char (peek-char port)))
      (if (char-numeric? next-char)
          (read-number-helper (cons (read1-char port) list-so-far))
          (reverse list-so-far))))
  (list->number (read-number-helper (list chr)) neg))

(define (read-comment chr port)
  (define (slurp-line port)
    (let ((next-char (read1-char port)))
      (if (eq? next-char #\newline)
          #t
          (slurp-line port))))
  (let ((next-char (read1-char port)))
    (if (eq? next-char chr)
        (slurp-line port)
        (error 'read-comment "expected a comment"))))

(define (read port)
   (let ((next-token (read-token port)))
      (cond ((token-leftpar? next-token)
             (read-list '() port))
            (else
             next-token))))
(define (read-list list-so-far port)
  (let ((token (read-token port)))
    (cond ((token-rightpar? token)
           (reverse list-so-far))
          ((token-leftpar? token)
           (read-list (cons (read-list '() port) list-so-far) port))
          ((token-dot? token)
           (let* ((rest (read-token port))
                  (r (read-token port)))
             (if (token-rightpar? r)
                 (append (reverse list-so-far) rest)
                 (error (format "unexpected dotted list ~s ~s" rest r)))))
          (else
           (read-list (cons token list-so-far) port)))))