encoding-declaration/encoding-reader.scm

123 lines
4.1 KiB
Scheme

(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-shift-jis.scm")
(try-file "test-utf16-be.scm")
(try-file "test-utf16-le.scm")