0000: 3b 3b 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 ;;.;; Copyright
0010: 32 30 31 36 20 41 6c 64 6f 20 4e 69 63 6f 6c 61 2016 Aldo Nicola
0020: 73 20 42 72 75 6e 6f 0a 3b 3b 0a 3b 3b 20 4c 69 s Bruno.;;.;; Li
0030: 63 65 6e 73 65 64 20 75 6e 64 65 72 20 74 68 65 censed under the
0040: 20 41 70 61 63 68 65 20 4c 69 63 65 6e 73 65 2c Apache License,
0050: 20 56 65 72 73 69 6f 6e 20 32 2e 30 20 28 74 68 Version 2.0 (th
0060: 65 20 22 4c 69 63 65 6e 73 65 22 29 3b 0a 3b 3b e "License");.;;
0070: 20 79 6f 75 20 6d 61 79 20 6e 6f 74 20 75 73 65 you may not use
0080: 20 74 68 69 73 20 66 69 6c 65 20 65 78 63 65 70 this file excep
0090: 74 20 69 6e 20 63 6f 6d 70 6c 69 61 6e 63 65 20 t in compliance
00a0: 77 69 74 68 20 74 68 65 20 4c 69 63 65 6e 73 65 with the License
00b0: 2e 0a 3b 3b 20 59 6f 75 20 6d 61 79 20 6f 62 74 ..;; You may obt
00c0: 61 69 6e 20 61 20 63 6f 70 79 20 6f 66 20 74 68 ain a copy of th
00d0: 65 20 4c 69 63 65 6e 73 65 20 61 74 0a 3b 3b 0a e License at.;;.
00e0: 3b 3b 20 20 20 20 20 68 74 74 70 3a 2f 2f 77 77 ;; http://ww
00f0: 77 2e 61 70 61 63 68 65 2e 6f 72 67 2f 6c 69 63 w.apache.org/lic
0100: 65 6e 73 65 73 2f 4c 49 43 45 4e 53 45 2d 32 2e enses/LICENSE-2.
0110: 30 0a 3b 3b 0a 3b 3b 20 55 6e 6c 65 73 73 20 72 0.;;.;; Unless r
0120: 65 71 75 69 72 65 64 20 62 79 20 61 70 70 6c 69 equired by appli
0130: 63 61 62 6c 65 20 6c 61 77 20 6f 72 20 61 67 72 cable law or agr
0140: 65 65 64 20 74 6f 20 69 6e 20 77 72 69 74 69 6e eed to in writin
0150: 67 2c 20 73 6f 66 74 77 61 72 65 0a 3b 3b 20 64 g, software.;; d
0160: 69 73 74 72 69 62 75 74 65 64 20 75 6e 64 65 72 istributed under
0170: 20 74 68 65 20 4c 69 63 65 6e 73 65 20 69 73 20 the License is
0180: 64 69 73 74 72 69 62 75 74 65 64 20 6f 6e 20 61 distributed on a
0190: 6e 20 22 41 53 20 49 53 22 20 42 41 53 49 53 2c n "AS IS" BASIS,
01a0: 0a 3b 3b 20 57 49 54 48 4f 55 54 20 57 41 52 52 .;; WITHOUT WARR
01b0: 41 4e 54 49 45 53 20 4f 52 20 43 4f 4e 44 49 54 ANTIES OR CONDIT
01c0: 49 4f 4e 53 20 4f 46 20 41 4e 59 20 4b 49 4e 44 IONS OF ANY KIND
01d0: 2c 20 65 69 74 68 65 72 20 65 78 70 72 65 73 73 , either express
01e0: 20 6f 72 20 69 6d 70 6c 69 65 64 2e 0a 3b 3b 20 or implied..;;
01f0: 53 65 65 20 74 68 65 20 4c 69 63 65 6e 73 65 20 See the License
0200: 66 6f 72 20 74 68 65 20 73 70 65 63 69 66 69 63 for the specific
0210: 20 6c 61 6e 67 75 61 67 65 20 67 6f 76 65 72 6e language govern
0220: 69 6e 67 20 70 65 72 6d 69 73 73 69 6f 6e 73 20 ing permissions
0230: 61 6e 64 0a 3b 3b 20 6c 69 6d 69 74 61 74 69 6f and.;; limitatio
0240: 6e 73 20 75 6e 64 65 72 20 74 68 65 20 4c 69 63 ns under the Lic
0250: 65 6e 73 65 2e 0a 0a 23 21 63 68 65 7a 73 63 68 ense...#!chezsch
0260: 65 6d 65 0a 28 6c 69 62 72 61 72 79 20 0a 20 28 eme.(library . (
0270: 6a 73 6f 6e 29 0a 20 28 65 78 70 6f 72 74 20 70 json). (export p
0280: 61 72 73 65 2d 6a 73 6f 6e 2d 73 74 72 20 72 65 arse-json-str re
0290: 61 64 2d 66 69 6c 65 20 6c 65 74 2d 6a 73 6f 6e ad-file let-json
02a0: 2d 6f 62 6a 65 63 74 20 73 74 72 69 6e 67 2d 3e -object string->
02b0: 6a 73 6f 6e 20 6a 73 6f 6e 2d 3e 73 74 72 69 6e json json->strin
02c0: 67 29 0a 20 28 69 6d 70 6f 72 74 20 28 73 72 66 g). (import (srf
02d0: 69 20 73 31 34 20 63 68 61 72 2d 73 65 74 73 29 i s14 char-sets)
02e0: 0a 09 20 28 73 63 68 65 6d 65 29 0a 09 20 28 6f .. (scheme).. (o
02f0: 6e 6c 79 20 28 64 61 74 61 2d 73 74 72 75 63 74 nly (data-struct
0300: 75 72 65 73 29 20 73 74 72 69 6e 67 2d 69 6e 74 ures) string-int
0310: 65 72 73 70 65 72 73 65 20 73 74 72 69 6e 67 2d ersperse string-
0320: 74 72 61 6e 73 6c 61 74 65 2a 29 29 0a 0a 20 28 translate*)).. (
0330: 69 6e 63 6c 75 64 65 20 22 6c 61 6c 72 2f 61 73 include "lalr/as
0340: 73 6f 63 69 61 74 6f 72 73 2e 73 73 22 29 0a 20 sociators.ss").
0350: 28 69 6e 63 6c 75 64 65 20 22 6c 61 6c 72 2f 6c (include "lalr/l
0360: 61 6c 72 2e 73 73 22 29 0a 0a 20 28 64 65 66 69 alr.ss").. (defi
0370: 6e 65 20 28 70 61 72 73 65 2d 6a 73 6f 6e 2d 73 ne (parse-json-s
0380: 74 72 20 70 6f 73 20 64 61 74 61 20 65 73 63 61 tr pos data esca
0390: 70 69 6e 67 20 6f 75 74 29 0a 20 20 20 28 63 6f ping out). (co
03a0: 6e 64 0a 20 20 20 20 5b 28 3e 3d 20 70 6f 73 20 nd. [(>= pos
03b0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 (string-length d
03c0: 61 74 61 29 29 0a 20 20 20 20 20 28 65 72 72 6f ata)). (erro
03d0: 72 20 27 70 61 72 73 65 2d 6a 73 6f 6e 2d 73 74 r 'parse-json-st
03e0: 72 20 22 65 72 72 6f 72 20 75 6e 65 78 70 65 63 r "error unexpec
03f0: 74 65 64 20 65 6e 64 20 6f 66 20 73 74 72 69 6e ted end of strin
0400: 67 22 29 5d 0a 20 20 20 20 5b 28 61 6e 64 20 28 g")]. [(and (
0410: 63 68 61 72 3d 3f 20 28 73 74 72 69 6e 67 2d 72 char=? (string-r
0420: 65 66 20 64 61 74 61 20 70 6f 73 29 20 23 5c 22 ef data pos) #\"
0430: 29 20 28 6e 6f 74 20 65 73 63 61 70 69 6e 67 29 ) (not escaping)
0440: 29 0a 20 20 20 20 20 28 76 61 6c 75 65 73 20 28 ). (values (
0450: 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 28 72 65 list->string (re
0460: 76 65 72 73 65 20 6f 75 74 29 29 20 70 6f 73 29 verse out)) pos)
0470: 5d 0a 20 20 20 20 5b 65 6c 73 65 0a 20 20 20 20 ]. [else.
0480: 20 28 6c 65 74 20 28 5b 63 68 61 72 20 28 73 74 (let ([char (st
0490: 72 69 6e 67 2d 72 65 66 20 64 61 74 61 20 70 6f ring-ref data po
04a0: 73 29 5d 29 0a 20 20 20 20 20 20 20 28 63 6f 6e s)]). (con
04b0: 64 20 0a 09 5b 65 73 63 61 70 69 6e 67 0a 09 20 d ..[escaping..
04c0: 28 6c 65 74 2a 20 28 5b 73 70 65 63 69 61 6c 20 (let* ([special
04d0: 27 28 28 23 5c 2f 20 2e 20 23 5c 2f 29 20 28 23 '((#\/ . #\/) (#
04e0: 5c 62 20 2e 20 23 5c 62 61 63 6b 73 70 61 63 65 \b . #\backspace
04f0: 29 20 28 23 5c 6e 20 2e 20 23 5c 6e 65 77 6c 69 ) (#\n . #\newli
0500: 6e 65 29 20 0a 09 09 09 20 20 20 28 23 5c 72 20 ne) .... (#\r
0510: 2e 20 23 5c 72 65 74 75 72 6e 29 20 28 23 5c 74 . #\return) (#\t
0520: 20 2e 20 23 5c 74 61 62 29 20 28 23 5c 5c 20 2e . #\tab) (#\\ .
0530: 20 23 5c 5c 29 20 28 23 5c 22 20 2e 20 23 5c 22 #\\) (#\" . #\"
0540: 29 29 5d 0a 09 09 5b 71 20 28 61 73 73 71 20 63 ))]...[q (assq c
0550: 68 61 72 20 73 70 65 63 69 61 6c 29 5d 29 0a 09 har special)])..
0560: 20 20 20 28 63 6f 6e 64 20 0a 09 20 20 20 20 5b (cond .. [
0570: 71 20 28 70 61 72 73 65 2d 6a 73 6f 6e 2d 73 74 q (parse-json-st
0580: 72 20 28 2b 20 31 20 70 6f 73 29 20 64 61 74 61 r (+ 1 pos) data
0590: 20 23 66 20 28 63 6f 6e 73 20 28 63 64 72 20 71 #f (cons (cdr q
05a0: 29 20 6f 75 74 29 29 5d 0a 09 20 20 20 20 5b 28 ) out))].. [(
05b0: 63 68 61 72 3d 3f 20 63 68 61 72 20 23 5c 5c 29 char=? char #\\)
05c0: 20 28 70 61 72 73 65 2d 6a 73 6f 6e 2d 73 74 72 (parse-json-str
05d0: 20 28 2b 20 31 20 70 6f 73 29 20 64 61 74 61 20 (+ 1 pos) data
05e0: 23 66 20 28 63 6f 6e 73 20 23 5c 5c 20 6f 75 74 #f (cons #\\ out
05f0: 29 29 5d 0a 09 20 20 20 20 5b 28 63 68 61 72 3d ))].. [(char=
0600: 3f 20 63 68 61 72 20 23 5c 75 29 0a 09 20 20 20 ? char #\u)..
0610: 20 20 28 69 66 20 28 3c 20 28 2b 20 34 20 70 6f (if (< (+ 4 po
0620: 73 29 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 s) (string-lengt
0630: 68 20 64 61 74 61 29 29 0a 09 09 20 28 6c 65 74 h data))... (let
0640: 20 28 5b 6e 75 6d 20 28 73 74 72 69 6e 67 2d 3e ([num (string->
0650: 6e 75 6d 62 65 72 20 28 73 75 62 73 74 72 69 6e number (substrin
0660: 67 20 64 61 74 61 20 28 2b 20 70 6f 73 20 31 29 g data (+ pos 1)
0670: 20 28 2b 20 70 6f 73 20 35 29 29 20 31 36 29 5d (+ pos 5)) 16)]
0680: 29 0a 09 09 20 20 20 28 69 66 20 6e 75 6d 0a 09 )... (if num..
0690: 09 20 20 20 20 20 20 20 28 70 61 72 73 65 2d 6a . (parse-j
06a0: 73 6f 6e 2d 73 74 72 20 28 2b 20 35 20 70 6f 73 son-str (+ 5 pos
06b0: 29 20 64 61 74 61 20 23 66 20 28 63 6f 6e 73 20 ) data #f (cons
06c0: 28 69 6e 74 65 67 65 72 2d 3e 63 68 61 72 20 6e (integer->char n
06d0: 75 6d 29 20 6f 75 74 29 29 0a 09 09 20 20 20 20 um) out))...
06e0: 20 20 20 28 65 72 72 6f 72 20 27 70 61 72 73 65 (error 'parse
06f0: 2d 6a 73 6f 6e 2d 73 74 72 20 22 69 6e 76 61 6c -json-str "inval
0700: 69 64 20 75 6e 69 63 6f 64 65 20 73 65 71 75 65 id unicode seque
0710: 6e 63 65 20 61 74 22 20 70 6f 73 29 29 29 0a 09 nce at" pos)))..
0720: 09 20 28 65 72 72 6f 72 20 27 70 61 72 73 65 2d . (error 'parse-
0730: 6a 73 6f 6e 2d 73 74 72 20 22 75 6e 65 78 70 65 json-str "unexpe
0740: 63 74 65 64 20 65 6e 64 20 6f 66 20 73 74 72 69 cted end of stri
0750: 6e 67 20 69 6e 20 75 6e 69 63 6f 64 65 20 73 65 ng in unicode se
0760: 71 75 65 6e 63 65 22 29 29 5d 09 0a 09 20 20 20 quence"))]...
0770: 20 5b 65 6c 73 65 0a 09 20 20 20 20 20 28 65 72 [else.. (er
0780: 72 6f 72 20 27 70 61 72 73 65 2d 6a 73 6f 6e 2d ror 'parse-json-
0790: 73 74 72 20 22 70 61 72 73 65 20 65 72 72 6f 72 str "parse error
07a0: 22 20 65 73 63 61 70 69 6e 67 20 63 68 61 72 29 " escaping char)
07b0: 5d 29 29 5d 0a 09 5b 28 63 68 61 72 3d 3f 20 63 ]))]..[(char=? c
07c0: 68 61 72 20 23 5c 5c 29 0a 09 20 28 70 61 72 73 har #\\).. (pars
07d0: 65 2d 6a 73 6f 6e 2d 73 74 72 20 28 2b 20 31 20 e-json-str (+ 1
07e0: 70 6f 73 29 20 64 61 74 61 20 28 63 6f 6e 73 20 pos) data (cons
07f0: 23 5c 5c 20 28 2b 20 31 20 70 6f 73 29 29 20 6f #\\ (+ 1 pos)) o
0800: 75 74 29 5d 0a 09 0a 09 5b 28 63 68 61 72 2d 73 ut)]....[(char-s
0810: 65 74 2d 63 6f 6e 74 61 69 6e 73 3f 20 63 68 61 et-contains? cha
0820: 72 2d 73 65 74 3a 69 73 6f 2d 63 6f 6e 74 72 6f r-set:iso-contro
0830: 6c 20 63 68 61 72 29 0a 09 20 28 65 72 72 6f 72 l char).. (error
0840: 20 27 70 61 72 73 65 2d 6a 73 6f 6e 2d 73 74 72 'parse-json-str
0850: 20 22 70 61 72 73 65 20 65 72 72 6f 72 3a 20 73 "parse error: s
0860: 70 65 63 69 61 6c 20 63 68 61 72 61 63 74 65 72 pecial character
0870: 20 69 6e 20 73 74 72 69 6e 67 20 6c 69 74 65 72 in string liter
0880: 61 6c 22 20 63 68 61 72 20 29 5d 0a 09 5b 65 6c al" char )]..[el
0890: 73 65 0a 09 20 28 70 61 72 73 65 2d 6a 73 6f 6e se.. (parse-json
08a0: 2d 73 74 72 20 28 2b 20 31 20 70 6f 73 29 20 64 -str (+ 1 pos) d
08b0: 61 74 61 20 65 73 63 61 70 69 6e 67 20 28 63 6f ata escaping (co
08c0: 6e 73 20 63 68 61 72 20 6f 75 74 29 29 5d 29 29 ns char out))]))
08d0: 5d 29 29 0a 0a 20 28 64 65 66 69 6e 65 20 28 70 ])).. (define (p
08e0: 61 72 73 65 2d 6c 69 74 65 72 61 6c 20 70 6f 73 arse-literal pos
08f0: 20 64 61 74 61 20 6f 75 74 29 0a 20 20 20 28 63 data out). (c
0900: 6f 6e 64 0a 20 20 20 20 5b 28 6f 72 20 28 3e 3d ond. [(or (>=
0910: 20 70 6f 73 20 28 73 74 72 69 6e 67 2d 6c 65 6e pos (string-len
0920: 67 74 68 20 64 61 74 61 29 29 0a 09 20 28 6e 6f gth data)).. (no
0930: 74 20 28 63 68 61 72 2d 73 65 74 2d 63 6f 6e 74 t (char-set-cont
0940: 61 69 6e 73 3f 20 20 63 68 61 72 2d 73 65 74 3a ains? char-set:
0950: 6c 65 74 74 65 72 20 28 73 74 72 69 6e 67 2d 72 letter (string-r
0960: 65 66 20 64 61 74 61 20 70 6f 73 29 29 29 29 0a ef data pos)))).
0970: 20 20 20 20 20 28 76 61 6c 75 65 73 20 28 6c 69 (values (li
0980: 73 74 2d 3e 73 74 72 69 6e 67 20 28 72 65 76 65 st->string (reve
0990: 72 73 65 20 6f 75 74 29 29 20 70 6f 73 29 5d 0a rse out)) pos)].
09a0: 20 20 20 20 5b 65 6c 73 65 0a 20 20 20 20 20 28 [else. (
09b0: 70 61 72 73 65 2d 6c 69 74 65 72 61 6c 20 28 2b parse-literal (+
09c0: 20 31 20 70 6f 73 29 20 64 61 74 61 20 28 63 6f 1 pos) data (co
09d0: 6e 73 20 28 73 74 72 69 6e 67 2d 72 65 66 20 64 ns (string-ref d
09e0: 61 74 61 20 70 6f 73 29 20 6f 75 74 29 29 5d 29 ata pos) out))])
09f0: 29 0a 0a 20 3b 3b 20 54 4f 44 4f 20 57 52 49 54 ).. ;; TODO WRIT
0a00: 45 20 4d 4f 52 45 20 54 45 53 54 53 20 4c 49 4b E MORE TESTS LIK
0a10: 45 20 54 48 49 53 0a 20 3b 3b 20 57 52 49 54 45 E THIS. ;; WRITE
0a20: 20 41 20 4d 41 43 52 4f 20 54 48 41 54 20 53 49 A MACRO THAT SI
0a30: 4d 50 4c 49 46 49 45 53 20 54 45 53 54 49 4e 47 MPLIFIES TESTING
0a40: 0a 09 09 09 09 09 3b 28 65 76 61 6c 2d 77 68 65 ......;(eval-whe
0a50: 6e 20 28 63 6f 6d 70 69 6c 65 20 65 76 61 6c 29 n (compile eval)
0a60: 0a 09 09 09 09 09 3b 09 20 20 20 28 75 6e 6c 65 ......;. (unle
0a70: 73 73 20 28 65 71 75 61 6c 3f 20 28 70 61 72 73 ss (equal? (pars
0a80: 65 2d 6a 73 6f 6e 20 22 61 20 62 20 63 22 29 20 e-json "a b c")
0a90: 27 28 28 63 68 61 72 20 2e 20 23 5c 61 29 20 28 '((char . #\a) (
0aa0: 63 68 61 72 20 2e 20 23 5c 62 29 20 28 63 68 61 char . #\b) (cha
0ab0: 72 20 2e 20 23 5c 63 29 29 29 0a 09 09 09 09 09 r . #\c)))......
0ac0: 3b 09 09 20 20 20 28 65 72 72 6f 72 20 27 70 61 ;.. (error 'pa
0ad0: 72 73 65 2d 6a 73 6f 6e 2d 74 65 73 74 20 22 61 rse-json-test "a
0ae0: 20 62 20 63 20 61 73 73 65 72 74 69 6f 6e 20 66 b c assertion f
0af0: 61 69 6c 65 64 22 29 29 29 0a 0a 20 28 64 65 66 ailed"))).. (def
0b00: 69 6e 65 20 28 69 64 65 6e 74 69 74 79 20 65 78 ine (identity ex
0b10: 70 72 29 20 65 78 70 72 29 0a 0a 20 28 64 65 66 pr) expr).. (def
0b20: 69 6e 65 20 65 78 70 72 2d 67 72 61 6d 6d 61 72 ine expr-grammar
0b30: 0a 20 20 20 60 28 3b 28 65 78 70 72 20 2d 2d 3e . `(;(expr -->
0b40: 20 65 78 70 72 20 65 78 70 72 2d 6f 70 20 74 65 expr expr-op te
0b50: 72 6d 20 2c 62 69 6e 61 72 79 2d 61 70 70 6c 79 rm ,binary-apply
0b60: 29 20 20 20 20 3b 3b 3b 20 63 68 61 6e 67 65 20 ) ;;; change
0b70: 60 20 74 6f 20 27 0a 20 20 20 20 20 28 6d 61 69 ` to '. (mai
0b80: 6e 20 2d 2d 3e 20 6f 62 6a 65 63 74 20 2c 69 64 n --> object ,id
0b90: 65 6e 74 69 74 79 29 0a 20 20 20 20 20 28 6d 61 entity). (ma
0ba0: 69 6e 20 2d 2d 3e 20 61 72 72 61 79 20 2c 69 64 in --> array ,id
0bb0: 65 6e 74 69 74 79 29 0a 20 20 20 20 20 28 6d 61 entity). (ma
0bc0: 69 6e 20 2d 2d 3e 20 70 61 69 72 20 2c 69 64 65 in --> pair ,ide
0bd0: 6e 74 69 74 79 29 0a 20 20 20 20 20 28 6d 61 69 ntity). (mai
0be0: 6e 20 2d 2d 3e 20 76 61 6c 75 65 20 2c 69 64 65 n --> value ,ide
0bf0: 6e 74 69 74 79 29 0a 20 20 20 20 20 28 6f 62 6a ntity). (obj
0c00: 65 63 74 20 2d 2d 3e 20 6c 62 72 61 63 6b 65 74 ect --> lbracket
0c10: 20 72 62 72 61 63 6b 65 74 20 2c 28 6c 61 6d 62 rbracket ,(lamb
0c20: 64 61 20 28 6c 20 72 29 20 27 28 29 29 29 0a 20 da (l r) '())).
0c30: 20 20 20 20 28 6f 62 6a 65 63 74 20 2d 2d 3e 20 (object -->
0c40: 6c 62 72 61 63 6b 65 74 20 6d 65 6d 62 65 72 73 lbracket members
0c50: 20 72 62 72 61 63 6b 65 74 20 2c 28 6c 61 6d 62 rbracket ,(lamb
0c60: 64 61 20 28 6c 20 6d 20 72 29 20 6d 29 29 0a 20 da (l m r) m)).
0c70: 20 20 20 20 28 6d 65 6d 62 65 72 73 20 2d 2d 3e (members -->
0c80: 20 70 61 69 72 20 2c 28 6c 61 6d 62 64 61 20 28 pair ,(lambda (
0c90: 70 29 20 28 6c 69 73 74 20 70 29 29 29 0a 20 20 p) (list p))).
0ca0: 20 20 20 28 6d 65 6d 62 65 72 73 20 2d 2d 3e 20 (members -->
0cb0: 70 61 69 72 20 63 6f 6d 6d 61 20 6d 65 6d 62 65 pair comma membe
0cc0: 72 73 20 2c 28 6c 61 6d 62 64 61 20 28 70 20 63 rs ,(lambda (p c
0cd0: 20 6d 29 20 28 61 70 70 65 6e 64 20 28 6c 69 73 m) (append (lis
0ce0: 74 20 70 29 20 6d 29 29 29 0a 20 20 20 20 20 28 t p) m))). (
0cf0: 70 61 69 72 20 2d 2d 3e 20 73 74 72 69 6e 67 20 pair --> string
0d00: 63 6f 6c 6f 6e 20 76 61 6c 75 65 20 2c 28 6c 61 colon value ,(la
0d10: 6d 62 64 61 20 28 73 20 63 20 76 29 20 60 28 2c mbda (s c v) `(,
0d20: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
0d30: 73 29 20 20 2e 20 2c 76 29 29 29 0a 20 20 20 20 s) . ,v))).
0d40: 20 28 61 72 72 61 79 20 2d 2d 3e 20 6c 73 71 75 (array --> lsqu
0d50: 61 72 65 20 72 73 71 75 61 72 65 20 2c 28 6c 61 are rsquare ,(la
0d60: 6d 62 64 61 20 28 6c 20 72 29 20 27 23 28 29 29 mbda (l r) '#())
0d70: 29 0a 20 20 20 20 20 28 61 72 72 61 79 20 2d 2d ). (array --
0d80: 3e 20 6c 73 71 75 61 72 65 20 65 6c 65 6d 65 6e > lsquare elemen
0d90: 74 73 20 72 73 71 75 61 72 65 20 2c 28 6c 61 6d ts rsquare ,(lam
0da0: 62 64 61 20 28 6c 20 65 20 72 29 20 60 23 28 2c bda (l e r) `#(,
0db0: 40 65 29 29 29 0a 20 20 20 20 20 28 65 6c 65 6d @e))). (elem
0dc0: 65 6e 74 73 20 2d 2d 3e 20 76 61 6c 75 65 20 2c ents --> value ,
0dd0: 28 6c 61 6d 62 64 61 20 28 76 29 20 28 6c 69 73 (lambda (v) (lis
0de0: 74 20 76 29 29 29 0a 20 20 20 20 20 28 65 6c 65 t v))). (ele
0df0: 6d 65 6e 74 73 20 2d 2d 3e 20 76 61 6c 75 65 20 ments --> value
0e00: 63 6f 6d 6d 61 20 65 6c 65 6d 65 6e 74 73 20 2c comma elements ,
0e10: 28 6c 61 6d 62 64 61 20 28 76 20 63 20 65 29 20 (lambda (v c e)
0e20: 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 76 29 (append (list v)
0e30: 20 65 29 29 29 0a 20 20 20 20 20 28 76 61 6c 75 e))). (valu
0e40: 65 20 2d 2d 3e 20 73 74 72 69 6e 67 20 2c 69 64 e --> string ,id
0e50: 65 6e 74 69 74 79 29 0a 20 20 20 20 20 28 76 61 entity). (va
0e60: 6c 75 65 20 2d 2d 3e 20 6e 75 6d 62 65 72 20 2c lue --> number ,
0e70: 28 6c 61 6d 62 64 61 20 28 6e 29 20 28 73 74 72 (lambda (n) (str
0e80: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6e 29 29 29 ing->number n)))
0e90: 0a 20 20 20 20 20 28 76 61 6c 75 65 20 2d 2d 3e . (value -->
0ea0: 20 6f 62 6a 65 63 74 20 2c 69 64 65 6e 74 69 74 object ,identit
0eb0: 79 29 0a 20 20 20 20 20 28 76 61 6c 75 65 20 2d y). (value -
0ec0: 2d 3e 20 61 72 72 61 79 20 2c 69 64 65 6e 74 69 -> array ,identi
0ed0: 74 79 29 0a 20 20 20 20 20 28 76 61 6c 75 65 20 ty). (value
0ee0: 2d 2d 3e 20 74 72 75 65 20 2c 28 6c 61 6d 62 64 --> true ,(lambd
0ef0: 61 20 28 78 29 20 23 74 29 29 0a 20 20 20 20 20 a (x) #t)).
0f00: 28 76 61 6c 75 65 20 2d 2d 3e 20 66 61 6c 73 65 (value --> false
0f10: 20 2c 28 6c 61 6d 62 64 61 20 28 78 29 20 23 66 ,(lambda (x) #f
0f20: 29 29 0a 20 20 20 20 20 28 76 61 6c 75 65 20 2d )). (value -
0f30: 2d 3e 20 6e 75 6c 6c 20 2c 28 6c 61 6d 62 64 61 -> null ,(lambda
0f40: 20 28 78 29 20 27 28 29 29 29 0a 0a 20 20 20 20 (x) '()))..
0f50: 20 28 69 6e 74 20 2d 2d 3e 20 64 69 67 69 74 73 (int --> digits
0f60: 20 2c 69 64 65 6e 74 69 74 79 29 0a 20 20 20 20 ,identity).
0f70: 20 28 69 6e 74 20 2d 2d 3e 20 6d 69 6e 75 73 20 (int --> minus
0f80: 64 69 67 69 74 73 20 2c 28 6c 61 6d 62 64 61 20 digits ,(lambda
0f90: 28 6d 20 64 29 20 28 73 74 72 69 6e 67 2d 61 70 (m d) (string-ap
0fa0: 70 65 6e 64 20 22 2d 22 20 64 20 29 29 29 0a 20 pend "-" d ))).
0fb0: 20 20 20 20 28 66 72 61 63 20 2d 2d 3e 20 64 6f (frac --> do
0fc0: 74 20 64 69 67 69 74 73 20 2c 28 6c 61 6d 62 64 t digits ,(lambd
0fd0: 61 20 28 70 20 64 29 20 20 28 73 74 72 69 6e 67 a (p d) (string
0fe0: 2d 61 70 70 65 6e 64 20 22 2e 22 20 64 29 29 29 -append "." d)))
0ff0: 0a 20 20 20 20 20 28 65 78 70 20 2d 2d 3e 20 65 . (exp --> e
1000: 78 20 64 69 67 69 74 73 20 2c 28 6c 61 6d 62 64 x digits ,(lambd
1010: 61 20 28 65 20 64 29 20 28 73 74 72 69 6e 67 2d a (e d) (string-
1020: 61 70 70 65 6e 64 20 28 69 66 20 28 65 71 3f 20 append (if (eq?
1030: 65 20 27 6d 69 6e 75 73 2d 65 29 20 22 65 2d 22 e 'minus-e) "e-"
1040: 20 22 65 22 29 20 64 29 29 29 0a 20 20 20 20 20 "e") d))).
1050: 28 65 78 20 2d 2d 3e 20 65 20 2c 69 64 65 6e 74 (ex --> e ,ident
1060: 69 74 79 29 0a 20 20 20 20 20 28 65 78 20 2d 2d ity). (ex --
1070: 3e 20 65 20 70 6c 75 73 20 2c 28 6c 61 6d 62 64 > e plus ,(lambd
1080: 61 20 28 65 20 70 29 20 27 70 6c 75 73 2d 65 29 a (e p) 'plus-e)
1090: 29 0a 20 20 20 20 20 28 65 78 20 2d 2d 3e 20 65 ). (ex --> e
10a0: 20 6d 69 6e 75 73 20 2c 28 6c 61 6d 62 64 61 20 minus ,(lambda
10b0: 28 65 20 70 29 20 27 6d 69 6e 75 73 2d 65 29 29 (e p) 'minus-e))
10c0: 0a 20 20 20 20 20 0a 20 20 20 20 20 28 6e 75 6d . . (num
10d0: 62 65 72 20 2d 2d 3e 20 69 6e 74 20 2c 69 64 65 ber --> int ,ide
10e0: 6e 74 69 74 79 29 0a 20 20 20 20 20 28 6e 75 6d ntity). (num
10f0: 62 65 72 20 2d 2d 3e 20 69 6e 74 20 66 72 61 63 ber --> int frac
1100: 20 2c 28 6c 61 6d 62 64 61 20 28 69 20 66 29 20 ,(lambda (i f)
1110: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 69 (string-append i
1120: 20 66 29 29 29 0a 20 20 20 20 20 28 6e 75 6d 62 f))). (numb
1130: 65 72 20 2d 2d 3e 20 69 6e 74 20 65 78 70 20 2c er --> int exp ,
1140: 28 6c 61 6d 62 64 61 20 28 69 20 65 29 20 28 73 (lambda (i e) (s
1150: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 69 20 65 tring-append i e
1160: 29 29 29 0a 20 20 20 20 20 28 6e 75 6d 62 65 72 ))). (number
1170: 20 2d 2d 3e 20 69 6e 74 20 66 72 61 63 20 65 78 --> int frac ex
1180: 70 20 2c 28 6c 61 6d 62 64 61 20 28 69 20 66 20 p ,(lambda (i f
1190: 65 29 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e e) (string-appen
11a0: 64 20 69 20 66 20 65 29 29 29 0a 20 20 20 20 20 d i f e))).
11b0: 28 64 69 67 69 74 20 2d 3e 20 64 69 67 69 74 2d (digit -> digit-
11c0: 31 2d 39 20 2c 28 6c 61 6d 62 64 61 20 28 6e 29 1-9 ,(lambda (n)
11d0: 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 (number->string
11e0: 20 6e 29 29 29 0a 20 20 20 20 20 28 64 69 67 69 n))). (digi
11f0: 74 20 2d 3e 20 7a 65 72 6f 20 2c 28 6c 61 6d 62 t -> zero ,(lamb
1200: 64 61 20 28 6e 29 20 22 30 22 29 29 0a 20 20 20 da (n) "0")).
1210: 20 20 3b 3b 20 49 20 43 4f 55 4c 44 4e 27 54 20 ;; I COULDN'T
1220: 46 4f 52 43 45 20 54 48 45 20 64 69 67 69 74 2d FORCE THE digit-
1230: 31 2d 39 20 73 74 61 72 74 20 73 74 75 66 66 2e 1-9 start stuff.
1240: 20 69 73 20 69 74 20 72 65 61 6c 6c 79 20 6e 65 is it really ne
1250: 65 64 65 64 3f 3f 0a 20 20 20 20 20 28 64 69 67 eded??. (dig
1260: 69 74 73 20 2d 2d 3e 20 64 69 67 69 74 20 64 69 its --> digit di
1270: 67 69 74 73 20 20 2c 28 6c 61 6d 62 64 61 20 28 gits ,(lambda (
1280: 64 20 6e 29 20 28 73 74 72 69 6e 67 2d 61 70 70 d n) (string-app
1290: 65 6e 64 20 64 20 6e 29 29 29 0a 09 09 09 09 09 end d n)))......
12a0: 3b 20 28 64 69 67 69 74 73 20 2d 2d 3e 20 64 69 ; (digits --> di
12b0: 67 69 74 2d 31 2d 39 20 2c 28 6c 61 6d 62 64 61 git-1-9 ,(lambda
12c0: 20 28 6e 29 20 28 6e 75 6d 62 65 72 2d 3e 73 74 (n) (number->st
12d0: 72 69 6e 67 20 6e 29 29 29 0a 09 09 09 09 09 3b ring n)))......;
12e0: 20 28 64 69 67 69 74 73 20 2d 2d 3e 20 64 20 2c (digits --> d ,
12f0: 28 6c 61 6d 62 64 61 20 28 6e 29 20 28 6e 75 6d (lambda (n) (num
1300: 62 65 72 2d 3e 73 74 72 69 6e 67 20 6e 29 29 29 ber->string n)))
1310: 0a 20 20 20 20 20 28 64 69 67 69 74 73 20 2d 2d . (digits --
1320: 3e 20 64 69 67 69 74 20 2c 69 64 65 6e 74 69 74 > digit ,identit
1330: 79 29 0a 20 20 20 20 20 29 29 0a 0a 20 28 64 65 y). )).. (de
1340: 66 69 6e 65 20 65 78 70 72 2d 74 65 72 6d 69 6e fine expr-termin
1350: 61 6c 73 20 27 28 73 74 72 69 6e 67 20 6c 69 74 als '(string lit
1360: 65 72 61 6c 20 64 69 67 69 74 2d 31 2d 39 20 7a eral digit-1-9 z
1370: 65 72 6f 20 63 68 61 72 20 6c 62 72 61 63 6b 65 ero char lbracke
1380: 74 20 72 62 72 61 63 6b 65 74 20 6c 73 71 75 61 t rbracket lsqua
1390: 72 65 20 72 73 71 75 61 72 65 20 65 20 64 6f 74 re rsquare e dot
13a0: 20 6d 69 6e 75 73 20 70 6c 75 73 20 63 6f 6c 6f minus plus colo
13b0: 6e 20 63 6f 6d 6d 61 20 74 72 75 65 20 66 61 6c n comma true fal
13c0: 73 65 20 6e 75 6c 6c 20 29 20 29 0a 0a 20 28 64 se null ) ).. (d
13d0: 65 66 69 6e 65 20 74 61 62 6c 65 20 28 6c 61 6c efine table (lal
13e0: 72 2d 74 61 62 6c 65 20 65 78 70 72 2d 67 72 61 r-table expr-gra
13f0: 6d 6d 61 72 20 65 78 70 72 2d 74 65 72 6d 69 6e mmar expr-termin
1400: 61 6c 73 20 23 66 29 29 20 0a 0a 20 28 64 65 66 als #f)) .. (def
1410: 69 6e 65 20 28 73 74 72 69 6e 67 2d 3e 6a 73 6f ine (string->jso
1420: 6e 20 64 61 74 61 29 0a 20 20 20 28 69 6d 70 6f n data). (impo
1430: 72 74 20 28 73 72 66 69 20 73 31 34 20 63 68 61 rt (srfi s14 cha
1440: 72 2d 73 65 74 73 29 29 0a 20 20 20 28 6c 65 74 r-sets)). (let
1450: 20 28 28 70 6f 73 20 30 29 29 0a 20 20 20 20 20 ((pos 0)).
1460: 28 64 65 66 69 6e 65 20 6c 65 78 69 63 61 6c 2d (define lexical-
1470: 61 6e 61 6c 79 73 65 72 20 0a 20 20 20 20 20 20 analyser .
1480: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 69 (lambda ().. (i
1490: 66 20 28 3e 3d 20 70 6f 73 20 28 73 74 72 69 6e f (>= pos (strin
14a0: 67 2d 6c 65 6e 67 74 68 20 64 61 74 61 29 29 20 g-length data))
14b0: 23 66 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a #f.. (begin.
14c0: 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 5b 63 . (let ([c
14d0: 68 61 72 20 28 73 74 72 69 6e 67 2d 72 65 66 20 har (string-ref
14e0: 64 61 74 61 20 70 6f 73 29 5d 29 0a 09 09 20 28 data pos)])... (
14f0: 63 6f 6e 64 0a 09 09 20 20 5b 28 63 68 61 72 3d cond... [(char=
1500: 3f 20 63 68 61 72 20 23 5c 22 29 0a 09 09 20 20 ? char #\")...
1510: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 5b 28 (let-values ([(
1520: 73 74 72 20 70 6f 73 2a 29 20 28 70 61 72 73 65 str pos*) (parse
1530: 2d 6a 73 6f 6e 2d 73 74 72 20 28 2b 20 31 20 70 -json-str (+ 1 p
1540: 6f 73 29 20 64 61 74 61 20 23 66 20 27 28 29 29 os) data #f '())
1550: 5d 29 0a 09 09 20 20 20 20 20 3b 3b 28 70 61 72 ])... ;;(par
1560: 73 65 20 28 2b 20 31 20 70 6f 73 2a 29 20 64 61 se (+ 1 pos*) da
1570: 74 61 20 28 63 6f 6e 73 20 28 63 6f 6e 73 20 27 ta (cons (cons '
1580: 73 74 72 20 73 74 72 29 20 6f 75 74 29 29 29 5d str str) out)))]
1590: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 70 6f ... (set! po
15a0: 73 20 28 2b 20 31 20 70 6f 73 2a 29 29 0a 09 09 s (+ 1 pos*))...
15b0: 20 20 20 20 20 60 28 73 74 72 69 6e 67 20 2e 20 `(string .
15c0: 2c 73 74 72 29 29 5d 0a 09 09 20 20 5b 28 63 68 ,str))]... [(ch
15d0: 61 72 2d 73 65 74 2d 63 6f 6e 74 61 69 6e 73 3f ar-set-contains?
15e0: 20 63 68 61 72 2d 73 65 74 3a 77 68 69 74 65 73 char-set:whites
15f0: 70 61 63 65 20 63 68 61 72 29 0a 09 09 20 20 20 pace char)...
1600: 28 73 65 74 21 20 70 6f 73 20 28 2b 20 31 20 70 (set! pos (+ 1 p
1610: 6f 73 29 29 0a 09 09 20 20 20 28 6c 65 78 69 63 os))... (lexic
1620: 61 6c 2d 61 6e 61 6c 79 73 65 72 29 5d 0a 09 09 al-analyser)]...
1630: 20 20 5b 28 63 68 61 72 2d 73 65 74 2d 63 6f 6e [(char-set-con
1640: 74 61 69 6e 73 3f 20 63 68 61 72 2d 73 65 74 3a tains? char-set:
1650: 6c 65 74 74 65 72 20 63 68 61 72 29 20 3b 3b 20 letter char) ;;
1660: 6c 69 74 65 72 61 6c 73 20 0a 09 09 20 20 20 28 literals ... (
1670: 6c 65 74 2d 76 61 6c 75 65 73 20 28 5b 28 73 74 let-values ([(st
1680: 72 20 70 6f 73 2a 29 20 28 70 61 72 73 65 2d 6c r pos*) (parse-l
1690: 69 74 65 72 61 6c 20 70 6f 73 20 64 61 74 61 20 iteral pos data
16a0: 27 28 29 29 5d 29 0a 09 09 20 20 20 20 20 28 73 '())])... (s
16b0: 65 74 21 20 70 6f 73 20 70 6f 73 2a 29 0a 09 09 et! pos pos*)...
16c0: 20 20 20 20 20 28 6c 65 74 20 28 5b 73 79 6d 20 (let ([sym
16d0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
16e0: 73 74 72 29 5d 29 0a 09 09 20 20 20 20 20 20 20 str)])...
16f0: 28 63 61 73 65 20 73 79 6d 0a 09 09 09 20 5b 28 (case sym.... [(
1700: 74 72 75 65 29 20 60 28 74 72 75 65 20 2e 20 23 true) `(true . #
1710: 74 29 5d 0a 09 09 09 20 5b 28 66 61 6c 73 65 29 t)].... [(false)
1720: 20 60 28 66 61 6c 73 65 20 2e 20 23 66 29 5d 0a `(false . #f)].
1730: 09 09 09 20 5b 28 6e 75 6c 6c 29 20 60 28 6e 75 ... [(null) `(nu
1740: 6c 6c 20 2e 20 27 28 29 29 5d 0a 09 09 09 20 5b ll . '())].... [
1750: 28 65 20 45 29 20 60 28 65 20 2e 20 23 66 29 5d (e E) `(e . #f)]
1760: 0a 09 09 09 20 5b 65 6c 73 65 0a 09 09 09 20 20 .... [else....
1770: 60 28 6c 69 74 65 72 61 6c 20 2c 28 73 74 72 69 `(literal ,(stri
1780: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 72 29 29 ng->symbol str))
1790: 5d 29 29 29 5d 0a 09 09 20 20 5b 28 63 68 61 72 ])))]... [(char
17a0: 2d 73 65 74 2d 63 6f 6e 74 61 69 6e 73 3f 20 28 -set-contains? (
17b0: 73 74 72 69 6e 67 2d 3e 63 68 61 72 2d 73 65 74 string->char-set
17c0: 20 22 31 32 33 34 35 36 37 38 39 22 29 20 63 68 "123456789") ch
17d0: 61 72 29 0a 09 09 20 20 20 28 73 65 74 21 20 70 ar)... (set! p
17e0: 6f 73 20 28 2b 20 31 20 70 6f 73 29 29 0a 09 09 os (+ 1 pos))...
17f0: 20 20 20 60 28 64 69 67 69 74 2d 31 2d 39 20 2e `(digit-1-9 .
1800: 20 2c 28 2d 20 28 63 68 61 72 2d 3e 69 6e 74 65 ,(- (char->inte
1810: 67 65 72 20 63 68 61 72 29 20 28 63 68 61 72 2d ger char) (char-
1820: 3e 69 6e 74 65 67 65 72 20 23 5c 30 29 29 29 5d >integer #\0)))]
1830: 0a 09 09 20 20 5b 28 63 68 61 72 3d 3f 20 23 5c ... [(char=? #\
1840: 30 20 63 68 61 72 29 0a 09 09 20 20 20 28 73 65 0 char)... (se
1850: 74 21 20 70 6f 73 20 28 2b 20 31 20 70 6f 73 29 t! pos (+ 1 pos)
1860: 29 0a 09 09 20 20 20 60 28 7a 65 72 6f 20 2e 20 )... `(zero .
1870: 30 29 5d 0a 09 09 20 20 5b 65 6c 73 65 20 0a 09 0)]... [else ..
1880: 09 20 20 20 28 73 65 74 21 20 70 6f 73 20 28 2b . (set! pos (+
1890: 20 31 20 70 6f 73 29 29 0a 09 09 20 20 20 28 63 1 pos))... (c
18a0: 61 73 65 20 63 68 61 72 0a 09 09 20 20 20 20 20 ase char...
18b0: 28 28 23 5c 7b 29 20 27 28 6c 62 72 61 63 6b 65 ((#\{) '(lbracke
18c0: 74 20 2e 20 23 66 29 29 0a 09 09 20 20 20 20 20 t . #f))...
18d0: 28 28 23 5c 7d 29 20 27 28 72 62 72 61 63 6b 65 ((#\}) '(rbracke
18e0: 74 20 2e 20 23 66 29 29 0a 09 09 20 20 20 20 20 t . #f))...
18f0: 28 28 23 5c 5b 29 20 27 28 6c 73 71 75 61 72 65 ((#\[) '(lsquare
1900: 20 2e 20 23 66 29 29 0a 09 09 20 20 20 20 20 28 . #f))... (
1910: 28 23 5c 5d 29 20 27 28 72 73 71 75 61 72 65 20 (#\]) '(rsquare
1920: 2e 20 23 66 29 29 0a 09 09 09 09 09 3b 20 28 28 . #f))......; ((
1930: 23 5c 65 20 23 5c 45 29 20 27 28 65 20 2e 20 23 #\e #\E) '(e . #
1940: 66 29 29 0a 09 09 20 20 20 20 20 28 28 23 5c 2e f))... ((#\.
1950: 29 20 27 28 64 6f 74 20 2e 20 23 66 29 29 0a 09 ) '(dot . #f))..
1960: 09 20 20 20 20 20 28 28 23 5c 2d 29 20 27 28 6d . ((#\-) '(m
1970: 69 6e 75 73 20 2e 20 23 66 29 29 0a 09 09 20 20 inus . #f))...
1980: 20 20 20 28 28 23 5c 2b 29 20 27 28 70 6c 75 73 ((#\+) '(plus
1990: 20 2e 20 23 66 29 29 0a 09 09 20 20 20 20 20 28 . #f))... (
19a0: 28 23 5c 3a 29 20 27 28 63 6f 6c 6f 6e 20 2e 20 (#\:) '(colon .
19b0: 23 66 29 29 0a 09 09 20 20 20 20 20 28 28 23 5c #f))... ((#\
19c0: 2c 29 20 27 28 63 6f 6d 6d 61 20 2e 20 23 66 29 ,) '(comma . #f)
19d0: 29 0a 09 09 20 20 20 20 20 5b 65 6c 73 65 0a 09 )... [else..
19e0: 09 20 20 20 20 20 20 60 28 63 68 61 72 20 2e 20 . `(char .
19f0: 2c 63 68 61 72 29 5d 29 5d 29 29 29 29 29 29 0a ,char)])])))))).
1a00: 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 70 61 (define (pa
1a10: 72 73 65 2d 65 72 72 6f 72 29 0a 20 20 20 20 20 rse-error).
1a20: 20 20 28 64 69 73 70 6c 61 79 20 22 45 72 72 6f (display "Erro
1a30: 72 20 73 6f 6d 65 77 68 65 72 65 20 69 6e 20 22 r somewhere in "
1a40: 29 0a 20 20 20 20 20 20 20 28 77 72 69 74 65 20 ). (write
1a50: 28 73 75 62 73 74 72 69 6e 67 20 64 61 74 61 20 (substring data
1a60: 28 6d 61 78 20 30 20 28 2d 20 70 6f 73 20 2d 31 (max 0 (- pos -1
1a70: 30 30 29 29 20 70 6f 73 29 29 0a 20 20 20 20 20 00)) pos)).
1a80: 20 20 28 6e 65 77 6c 69 6e 65 29 29 0a 20 20 20 (newline)).
1a90: 20 20 28 6c 61 6c 72 2d 70 61 72 73 65 72 20 74 (lalr-parser t
1aa0: 61 62 6c 65 20 6c 65 78 69 63 61 6c 2d 61 6e 61 able lexical-ana
1ab0: 6c 79 73 65 72 20 70 61 72 73 65 2d 65 72 72 6f lyser parse-erro
1ac0: 72 29 29 29 0a 0a 20 28 64 65 66 69 6e 65 20 28 r))).. (define (
1ad0: 72 65 61 64 2d 66 69 6c 65 20 66 69 6c 65 6e 61 read-file filena
1ae0: 6d 65 29 0a 20 20 20 28 77 69 74 68 2d 69 6e 70 me). (with-inp
1af0: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 69 6c ut-from-file fil
1b00: 65 6e 61 6d 65 0a 20 20 20 20 20 28 6c 61 6d 62 ename. (lamb
1b10: 64 61 20 28 29 20 0a 20 20 20 20 20 20 20 28 6c da () . (l
1b20: 65 74 20 6c 6f 6f 70 20 28 5b 78 20 28 72 65 61 et loop ([x (rea
1b30: 64 2d 63 68 61 72 29 5d 20 5b 61 63 63 20 27 28 d-char)] [acc '(
1b40: 29 5d 29 20 20 0a 09 20 28 69 66 20 28 65 6f 66 )]) .. (if (eof
1b50: 2d 6f 62 6a 65 63 74 3f 20 78 29 20 28 61 70 70 -object? x) (app
1b60: 6c 79 20 73 74 72 69 6e 67 20 28 72 65 76 65 72 ly string (rever
1b70: 73 65 20 61 63 63 29 29 0a 09 20 20 20 20 20 28 se acc)).. (
1b80: 6c 6f 6f 70 20 28 72 65 61 64 2d 63 68 61 72 29 loop (read-char)
1b90: 20 28 63 6f 6e 73 20 78 20 61 63 63 29 29 29 29 (cons x acc))))
1ba0: 29 29 29 0a 0a 20 28 64 65 66 69 6e 65 2d 73 79 ))).. (define-sy
1bb0: 6e 74 61 78 20 6c 65 74 2d 6a 73 6f 6e 2d 6f 62 ntax let-json-ob
1bc0: 6a 65 63 74 0a 20 20 20 28 6c 61 6d 62 64 61 20 ject. (lambda
1bd0: 28 78 29 0a 20 20 20 20 20 28 73 79 6e 74 61 78 (x). (syntax
1be0: 2d 63 61 73 65 20 78 20 28 29 0a 20 20 20 20 20 -case x ().
1bf0: 20 20 5b 28 5f 20 6f 62 6a 65 63 74 20 28 74 61 [(_ object (ta
1c00: 67 20 2e 2e 2e 29 20 62 6f 64 79 20 2e 2e 2e 29 g ...) body ...)
1c10: 0a 09 23 60 28 6c 65 74 20 23 2c 28 6d 61 70 20 ..#`(let #,(map
1c20: 28 6c 61 6d 62 64 61 20 28 74 29 20 23 60 28 23 (lambda (t) #`(#
1c30: 2c 74 20 0a 09 09 09 09 20 20 20 20 20 28 6c 65 ,t ..... (le
1c40: 74 20 28 5b 76 20 28 61 73 73 71 20 28 71 75 6f t ([v (assq (quo
1c50: 74 65 20 23 2c 74 29 20 6f 62 6a 65 63 74 29 5d te #,t) object)]
1c60: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 69 66 )..... (if
1c70: 20 76 20 28 63 64 72 20 76 29 20 76 29 29 29 29 v (cdr v) v))))
1c80: 23 27 28 74 61 67 20 2e 2e 2e 29 29 0a 09 20 20 #'(tag ...))..
1c90: 20 20 62 6f 64 79 20 2e 2e 2e 29 5d 29 29 29 0a body ...)]))).
1ca0: 0a 0a 20 28 64 65 66 69 6e 65 20 28 6a 73 6f 6e .. (define (json
1cb0: 2d 3e 73 74 72 69 6e 67 20 6a 73 6f 6e 29 0a 20 ->string json).
1cc0: 20 20 28 64 65 66 69 6e 65 20 73 70 65 63 69 61 (define specia
1cd0: 6c 20 27 28 28 23 5c 62 61 63 6b 73 70 61 63 65 l '((#\backspace
1ce0: 20 2e 20 23 5c 62 29 20 28 23 5c 6e 65 77 6c 69 . #\b) (#\newli
1cf0: 6e 65 20 2e 20 23 5c 6e 29 20 28 23 5c 61 6c 61 ne . #\n) (#\ala
1d00: 72 6d 20 2e 20 23 5c 61 29 20 0a 09 09 20 20 20 rm . #\a) ...
1d10: 20 20 28 23 5c 72 65 74 75 72 6e 20 2e 20 23 5c (#\return . #\
1d20: 72 29 20 28 23 5c 74 61 62 20 23 5c 74 29 20 28 r) (#\tab #\t) (
1d30: 23 5c 5c 20 2e 20 23 5c 5c 29 20 28 23 5c 22 20 #\\ . #\\) (#\"
1d40: 2e 20 23 5c 22 29 29 29 0a 20 20 20 28 63 6f 6e . #\"))). (con
1d50: 64 20 5b 28 61 6e 64 20 28 70 61 69 72 3f 20 6a d [(and (pair? j
1d60: 73 6f 6e 29 20 28 65 71 3f 20 28 63 61 72 20 6a son) (eq? (car j
1d70: 73 6f 6e 29 20 27 40 29 29 0a 09 20 20 28 73 74 son) '@)).. (st
1d80: 72 69 6e 67 2d 61 70 70 65 6e 64 20 0a 09 20 20 ring-append ..
1d90: 20 22 7b 5c 6e 22 0a 09 20 20 20 28 73 74 72 69 "{\n".. (stri
1da0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 ng-intersperse..
1db0: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
1dc0: 20 28 70 61 69 72 29 0a 09 09 20 20 20 28 6c 65 (pair)... (le
1dd0: 74 20 28 5b 6b 20 28 63 61 72 20 70 61 69 72 29 t ([k (car pair)
1de0: 5d 0a 09 09 09 20 5b 76 20 28 63 64 72 20 70 61 ].... [v (cdr pa
1df0: 69 72 29 5d 29 0a 09 09 20 20 20 20 20 28 73 74 ir)])... (st
1e00: 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 20 20 22 ring-append " "
1e10: 20 28 6a 73 6f 6e 2d 3e 73 74 72 69 6e 67 20 6b (json->string k
1e20: 29 0a 09 09 09 09 20 20 20 20 22 20 3a 20 22 20 )..... " : "
1e30: 28 6a 73 6f 6e 2d 3e 73 74 72 69 6e 67 20 76 29 (json->string v)
1e40: 29 29 29 0a 09 09 20 28 63 64 72 20 6a 73 6f 6e )))... (cdr json
1e50: 29 29 0a 09 20 20 20 20 22 2c 5c 6e 22 29 0a 09 )).. ",\n")..
1e60: 20 20 20 22 5c 6e 7d 5c 6e 22 29 5d 0a 09 20 5b "\n}\n")].. [
1e70: 28 6c 69 73 74 3f 20 6a 73 6f 6e 29 0a 09 20 20 (list? json)..
1e80: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 20 (string-append
1e90: 22 5b 22 0a 09 09 09 20 20 28 73 74 72 69 6e 67 "[".... (string
1ea0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
1eb0: 70 20 6a 73 6f 6e 2d 3e 73 74 72 69 6e 67 20 6a p json->string j
1ec0: 73 6f 6e 29 20 22 2c 22 29 0a 09 09 09 20 20 22 son) ",").... "
1ed0: 5d 5c 6e 22 29 5d 0a 09 20 5b 28 6e 75 6d 62 65 ]\n")].. [(numbe
1ee0: 72 3f 20 6a 73 6f 6e 29 0a 09 20 20 28 6e 75 6d r? json).. (num
1ef0: 62 65 72 2d 3e 73 74 72 69 6e 67 20 6a 73 6f 6e ber->string json
1f00: 29 5d 0a 09 20 5b 28 73 74 72 69 6e 67 3f 20 6a )].. [(string? j
1f10: 73 6f 6e 29 0a 09 20 20 28 73 74 72 69 6e 67 2d son).. (string-
1f20: 61 70 70 65 6e 64 20 22 5c 22 22 0a 09 09 09 20 append "\""....
1f30: 28 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 28 66 (list->string (f
1f40: 6f 6c 64 2d 72 69 67 68 74 0a 09 09 09 09 09 28 old-right......(
1f50: 6c 61 6d 62 64 61 20 28 78 20 61 63 63 29 0a 09 lambda (x acc)..
1f60: 09 09 09 09 20 20 28 6c 65 74 20 28 5b 71 20 28 .... (let ([q (
1f70: 61 73 73 71 20 78 20 73 70 65 63 69 61 6c 29 5d assq x special)]
1f80: 29 0a 09 09 09 09 09 20 20 20 20 28 69 66 20 71 )...... (if q
1f90: 20 28 63 6f 6e 73 20 23 5c 5c 20 28 63 6f 6e 73 (cons #\\ (cons
1fa0: 20 28 63 64 72 20 71 29 20 61 63 63 29 29 0a 09 (cdr q) acc))..
1fb0: 09 09 09 09 09 28 63 6f 6e 73 20 78 20 61 63 63 .....(cons x acc
1fc0: 29 29 29 29 0a 09 09 09 09 09 27 28 29 0a 09 09 ))))......'()...
1fd0: 09 09 09 28 73 74 72 69 6e 67 2d 3e 6c 69 73 74 ...(string->list
1fe0: 20 6a 73 6f 6e 29 29 29 0a 09 09 09 20 22 5c 22 json))).... "\"
1ff0: 22 20 29 5d 0a 09 20 5b 28 62 79 74 65 76 65 63 " )].. [(bytevec
2000: 74 6f 72 3f 20 6a 73 6f 6e 29 0a 09 20 20 28 75 tor? json).. (u
2010: 74 66 38 2d 3e 73 74 72 69 6e 67 20 6a 73 6f 6e tf8->string json
2020: 29 5d 09 09 0a 20 20 20 0a 09 20 5b 28 73 79 6d )]... .. [(sym
2030: 62 6f 6c 3f 20 6a 73 6f 6e 29 0a 09 20 20 28 6a bol? json).. (j
2040: 73 6f 6e 2d 3e 73 74 72 69 6e 67 20 28 73 79 6d son->string (sym
2050: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6a 73 6f 6e bol->string json
2060: 29 29 5d 0a 09 20 5b 65 6c 73 65 0a 09 20 20 28 ))].. [else.. (
2070: 6a 73 6f 6e 2d 3e 73 74 72 69 6e 67 20 22 22 29 json->string "")
2080: 5d 29 29 0a 20 0a 20 29 0a 0a 3b 3b 23 21 65 6f ])). . )..;;#!eo
2090: 66 0a f.