;; Read table features:
;;    - #!r6rs comments.
;;    - bytevector literals (reads, but signals an error since
;;      expander doesn't support them).
;;    - prohibits initial vertical bar in identifiers or symbols.

(module reader mzscheme
  (provide readtable
           (struct mzprim (quoted-require)))
  
  (define-struct mzprim (quoted-require))
  
  ;; for raise-read-[eof-]error:
  (require (lib "readerr.ss" "syntax"))
  
  (define (read-!dispatcher ch port src line col pos)
    (let ((ch (peek-char port)))
      (case ch
        ((#\r) (read-!r6rs      ch port src line col pos))
        ((#\m) (read-!mzprim ch port src line col pos))
        (else
         (raise-read-eof-error 
          "unexpected #!-lexeme"  
          src line col pos 1)))))
  
  (define (read-!mzprim ch port src line col pos)
    (for-each
     (λ (c len)
       (let ((ch (read-char port)))
         (cond ((eof-object? ch) 
                (raise-read-eof-error 
                 "unexpected end-of-file in #!mzprim"  
                 src line col pos len))
               ((not (char=? ch c))
                (raise-read-error 
                 (format "expected a #!r6rs-lexeme, found: #!~a~a" (substring "r6rs" 0 len) ch)
                 src line col pos (+ 2 len))))))
     '(#\m #\z #\p #\r #\i #\m)
     '(  0   1   2   3   4   5))
    
    (make-mzprim (read port)))
  
  ;; Reader macro for #!r6rs
  ;; Reads the characters "r6rs" (or fails)
  ;; and returns a comment.
  
  (define (read-!r6rs ch port src line col pos)
    (for-each
     (λ (c len)
       (let ((ch (read-char port)))
         (cond ((eof-object? ch) 
                (raise-read-eof-error 
                 "unexpected end-of-file in #!r6rs"  
                 src line col pos len))
               ((not (char=? ch c))
                (raise-read-error 
                 (format "expected a #!r6rs-lexeme, found: #!~a~a" (substring "r6rs" 0 len) ch)
                 src line col pos (+ 2 len))))))
     '(#\r #\6 #\r #\s)
     '(  0   1   2   3))
    (make-special-comment '!r6rs))
  
  ;; Reader macro for bytevector literals
  ;; Reads the characters "u8" (or fails)
  ;; Reads a list of octects (or fails)
  ;; Then signals an unsupported feature error.
  
  (define (read-vu8 ch port src line col pos)
    (for-each
     (λ (c len)
       (let ((ch (read-char port)))
         (cond ((eof-object? ch) 
                (raise-read-eof-error 
                 "unexpected end-of-file in #!r6rs"  
                 src line col pos len))
               ((not (char=? ch c))
                (raise-read-error 
                 (format "expected a #vu8, found: #v~a~a" (substring "u8" 0 len) ch)
                 src line col pos (+ 2 len))))))
     '(#\u #\8)
     '(  0   1))
    
    (let ((elems (read port)))
      (cond ((eof-object? elems)
             (raise-read-eof-error 
              "unexpected end-of-file in #vu8(---)"
              src line col pos 0))
            
            ((and (list? elems)
                  (andmap
                   (λ (n)
                     (and (integer? n)
                          (>= n 0)
                          (<= n 255)))
                   elems))
             (raise-read-error 
              (format "#vu8~a syntax is well-formed, but unsupported at this time." elems)
              src line col pos 1))
            
            (else
             (raise-read-error
              (format "expected #vu8(<u8> ...), found: #vu8~a" elems)
              src line col pos 1)))))
  
  (define (read-vertical-bar ch port src line col pos)
    (raise-read-error 
     "Vertical bar is not an initial character."
     src line col pos 1)) 
  
  (define readtable
    (make-readtable #f
                    #\! 'dispatch-macro read-!dispatcher
                    #\v 'dispatch-macro read-vu8
                    #\| 'non-terminating-macro read-vertical-bar
                    #\{ #\{ #f))
     
  ) ; end of module reader