examples/iOS/json.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "json.scm"
   4
   5 ;;; Copyright (c) 2011 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 (##namespace ("json#"))
  10
  11 (##include "~~lib/gambit#.scm")
  12
  13 (##include "json#.scm")
  14
  15 (declare
  16   (standard-bindings)
  17   (extended-bindings)
  18   (block)
  19   (fixnum)
  20   (not safe)
  21 )
  22
  23 ;;;============================================================================
  24
  25 (define (json-read port)
  26
  27   (define (create-object props)
  28     (list->table props))
  29
  30   (define (create-array elements)
  31     (list->vector elements))
  32
  33   (define (rd)
  34     (read-char port))
  35
  36   (define (pk)
  37     (peek-char port))
  38
  39   (define (accum c i str)
  40     (if (not (json-error? str))
  41         (string-set! str i c))
  42     str)
  43
  44   (define (digit? c radix)
  45     (and (char? c)
  46          (let ((n
  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))))
  53                       (else
  54                        999))))
  55            (and (< n radix)
  56                 n))))
  57
  58   (define (space)
  59     (let ((c (pk)))
  60       (if (and (char? c)
  61                (char<=? c #\space))
  62           (begin (rd) (space)))))
  63
  64   (define (parse-value)
  65     (space)
  66     (let ((c (pk)))
  67       (if (not (char? c))
  68           json-error
  69           (cond ((eqv? c #\{)
  70                  (parse-object))
  71                 ((eqv? c #\[)
  72                  (parse-array))
  73                 ((eqv? c #\")
  74                  (parse-string))
  75                 ((or (eqv? c #\-) (digit? c 10))
  76                  (parse-number))
  77                 ((eqv? c #\f)
  78                  (rd)
  79                  (if (not (and (eqv? (rd) #\a)
  80                                (eqv? (rd) #\l)
  81                                (eqv? (rd) #\s)
  82                                (eqv? (rd) #\e)))
  83                      json-error
  84                      #f))
  85                 ((eqv? c #\t)
  86                  (rd)
  87                  (if (not (and (eqv? (rd) #\r)
  88                                (eqv? (rd) #\u)
  89                                (eqv? (rd) #\e)))
  90                      json-error
  91                      #t))
  92                 ((eqv? c #\n)
  93                  (rd)
  94                  (if (not (and (eqv? (rd) #\u)
  95                                (eqv? (rd) #\l)
  96                                (eqv? (rd) #\l)))
  97                      json-error
  98                      '()))
  99                 (else
 100                  json-error)))))
 101
 102   (define (parse-object)
 103     (rd) ;; skip #\{
 104     (space)
 105     (if (eqv? (pk) #\})
 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)
 110                 str
 111                 (begin
 112                   (space)
 113                   (if (not (eqv? (pk) #\:))
 114                       json-error
 115                       (begin
 116                         (rd)
 117                         (space)
 118                         (let ((val (parse-value)))
 119                           (if (json-error? val)
 120                               val
 121                               (let ((new-rev-elements
 122                                      (cons (cons str val) rev-elements)))
 123                                 (space)
 124                                 (let ((c (pk)))
 125                                   (cond ((eqv? c #\})
 126                                          (rd)
 127                                          (create-object
 128                                           (reverse new-rev-elements)))
 129                                         ((eqv? c #\,)
 130                                          (rd)
 131                                          (space)
 132                                          (loop new-rev-elements))
 133                                         (else
 134                                          json-error))))))))))))))
 135
 136   (define (parse-array)
 137     (rd) ;; skip #\[
 138     (space)
 139     (if (eqv? (pk) #\])
 140         (begin (rd) (create-array '()))
 141         (let ((x (parse-value)))
 142           (if (json-error? x)
 143               x
 144               (let loop ((rev-elements (list x)))
 145                 (space)
 146                 (let ((c (pk)))
 147                   (cond ((eqv? c #\])
 148                          (rd)
 149                          (create-array (reverse rev-elements)))
 150                         ((eqv? c #\,)
 151                          (rd)
 152                          (let ((y (parse-value)))
 153                            (if (json-error? y)
 154                                y
 155                                (loop (cons y rev-elements)))))
 156                         (else
 157                          json-error))))))))
 158
 159   (define string-escapes
 160     '((#\" . #\")
 161       (#\\ . #\\)
 162       (#\/ . #\/)
 163       (#\b . #\x08)
 164       (#\t . #\x09)
 165       (#\n . #\x0A)
 166       (#\v . #\x0B)
 167       (#\f . #\x0C)
 168       (#\r . #\x0D)))
 169
 170   (define (parse-string)
 171
 172     (define (parse-str pos)
 173       (let ((c (rd)))
 174         (cond ((eqv? c #\")
 175                (make-string pos))
 176               ((eqv? c #\\)
 177                (let ((x (rd)))
 178                  (if (eqv? x #\u)
 179                      (let loop ((n 0) (i 4))
 180                        (if (> i 0)
 181                            (let ((h (rd)))
 182                              (cond ((not (char? h))
 183                                     json-error)
 184                                    ((digit? h 16)
 185                                     =>
 186                                     (lambda (d)
 187                                       (loop (+ (* n 16) d) (- i 1))))
 188                                    (else
 189                                     json-error)))
 190                            (accum (integer->char n) pos (parse-str (+ pos 1)))))
 191                      (let ((e (assv x string-escapes)))
 192                        (if e
 193                            (accum (cdr e) pos (parse-str (+ pos 1)))
 194                            json-error)))))
 195               ((char? c)
 196                (accum c pos (parse-str (+ pos 1))))
 197               (else
 198                json-error))))
 199
 200     (rd) ;; skip #\"
 201     (parse-str 0))
 202
 203   (define (parse-number)
 204
 205     (define (sign-part)
 206       (let ((c (pk)))
 207         (if (eqv? c #\-)
 208             (begin (rd) (accum c 0 (after-sign-part 1)))
 209             (after-sign-part 0))))
 210
 211     (define (after-sign-part pos)
 212       (if (not (digit? (pk) 10))
 213           json-error
 214           (integer-part pos)))
 215
 216     (define (integer-part pos)
 217       (let ((c (pk)))
 218         (if (digit? c 10)
 219             (begin (rd) (accum c pos (integer-part (+ pos 1))))
 220             (if (eqv? c #\.)
 221                 (begin (rd) (accum c pos (decimals-part (+ pos 1))))
 222                 (exponent-part pos)))))
 223
 224     (define (decimals-part pos)
 225       (let ((c (pk)))
 226         (if (digit? c 10)
 227             (begin (rd) (accum c pos (decimals-part (+ pos 1))))
 228             (exponent-part pos))))
 229
 230     (define (exponent-part pos)
 231       (let ((c (pk)))
 232         (if (or (eqv? c #\e) (eqv? c #\E))
 233             (begin (rd) (accum c pos (exponent-sign-part (+ pos 1))))
 234             (done pos))))
 235
 236     (define (exponent-sign-part pos)
 237       (let ((c (pk)))
 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))))
 241
 242     (define (exponent-after-sign-part pos)
 243       (if (not (digit? (pk) 10))
 244           json-error
 245           (exponent-integer-part pos)))
 246
 247     (define (exponent-integer-part pos)
 248       (let ((c (pk)))
 249         (if (digit? c 10)
 250             (begin (rd) (accum c pos (exponent-integer-part (+ pos 1))))
 251             (done pos))))
 252
 253     (define (done pos)
 254       (make-string pos))
 255
 256     (let ((str (sign-part)))
 257       (if (json-error? str)
 258           str
 259           (string->number str))))
 260
 261   (parse-value))
 262
 263 (define json-error
 264   'json-error)
 265
 266 (define (json-error? x)
 267   (eq? x json-error))
 268
 269 ;;;============================================================================