125 lines
4.2 KiB
Scheme
125 lines
4.2 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-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")
|