Initial commit

encoding-reader.scm

@@ -0,0 +1,91 @@
+(import (scheme base)
+        (scheme cxr)
+        (scheme file)
+        (scheme read)
+        (scheme write))
+
+(define (read-encoding 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 (read-char? k)
+      (let* ((remain? (< i (bytevector-length bytes)))
+             (next-byte (if remain?
+                            (bytevector-u8-ref bytes i)
+                            (eof-object)))
+             (next-char (cond ((eof-object? next-byte)
+                               next-byte)
+                              ((<= 1 next-byte 126)
+                               (integer->char next-byte))
+                              (else
+                               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 (skip-char* k)
+      (when (read-char? k) (skip-char* k)))
+    (define (skip-rest-of-line)
+      (skip-char* (lambda (c) (not (or (eof-object? c) (eqv? c #\newline))))))
+    (define (skip-whitespace-and-comments)
+      (cond ((read-char? #\;)
+             (skip-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-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)
+      (if (read-char? #\()
+          (read-list)
+          (let ((symbol-name (read-char* not-special-char?)))
+            (if symbol-name
+                (string->symbol symbol-name)
+                (eof-object)))))
+    (let* ((form (read-form))
+           (coding-pair (and (list? form) (assoc 'coding (cdr form))))
+           (coding (if (and coding-pair
+                            (pair? (cdr coding-pair))
+                            (null? (cddr coding-pair))
+                            (symbol? (cadr coding-pair)))
+                       (cadr coding-pair)
+                       #f)))
+      coding)))
+
+(display (read-encoding "test.scm"))
+(newline)

test-chibi.sh

@@ -0,0 +1,2 @@
+#!/bin/sh
+chibi-scheme encoding-reader.scm

test-gauche.sh

@@ -0,0 +1,2 @@
+#!/bin/sh
+gosh encoding-reader.scm

test.scm

@@ -0,0 +1,4 @@
+(declare-file
+ (coding shift_jis))
+
+(display "こんにちは世界")