1 ;;;============================================================================
5 ;;; Copyright (c) 2011 by Marc Feeley, All Rights Reserved.
7 ;;;============================================================================
9 (##namespace ("json#"))
11 (##include "~~lib/gambit#.scm")
13 (##include "json#.scm")
23 ;;;============================================================================
25 (define (json-read port)
27 (define (create-object props)
30 (define (create-array elements)
31 (list->vector elements))
39 (define (accum c i str)
40 (if (not (json-error? str))
41 (string-set! str i c))
44 (define (digit? c radix)
47 (cond ((and (char>=? c #\0) (char<=? c #\9))
48 (- (char->integer c) (char->integer #\0)))
49 ((and (char>=? c #\a) (char<=? c #\Z))
50 (+ 10 (- (char->integer c) (char->integer #\a))))
51 ((and (char>=? c #\A) (char<=? c #\Z))
52 (+ 10 (- (char->integer c) (char->integer #\A))))
62 (begin (rd) (space)))))
75 ((or (eqv? c #\-) (digit? c 10))
79 (if (not (and (eqv? (rd) #\a)
87 (if (not (and (eqv? (rd) #\r)
94 (if (not (and (eqv? (rd) #\u)
102 (define (parse-object)
106 (begin (rd) (create-object '()))
107 (let loop ((rev-elements '()))
108 (let ((str (if (not (eqv? (pk) #\")) json-error (parse-string))))
109 (if (json-error? str)
113 (if (not (eqv? (pk) #\:))
118 (let ((val (parse-value)))
119 (if (json-error? val)
121 (let ((new-rev-elements
122 (cons (cons str val) rev-elements)))
128 (reverse new-rev-elements)))
132 (loop new-rev-elements))
134 json-error))))))))))))))
136 (define (parse-array)
140 (begin (rd) (create-array '()))
141 (let ((x (parse-value)))
144 (let loop ((rev-elements (list x)))
149 (create-array (reverse rev-elements)))
152 (let ((y (parse-value)))
155 (loop (cons y rev-elements)))))
159 (define string-escapes
170 (define (parse-string)
172 (define (parse-str pos)
179 (let loop ((n 0) (i 4))
182 (cond ((not (char? h))
187 (loop (+ (* n 16) d) (- i 1))))
190 (accum (integer->char n) pos (parse-str (+ pos 1)))))
191 (let ((e (assv x string-escapes)))
193 (accum (cdr e) pos (parse-str (+ pos 1)))
196 (accum c pos (parse-str (+ pos 1))))
203 (define (parse-number)
208 (begin (rd) (accum c 0 (after-sign-part 1)))
209 (after-sign-part 0))))
211 (define (after-sign-part pos)
212 (if (not (digit? (pk) 10))
216 (define (integer-part pos)
219 (begin (rd) (accum c pos (integer-part (+ pos 1))))
221 (begin (rd) (accum c pos (decimals-part (+ pos 1))))
222 (exponent-part pos)))))
224 (define (decimals-part pos)
227 (begin (rd) (accum c pos (decimals-part (+ pos 1))))
228 (exponent-part pos))))
230 (define (exponent-part pos)
232 (if (or (eqv? c #\e) (eqv? c #\E))
233 (begin (rd) (accum c pos (exponent-sign-part (+ pos 1))))
236 (define (exponent-sign-part pos)
238 (if (or (eqv? c #\-) (eqv? c #\+))
239 (begin (rd) (accum c pos (exponent-after-sign-part (+ pos 1))))
240 (exponent-after-sign-part pos))))
242 (define (exponent-after-sign-part pos)
243 (if (not (digit? (pk) 10))
245 (exponent-integer-part pos)))
247 (define (exponent-integer-part pos)
250 (begin (rd) (accum c pos (exponent-integer-part (+ pos 1))))
256 (let ((str (sign-part)))
257 (if (json-error? str)
259 (string->number str))))
266 (define (json-error? x)
269 ;;;============================================================================