(import (scheme base)
        (scheme cxr)
        (scheme file)
        (scheme read)
        (scheme write))

(define (read-declarations-from-file filename)
  (let ((bytes (let ((bytes (call-with-port
                             (open-binary-input-file filename)
                             (lambda (port) (read-bytevector 1000 port)))))
                 (if (eof-object? bytes) (make-bytevector 0) bytes)))
        (i 0))
    (define (peek-next-ascii-byte)
      (if (not (< i (bytevector-length bytes)))
          (eof-object)
          (let ((next-byte (bytevector-u8-ref bytes i)))
            (if (<= 1 next-byte 126)
                next-byte
                (begin (set! i (+ i 1))
                       (peek-next-ascii-byte))))))
    (define (read-char? k)
      (let* ((next-byte (peek-next-ascii-byte))
             (next-char (if (eof-object? next-byte)
                            next-byte
                            (integer->char next-byte)))
             (consume? (cond ((procedure? k) (k next-char))
                             ((char? k) (eqv? k next-char))
                             (else #f))))
        (cond (consume?
               (set! i (+ i 1))
               next-char)
              (else
               #f))))
    (define (whitespace-char? c)
      (or (eqv? c #\space)
          (eqv? c #\tab)
          (eqv? c #\newline)
          (eqv? c #\return)))
    (define (not-special-char? c)
      (not (or (eof-object? c)
               (whitespace-char? c)
               (eqv? c #\")
               (eqv? c #\()
               (eqv? c #\)))))
    (define (string-char? c)
      (not (or (eof-object? c)
               (eqv? c #\tab)
               (eqv? c #\newline)
               (eqv? c #\return)
               (eqv? c #\")
               (eqv? c #\\))))
    (define (skip-char* k)
      (when (read-char? k) (skip-char* k)))
    (define (read-rest-of-line)
      (read-char* (lambda (c) (not (or (eof-object? c) (eqv? c #\newline))))))
    (define (skip-whitespace-and-comments)
      (cond ((read-char? #\;)
             (read-rest-of-line)
             (skip-whitespace-and-comments))
            ((read-char? whitespace-char?)
             (skip-char* whitespace-char?)
             (skip-whitespace-and-comments))
            (else #f)))
    (define (read-char* k)
      (let loop ((chars '()))
        (let ((c (read-char? k)))
          (if (not c)
              (if (null? chars)
                  #f
                  (list->string chars))
              (loop (append chars (list c)))))))
    (define (read-string)
      (let loop ((chars '()))
        (if (read-char? #\")
            (list->string chars)
            (let ((c (read-char? string-char?)))
              (if (not c)
                  (eof-object)
                  (loop (append chars (list c))))))))
    (define (read-list)
      (let loop ((xs '()))
        (skip-whitespace-and-comments)
        (if (read-char? #\))
            xs
            (let ((x (read-form)))
              (if (eof-object? x)
                  x
                  (loop (append xs (list x))))))))
    (define (read-form)
      (skip-whitespace-and-comments)
      (cond ((read-char? #\()
             (read-list))
            ((read-char? #\")
             (read-string))
            (else
             (let ((symbol-name (read-char* not-special-char?)))
               (if symbol-name
                   (string->symbol symbol-name)
                   (eof-object))))))
    (let* ((shebang (if (and (read-char? #\#) (read-char? #\!))
                        (read-rest-of-line)
                        #f))
           (first-form (read-form))
           (declarations (or (and (list? first-form)
                                  (eqv? 'declare-file (car first-form))
                                  (cdr first-form))
                             '())))
      (if shebang
          (cons (list 'shebang shebang) declarations)
          declarations))))

(define (writeln x)
  (write x)
  (newline))

(define (try-file filename)
  (for-each writeln (read-declarations-from-file filename))
  (newline))

(try-file "test-big5.scm")
(try-file "test-euc-jp.scm")
(try-file "test-shift-jis.scm")
(try-file "test-utf16-be.scm")
(try-file "test-utf16-le.scm")