JSON パーサを R6RS 化するパッチ

patch.patch

--- parser.scm.org	2015-01-26 11:13:28 +0900
+++ parser.scm	2015-01-26 18:28:49 +0900
@@ -25,33 +25,20 @@
 
 ;;; Code:
 
-(define-module (json parser)
-  #:use-module (ice-9 rdelim)
-  #:use-module (rnrs bytevectors)
-  #:use-module (srfi srfi-9)
-  #:export (json->scm
-            json-string->scm
-            json-parser?
-            json-parser-port))
+(library (json parser)
+  (export json->scm json-string->scm)
+  (import (rnrs))
+
+(define (parser-read-delimited port delim)
+  (call-with-values open-string-output-port
+    (lambda(out get)
+      (do ((ch (get-char port) (get-char port)))
+          ((exists (lambda(x) (equal? ch x)) delim)
+           (cons (get) ch))
+        (write-char ch out)))))
 
-;;
-;; Parser record and read helpers
-;;
-
-(define-record-type json-parser
-  (make-json-parser port)
-  json-parser?
-  (port json-parser-port))
-
-(define (parser-peek-char parser)
-  (peek-char (json-parser-port parser)))
-
-(define (parser-read-char parser)
-  (read-char (json-parser-port parser)))
-
-(define (parser-read-delimited parser delim handle-delim)
-  (let ((port (json-parser-port parser)))
-    (read-delimited delim port handle-delim)))
+(define (string-null? str)
+  (string=? "" str))
 
 ;;
 ;; Number parsing helpers
@@ -59,34 +46,33 @@
 
 ;; Read + or -. . If something different is found, return empty string.
 (define (read-sign parser)
-  (let loop ((c (parser-peek-char parser)) (s ""))
+  (let ((c (peek-char parser)))
     (case c
       ((#\+ #\-)
-       (let ((ch (parser-read-char parser)))
-         (string-append s (string ch))))
+       (string (get-char parser)))
       (else s))))
 
 ;; Read digits [0..9]. If something different is found, return empty
 ;; string.
 (define (read-digits parser)
-  (let loop ((c (parser-peek-char parser)) (s ""))
+  (let loop ((c (peek-char parser)) (s ""))
     (case c
       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-       (let ((ch (parser-read-char parser)))
-         (loop (parser-peek-char parser)
+       (let ((ch (get-char parser)))
+         (loop (peek-char parser)
                (string-append s (string ch)))))
       (else s))))
 
 (define (read-exp-part parser)
-  (let ((c (parser-peek-char parser)) (s ""))
+  (let ((c (peek-char parser)) (s ""))
     (case c
       ;; Stop parsing if whitespace found.
-      ((#\ht #\vt #\lf #\cr #\sp) s)
+      ((#\tab #\vtab #\linefeed #\return #\space) s)
       ;; We might be in an array or object, so stop here too.
       ((#\, #\] #\}) s)
       ;; We might have the exponential part
       ((#\e #\E)
-       (let ((ch (parser-read-char parser)) ; current char
+       (let ((ch (get-char parser)) ; current char
              (sign (read-sign parser))
              (digits (read-digits parser)))
          ;; If we don't have sign or digits, we have an invalid
@@ -100,15 +86,15 @@
       (else #f))))
 
 (define (read-real-part parser)
-  (let ((c (parser-peek-char parser)) (s ""))
+  (let ((c (peek-char parser)) (s ""))
     (case c
       ;; Stop parsing if whitespace found.
-      ((#\ht #\vt #\lf #\cr #\sp) s)
+      ((#\tab #\vtab #\linefeed #\return #\space) s)
       ;; We might be in an array or object, so stop here too.
       ((#\, #\] #\}) s)
       ;; If we read . we might have a real number
       ((#\.)
-       (let ((ch (parser-read-char parser))
+       (let ((ch (get-char parser))
              (digits (read-digits parser)))
          ;; If we have digits, try to read the exponential part,
          ;; otherwise we have an invalid number.
@@ -124,31 +110,31 @@
       (else #f))))
 
 (define (read-number parser)
-  (let loop ((c (parser-peek-char parser)) (s ""))
+  (let loop ((c (peek-char parser)) (s ""))
     (case c
       ;; Stop parsing if whitespace found.
-      ((#\ht #\vt #\lf #\cr #\sp) s)
+      ((#\tab #\vtab #\linefeed #\return #\space) s)
       ;; We might be in an array or object, so stop here too.
       ((#\, #\] #\}) s)
       ((#\-)
-       (let ((ch (parser-read-char parser)))
-         (loop (parser-peek-char parser)
+       (let ((ch (get-char parser)))
+         (loop (peek-char parser)
                (string-append s (string ch)))))
       ((#\0)
-       (let ((ch (parser-read-char parser)))
+       (let ((ch (get-char parser)))
          (string-append s
                         (string ch)
                         (or (read-real-part parser)
-                            (throw 'json-invalid parser)))))
+                            (error 'json-invalid parser)))))
       ((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-       (let ((ch (parser-read-char parser)))
+       (let ((ch (get-char parser)))
          (string-append s
                         (string ch)
                         (read-digits parser)
                         (or (read-real-part parser)
                             (read-exp-part parser)
-                            (throw 'json-invalid parser)))))
-      (else (throw 'json-invalid parser)))))
+                            (error 'json-invalid parser)))))
+      (else (error 'json-invalid parser)))))
 
 ;;
 ;; Object parsing helpers
@@ -157,62 +143,62 @@
 (define (read-pair parser)
   ;; Read string key
   (let ((key (json-read-string parser)))
-    (let loop ((c (parser-peek-char parser)))
+    (let loop ((c (peek-char parser)))
       (case c
       ;; Skip whitespaces
-      ((#\ht #\vt #\lf #\cr #\sp)
-       (parser-read-char parser)
-       (loop (parser-peek-char parser)))
+      ((#\tab #\vtab #\linefeed #\return #\space)
+       (get-char parser)
+       (loop (peek-char parser)))
       ;; Skip colon and read value
       ((#\:)
-       (parser-read-char parser)
+       (get-char parser)
        (cons key (json-read parser)))
       ;; invalid object
-      (else (throw 'json-invalid parser))))))
+      (else (error 'json-invalid parser))))))
 
 (define (read-object parser)
-  (let loop ((c (parser-peek-char parser))
-             (pairs (make-hash-table)))
+  (let loop ((c (peek-char parser))
+             (pairs '()))
     (case c
       ;; Skip whitespaces
-      ((#\ht #\vt #\lf #\cr #\sp)
-       (parser-read-char parser)
-       (loop (parser-peek-char parser) pairs))
+      ((#\tab #\vtab #\linefeed #\return #\space)
+       (get-char parser)
+       (loop (peek-char parser) pairs))
       ;; end of object
       ((#\})
-       (parser-read-char parser)
-       pairs)
+       (get-char parser)
+       (list->vector pairs))
       ;; Read one pair and continue
       ((#\")
        (let ((pair (read-pair parser)))
-         (hash-set! pairs (car pair) (cdr pair))
-         (loop (parser-peek-char parser) pairs)))
+         (set! pairs (cons pair pairs))
+         (loop (peek-char parser) pairs)))
       ;; Skip comma and read more pairs
       ((#\,)
-       (parser-read-char parser)
-       (loop (parser-peek-char parser) pairs))
+       (get-char parser)
+       (loop (peek-char parser) pairs))
       ;; invalid object
-      (else (throw 'json-invalid parser)))))
+      (else (error 'json-invalid parser)))))
 
 ;;
 ;; Array parsing helpers
 ;;
 
 (define (read-array parser)
-  (let loop ((c (parser-peek-char parser)) (values '()))
+  (let loop ((c (peek-char parser)) (values '()))
     (case c
       ;; Skip whitespace and comma
-      ((#\ht #\vt #\lf #\cr #\sp #\,)
-       (parser-read-char parser)
-       (loop (parser-peek-char parser) values))
+      ((#\tab #\vtab #\linefeed #\return #\space #\,)
+       (get-char parser)
+       (loop (peek-char parser) values))
       ;; end of array
       ((#\])
-       (parser-read-char parser)
+       (get-char parser)
        values)
       ;; this can be any json object
       (else
        (let ((value (json-read parser)))
-         (loop (parser-peek-char parser)
+         (loop (peek-char parser)
                (append values (list value))))))))
 
 ;;
@@ -220,9 +206,9 @@
 ;;
 
 (define (expect parser expected)
-  (let ((ch (parser-read-char parser)))
+  (let ((ch (get-char parser)))
     (if (not (char=? ch expected))
-      (throw 'json-invalid parser)
+      (error 'json-invalid parser)
       ch)))
 
 (define (expect-string parser expected)
@@ -231,36 +217,30 @@
         (string->list expected))))
 
 (define (read-hex-digit parser)
-  (let ((c (parser-read-char parser)))
+  (let ((c (get-char parser)))
     (case c
       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
         #\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f) c)
-      (else (throw 'json-invalid parser)))))
+      (else (error 'json-invalid parser)))))
 
 (define (read-control-char parser)
-  (let ((c (parser-read-char parser)))
+  (let ((c (get-char parser)))
     (case c
       ((#\" #\\ #\/) (string c))
-      ((#\b) (string #\bs))
-      ((#\f) (string #\ff))
-      ((#\n) (string #\lf))
-      ((#\r) (string #\cr))
-      ((#\t) (string #\ht))
+      ((#\b) (string #\backspace))
+      ((#\f) (string #\page))
+      ((#\n) (string #\linefeed))
+      ((#\r) (string #\return))
+      ((#\t) (string #\tab))
       ((#\u)
-       (let* ((utf1 (string (read-hex-digit parser)
-                            (read-hex-digit parser)))
-              (utf2 (string (read-hex-digit parser)
-                            (read-hex-digit parser)))
-              (vu8 (list (string->number utf1 16)
-                         (string->number utf2 16)))
-              (utf (u8-list->bytevector vu8)))
-         (utf16->string utf)))
+       (let ((utf (string->number (get-string-n parser 4) 16)))
+         (string (integer->char utf))))
       (else #f))))
 
 (define (read-string parser)
   ;; Read characters until \ or " are found.
   (let loop ((result "")
-             (current (parser-read-delimited parser "\\\"" 'split)))
+             (current (parser-read-delimited parser '(#\" #\\))))
     (case (cdr current)
       ((#\")
        (string-append result (car current)))
@@ -268,10 +248,10 @@
        (let ((ch (read-control-char parser)))
          (if ch
              (loop (string-append result (car current) ch)
-                   (parser-read-delimited parser "\\\"" 'split))
-             (throw 'json-invalid parser ))))
+                   (parser-read-delimited parser '(#\" #\\)))
+             (error 'json-invalid parser ))))
       (else
-       (throw 'json-invalid parser)))))
+       (error 'json-invalid parser)))))
 
 ;;
 ;; Main parser functions
@@ -280,13 +260,14 @@
 (define-syntax json-read-delimited
   (syntax-rules ()
     ((json-read-delimited parser delim read-func)
-     (let loop ((c (parser-read-char parser)))
+     (let loop ((c (get-char parser)))
        (case c
          ;; skip whitespace
-         ((#\ht #\vt #\lf #\cr #\sp) (loop (parser-peek-char parser)))
+         ((#\tab #\vtab #\linefeed #\return #\space)
+          (loop (peek-char parser)))
          ;; read contents
          ((delim) (read-func parser))
-         (else (throw 'json-invalid parser)))))))
+         (else (error 'json-invalid parser)))))))
 
 (define (json-read-true parser)
   (expect-string parser "true")
@@ -298,7 +279,7 @@
 
 (define (json-read-null parser)
   (expect-string parser "null")
-  #nil)
+  'null)
 
 (define (json-read-object parser)
   (json-read-delimited parser #\{ read-object))
@@ -313,16 +294,16 @@
   (string->number (read-number parser)))
 
 (define (json-read parser)
-  (let loop ((c (parser-peek-char parser)))
+  (let loop ((c (peek-char parser)))
     (cond
      ;;If we reach the end we might have an incomplete document
-     ((eof-object? c) (throw 'json-invalid parser))
+     ((eof-object? c) (error 'json-invalid parser))
      (else
       (case c
         ;; skip whitespaces
-        ((#\ht #\vt #\lf #\cr #\sp)
-         (parser-read-char parser)
-         (loop (parser-peek-char parser)))
+        ((#\tab #\vtab #\linefeed #\return #\space)
+         (get-char parser)
+         (loop (peek-char parser)))
         ;; read json values
         ((#\t) (json-read-true parser))
         ((#\f) (json-read-false parser))
@@ -337,15 +318,10 @@
 ;; Public procedures
 ;;
 
-(define* (json->scm #:optional (port (current-input-port)))
-  "Parse a JSON document into native. Takes one optional argument,
-@var{port}, which defaults to the current input port from where the JSON
-document is read."
-  (json-read (make-json-parser port)))
-
-(define* (json-string->scm str)
-  "Parse a JSON document into native. Takes a string argument,
-@var{str}, that contains the JSON document."
-  (call-with-input-string str (lambda (p) (json->scm p))))
+(define (json->scm port)
+  (json-read port))
 
+(define (json-string->scm str)
+  (json->scm (open-string-input-port str)))
+)
 ;;; (json parser) ends here