Artifact
f91b0c26deb333b2c5a1c47e7c65b040afe03698:
- File
lmdb/parse-json.ss
— part of check-in
[b358a80757]
at
2016-09-04 14:50:46
on branch trunk
— added missing file changes
(user:
aldo
size: 4571)
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 28 69 6d 70 6f 72 74 20 28 ense...(import (
0260: 73 63 68 65 6d 65 29 0a 09 28 6a 73 6f 6e 29 29 scheme)..(json))
0270: 0a 0a 28 69 6d 70 6f 72 74 20 28 6f 6e 6c 79 20 ..(import (only
0280: 28 74 68 75 6e 64 65 72 2d 75 74 69 6c 73 29 20 (thunder-utils)
0290: 73 74 72 69 6e 67 2d 72 65 70 6c 61 63 65 20 73 string-replace s
02a0: 74 72 69 6e 67 2d 73 70 6c 69 74 29 20 0a 09 28 tring-split) ..(
02b0: 6f 6e 6c 79 20 28 73 72 66 69 20 73 31 33 20 73 only (srfi s13 s
02c0: 74 72 69 6e 67 73 29 20 73 74 72 69 6e 67 2d 64 trings) string-d
02d0: 72 6f 70 20 73 74 72 69 6e 67 2d 64 6f 77 6e 63 rop string-downc
02e0: 61 73 65 20 73 74 72 69 6e 67 2d 70 72 65 66 69 ase string-prefi
02f0: 78 3f 20 73 74 72 69 6e 67 2d 73 75 66 66 69 78 x? string-suffix
0300: 3f 20 73 74 72 69 6e 67 2d 64 65 6c 65 74 65 29 ? string-delete)
0310: 0a 09 28 6f 6e 6c 79 20 28 73 72 66 69 20 73 31 ..(only (srfi s1
0320: 20 6c 69 73 74 73 29 20 66 6f 6c 64 29 0a 09 28 lists) fold)..(
0330: 73 72 66 69 20 73 31 34 20 63 68 61 72 2d 73 65 srfi s14 char-se
0340: 74 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 ts))..(define (a
0350: 6e 74 69 2d 63 61 6d 65 6c 20 78 29 0a 20 20 28 nti-camel x). (
0360: 6c 65 74 2a 20 28 5b 78 20 28 73 74 72 69 6e 67 let* ([x (string
0370: 2d 72 65 70 6c 61 63 65 20 78 20 23 5c 5f 20 23 -replace x #\_ #
0380: 5c 2d 29 5d 0a 09 20 5b 6c 65 6e 20 28 73 74 72 \-)].. [len (str
0390: 69 6e 67 2d 6c 65 6e 67 74 68 20 78 29 5d 0a 09 ing-length x)]..
03a0: 20 5b 66 20 28 6c 61 6d 62 64 61 20 28 73 20 6c [f (lambda (s l
03b0: 65 6e 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 en).. (list
03c0: 2d 3e 73 74 72 69 6e 67 0a 09 20 20 20 20 20 20 ->string..
03d0: 20 28 72 65 76 65 72 73 65 0a 09 09 28 66 6f 6c (reverse...(fol
03e0: 64 20 28 6c 61 6d 62 64 61 20 28 69 20 61 63 63 d (lambda (i acc
03f0: 29 20 0a 09 09 09 28 6c 65 74 20 28 5b 61 20 28 ) ....(let ([a (
0400: 73 74 72 69 6e 67 2d 72 65 66 20 73 20 69 29 5d string-ref s i)]
0410: 20 0a 09 09 09 20 20 20 20 20 20 5b 6e 65 78 74 .... [next
0420: 20 28 69 66 20 28 3c 20 28 2b 20 31 20 69 29 20 (if (< (+ 1 i)
0430: 6c 65 6e 29 20 28 73 74 72 69 6e 67 2d 72 65 66 len) (string-ref
0440: 20 73 20 28 2b 20 31 20 69 29 29 20 23 66 29 5d s (+ 1 i)) #f)]
0450: 0a 09 09 09 20 20 20 20 20 20 5b 70 72 65 76 20 .... [prev
0460: 28 69 66 20 28 3e 20 69 20 30 29 20 28 73 74 72 (if (> i 0) (str
0470: 69 6e 67 2d 72 65 66 20 73 20 28 2d 20 69 20 31 ing-ref s (- i 1
0480: 29 29 20 23 66 29 5d 29 0a 09 09 09 20 20 28 69 )) #f)]).... (i
0490: 66 20 28 61 6e 64 20 28 63 68 61 72 2d 75 70 70 f (and (char-upp
04a0: 65 72 2d 63 61 73 65 3f 20 61 29 20 20 6e 65 78 er-case? a) nex
04b0: 74 20 70 72 65 76 0a 09 09 09 09 20 20 20 28 6e t prev..... (n
04c0: 6f 74 20 0a 09 09 09 09 20 20 20 20 28 6f 72 20 ot ..... (or
04d0: 28 63 68 61 72 3d 3f 20 61 20 23 5c 2d 29 20 28 (char=? a #\-) (
04e0: 63 68 61 72 3d 3f 20 70 72 65 76 20 23 5c 2d 29 char=? prev #\-)
04f0: 20 28 63 68 61 72 3d 3f 20 6e 65 78 74 20 23 5c (char=? next #\
0500: 2d 29 0a 09 09 09 09 09 28 61 6e 64 20 28 63 68 -)......(and (ch
0510: 61 72 2d 75 70 70 65 72 2d 63 61 73 65 3f 20 6e ar-upper-case? n
0520: 65 78 74 29 20 28 63 68 61 72 2d 75 70 70 65 72 ext) (char-upper
0530: 2d 63 61 73 65 3f 20 70 72 65 76 29 29 29 29 29 -case? prev)))))
0540: 0a 09 09 09 20 20 20 20 20 20 28 63 6f 6e 73 20 .... (cons
0550: 28 63 68 61 72 2d 64 6f 77 6e 63 61 73 65 20 61 (char-downcase a
0560: 29 20 28 63 6f 6e 73 20 23 5c 2d 20 61 63 63 29 ) (cons #\- acc)
0570: 29 0a 09 09 09 20 20 20 20 20 20 28 63 6f 6e 73 ).... (cons
0580: 20 28 63 68 61 72 2d 64 6f 77 6e 63 61 73 65 20 (char-downcase
0590: 61 29 20 61 63 63 29 29 29 29 20 27 28 29 20 28 a) acc)))) '() (
05a0: 69 6f 74 61 20 6c 65 6e 29 29 29 29 29 5d 29 0a iota len)))))]).
05b0: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 5b (cond. [
05c0: 23 66 20 23 66 5d 0a 20 20 20 20 20 5b 65 6c 73 #f #f]. [els
05d0: 65 20 28 66 20 78 20 6c 65 6e 29 5d 29 29 29 0a e (f x len)]))).
05e0: 0a 28 64 65 66 69 6e 65 20 28 61 64 64 2d 74 20 .(define (add-t
05f0: 78 29 0a 20 20 28 6c 65 74 20 28 5b 78 64 20 28 x). (let ([xd (
0600: 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 string-downcase
0610: 78 29 5d 29 0a 20 20 20 20 28 69 66 20 28 61 6e x)]). (if (an
0620: 64 20 28 73 74 72 69 6e 67 2d 70 72 65 66 69 78 d (string-prefix
0630: 3f 20 22 6c 6d 64 62 2d 22 20 78 64 29 20 0a 09 ? "lmdb-" xd) ..
0640: 20 20 20 20 20 28 6e 6f 74 20 20 28 6f 72 20 28 (not (or (
0650: 73 74 72 69 6e 67 2d 73 75 66 66 69 78 3f 20 22 string-suffix? "
0660: 2a 22 20 78 29 20 28 73 74 72 69 6e 67 2d 73 75 *" x) (string-su
0670: 66 66 69 78 3f 20 22 2d 74 22 20 78 29 29 29 29 ffix? "-t" x))))
0680: 0a 09 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 ..(string-append
0690: 20 78 20 22 2d 74 22 29 0a 09 78 29 29 29 0a 0a x "-t")..x)))..
06a0: 28 64 65 66 69 6e 65 20 28 61 64 64 2d 2a 20 78 (define (add-* x
06b0: 29 0a 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 ). (string-appe
06c0: 6e 64 20 78 20 22 2a 22 29 29 0a 20 0a 28 64 65 nd x "*")). .(de
06d0: 66 69 6e 65 20 28 64 65 63 6f 64 65 2d 74 79 70 fine (decode-typ
06e0: 65 20 74 29 0a 20 20 28 69 66 20 74 0a 20 20 20 e t). (if t.
06f0: 20 20 20 28 6c 65 74 2d 6a 73 6f 6e 2d 6f 62 6a (let-json-obj
0700: 65 63 74 20 74 20 28 74 61 67 20 74 79 70 65 29 ect t (tag type)
0710: 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 ... (let (
0720: 5b 74 61 67 2a 20 28 69 66 20 28 73 74 72 69 6e [tag* (if (strin
0730: 67 3f 20 74 61 67 29 20 28 73 74 72 69 6e 67 2d g? tag) (string-
0740: 3e 73 79 6d 62 6f 6c 20 74 61 67 29 20 74 61 67 >symbol tag) tag
0750: 29 5d 29 0a 09 09 09 20 28 63 61 73 65 20 74 61 )]).... (case ta
0760: 67 2a 0a 09 09 09 20 20 20 5b 3a 66 75 6e 63 74 g*.... [:funct
0770: 69 6f 6e 2d 70 6f 69 6e 74 65 72 20 27 76 6f 69 ion-pointer 'voi
0780: 64 2a 5d 0a 09 09 09 20 20 20 5b 3a 69 6e 74 20 d*].... [:int
0790: 27 69 6e 74 5d 0a 09 09 09 20 20 20 5b 3a 75 6e 'int].... [:un
07a0: 73 69 67 6e 65 64 2d 69 6e 74 20 27 75 6e 73 69 signed-int 'unsi
07b0: 67 6e 65 64 2d 69 6e 74 5d 0a 09 09 09 20 20 20 gned-int]....
07c0: 5b 3a 75 6e 73 69 67 6e 65 64 2d 6c 6f 6e 67 2d [:unsigned-long-
07d0: 6c 6f 6e 67 20 27 75 6e 73 69 67 6e 65 64 2d 6c long 'unsigned-l
07e0: 6f 6e 67 2d 6c 6f 6e 67 5d 0a 09 09 09 20 20 20 ong-long]....
07f0: 5b 3a 75 6e 73 69 67 6e 65 64 2d 6c 6f 6e 67 20 [:unsigned-long
0800: 27 75 6e 73 69 67 6e 65 64 2d 6c 6f 6e 67 5d 0a 'unsigned-long].
0810: 09 09 09 20 20 20 5b 3a 6c 6f 6e 67 20 27 6c 6f ... [:long 'lo
0820: 6e 67 5d 0a 09 09 09 20 20 20 5b 3a 64 6f 75 62 ng].... [:doub
0830: 6c 65 20 27 64 6f 75 62 6c 65 5d 0a 09 09 09 20 le 'double]....
0840: 20 20 5b 3a 6c 6f 6e 67 2d 64 6f 75 62 6c 65 20 [:long-double
0850: 27 6c 6f 6e 67 2d 64 6f 75 62 6c 65 5d 0a 09 09 'long-double]...
0860: 09 20 20 20 5b 3a 66 6c 6f 61 74 20 27 66 6c 6f . [:float 'flo
0870: 61 74 5d 0a 09 09 09 20 20 20 5b 3a 70 6f 69 6e at].... [:poin
0880: 74 65 72 20 28 6c 65 74 20 28 5b 70 74 20 28 64 ter (let ([pt (d
0890: 65 63 6f 64 65 2d 74 79 70 65 20 74 79 70 65 29 ecode-type type)
08a0: 5d 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 ])..... (c
08b0: 61 73 65 20 70 74 0a 09 09 09 09 09 20 28 63 68 ase pt...... (ch
08c0: 61 72 20 27 73 74 72 69 6e 67 29 0a 09 09 09 09 ar 'string).....
08d0: 09 20 28 76 6f 69 64 20 27 76 6f 69 64 2a 29 0a . (void 'void*).
08e0: 09 09 09 09 09 20 28 73 74 72 69 6e 67 20 27 76 ..... (string 'v
08f0: 6f 69 64 2a 29 0a 09 09 09 09 09 20 28 65 6c 73 oid*)...... (els
0900: 65 0a 09 09 09 09 09 20 20 28 69 66 20 28 61 6e e...... (if (an
0910: 64 20 28 70 61 69 72 3f 20 70 74 20 29 20 28 65 d (pair? pt ) (e
0920: 71 3f 20 28 63 61 72 20 70 74 29 20 27 2a 29 29 q? (car pt) '*))
0930: 0a 09 09 09 09 09 20 20 20 20 20 20 28 63 61 73 ...... (cas
0940: 65 20 28 63 64 72 20 70 74 29 0a 09 09 09 09 09 e (cdr pt)......
0950: 09 5b 27 6d 64 62 2d 65 6e 76 20 27 6d 64 62 2d .['mdb-env 'mdb-
0960: 65 6e 76 2a 5d 0a 09 09 09 09 09 09 5b 27 6d 64 env*].......['md
0970: 62 2d 74 78 6e 20 27 6d 64 62 2d 74 78 6e 2a 5d b-txn 'mdb-txn*]
0980: 0a 09 09 09 09 09 09 5b 65 6c 73 65 20 27 76 6f .......[else 'vo
0990: 69 64 2a 5d 29 20 3b 3b 20 44 4f 55 42 4c 45 20 id*]) ;; DOUBLE
09a0: 53 54 41 52 20 53 45 45 4d 53 20 4e 4f 54 20 53 STAR SEEMS NOT S
09b0: 55 50 50 4f 52 54 45 44 20 4f 4e 20 43 48 45 5a UPPORTED ON CHEZ
09c0: 0a 09 09 09 09 09 20 20 20 20 20 60 28 2a 20 2c ...... `(* ,
09d0: 70 74 29 29 0a 09 09 09 09 09 20 20 23 3b 28 73 pt))...... #;(s
09e0: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 0a 09 tring->symbol ..
09f0: 09 09 09 09 20 20 20 28 61 64 64 2d 2a 0a 09 09 .... (add-*...
0a00: 09 09 09 20 20 20 20 28 73 79 6d 62 6f 6c 2d 3e ... (symbol->
0a10: 73 74 72 69 6e 67 20 70 74 29 29 29 0a 09 09 09 string pt)))....
0a20: 09 09 20 20 29 29 29 5d 0a 09 09 09 20 20 20 5b .. )))].... [
0a30: 3a 76 6f 69 64 20 27 76 6f 69 64 5d 0a 09 09 09 :void 'void]....
0a40: 20 20 20 5b 3a 63 68 61 72 20 27 63 68 61 72 5d [:char 'char]
0a50: 0a 09 09 09 20 20 20 5b 3a 75 6e 73 69 67 6e 65 .... [:unsigne
0a60: 64 2d 63 68 61 72 20 27 75 6e 73 69 67 6e 65 64 d-char 'unsigned
0a70: 2d 38 5d 0a 09 09 09 20 20 20 5b 28 29 0a 09 09 -8].... [()...
0a80: 09 20 20 20 20 60 28 2a 20 2c 28 73 74 72 69 6e . `(* ,(strin
0a90: 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e g->symbol (strin
0aa0: 67 2d 72 65 70 6c 61 63 65 20 28 73 79 6d 62 6f g-replace (symbo
0ab0: 6c 2d 3e 73 74 72 69 6e 67 20 74 61 67 2a 29 20 l->string tag*)
0ac0: 23 5c 5f 20 23 5c 2d 29 29 29 5d 0a 09 09 09 20 #\_ #\-)))]....
0ad0: 20 20 5b 4d 44 42 5f 73 74 61 74 20 27 6d 64 62 [MDB_stat 'mdb
0ae0: 2d 73 74 61 74 2d 74 5d 0a 09 09 09 20 20 20 5b -stat-t].... [
0af0: 4d 44 42 5f 65 6e 76 69 6e 66 6f 20 27 6d 64 62 MDB_envinfo 'mdb
0b00: 2d 65 6e 76 69 6e 66 6f 2d 74 5d 0a 09 09 09 20 -envinfo-t]....
0b10: 20 20 5b 4d 44 42 5f 63 75 72 73 6f 72 5f 6f 70 [MDB_cursor_op
0b20: 20 27 6d 64 62 2d 63 75 72 73 6f 72 2d 6f 70 2d 'mdb-cursor-op-
0b30: 74 5d 0a 09 09 09 20 20 20 5b 65 6c 73 65 20 28 t].... [else (
0b40: 69 66 20 28 73 79 6d 62 6f 6c 3f 20 74 61 67 2a if (symbol? tag*
0b50: 29 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 69 )..... (stri
0b60: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 0a 09 09 09 09 ng->symbol .....
0b70: 20 20 20 20 20 20 28 61 64 64 2d 74 0a 09 09 09 (add-t....
0b80: 09 20 20 20 20 20 20 20 28 61 6e 74 69 2d 63 61 . (anti-ca
0b90: 6d 65 6c 20 0a 09 09 09 09 09 28 73 79 6d 62 6f mel ......(symbo
0ba0: 6c 2d 3e 73 74 72 69 6e 67 20 74 61 67 2a 29 29 l->string tag*))
0bb0: 29 29 0a 09 09 09 09 20 20 20 20 20 74 61 67 2a ))..... tag*
0bc0: 29 5d 29 29 29 0a 20 20 20 20 20 20 23 66 29 29 )]))). #f))
0bd0: 0a 28 64 65 66 69 6e 65 20 28 64 65 63 6f 64 65 .(define (decode
0be0: 2d 70 61 72 61 6d 20 70 29 0a 20 20 28 6c 65 74 -param p). (let
0bf0: 2d 6a 73 6f 6e 2d 6f 62 6a 65 63 74 20 70 20 28 -json-object p (
0c00: 74 61 67 20 6e 61 6d 65 20 74 79 70 65 29 0a 09 tag name type)..
0c10: 09 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 . (if (equal?
0c20: 6e 61 6d 65 20 22 22 29 20 0a 09 09 20 20 20 20 name "") ...
0c30: 20 20 20 28 64 65 63 6f 64 65 2d 74 79 70 65 20 (decode-type
0c40: 74 79 70 65 29 0a 09 09 20 20 20 20 20 20 20 28 type)... (
0c50: 6c 69 73 74 20 6e 61 6d 65 20 28 64 65 63 6f 64 list name (decod
0c60: 65 2d 74 79 70 65 20 74 79 70 65 29 29 29 29 29 e-type type)))))
0c70: 0a 0a 0a 28 64 65 66 69 6e 65 20 6c 6d 64 62 2d ...(define lmdb-
0c80: 6a 73 6f 6e 2d 74 65 78 74 20 28 72 65 61 64 2d json-text (read-
0c90: 66 69 6c 65 20 22 6c 6d 64 62 2e 6a 73 6f 6e 22 file "lmdb.json"
0ca0: 29 29 0a 28 64 65 66 69 6e 65 20 6c 6d 64 62 2d )).(define lmdb-
0cb0: 6a 73 6f 6e 20 28 73 74 72 69 6e 67 2d 3e 6a 73 json (string->js
0cc0: 6f 6e 20 6c 6d 64 62 2d 6a 73 6f 6e 2d 74 65 78 on lmdb-json-tex
0cd0: 74 29 29 0a 0a 28 77 69 74 68 2d 6f 75 74 70 75 t))..(with-outpu
0ce0: 74 2d 74 6f 2d 66 69 6c 65 20 22 6c 6d 64 62 2e t-to-file "lmdb.
0cf0: 73 65 78 70 22 20 28 6c 61 6d 62 64 61 20 28 29 sexp" (lambda ()
0d00: 20 28 70 72 65 74 74 79 2d 70 72 69 6e 74 20 6c (pretty-print l
0d10: 6d 64 62 2d 6a 73 6f 6e 29 29 20 27 74 72 75 6e mdb-json)) 'trun
0d20: 63 61 74 65 29 0a 0a 0a 28 64 65 66 69 6e 65 20 cate)...(define
0d30: 62 6c 61 63 6b 6c 69 73 74 20 27 28 29 29 0a 0a blacklist '())..
0d40: 28 69 6d 70 6f 72 74 20 28 6f 6e 6c 79 20 28 73 (import (only (s
0d50: 72 66 69 20 73 31 33 20 73 74 72 69 6e 67 73 29 rfi s13 strings)
0d60: 20 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 string-contains
0d70: 29 29 0a 28 64 65 66 69 6e 65 20 28 70 61 72 73 )).(define (pars
0d80: 65 2d 6a 73 6f 6e 2d 66 75 6e 63 74 69 6f 6e 20 e-json-function
0d90: 78 20 6d 29 0a 20 20 28 6c 65 74 2d 6a 73 6f 6e x m). (let-json
0da0: 2d 6f 62 6a 65 63 74 20 78 20 28 74 61 67 20 6e -object x (tag n
0db0: 61 6d 65 20 6c 6f 63 61 74 69 6f 6e 20 72 65 74 ame location ret
0dc0: 75 72 6e 2d 74 79 70 65 20 70 61 72 61 6d 65 74 urn-type paramet
0dd0: 65 72 73 29 20 0a 09 09 20 20 20 28 69 66 20 28 ers) ... (if (
0de0: 61 6e 64 20 20 28 6f 72 20 28 73 74 72 69 6e 67 and (or (string
0df0: 2d 63 6f 6e 74 61 69 6e 73 20 6c 6f 63 61 74 69 -contains locati
0e00: 6f 6e 20 6d 29 20 0a 09 09 09 09 28 61 6e 64 20 on m) .....(and
0e10: 28 65 71 75 61 6c 3f 20 22 6c 6d 64 62 22 20 6d (equal? "lmdb" m
0e20: 29 20 28 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 ) (string-contai
0e30: 6e 73 20 6c 6f 63 61 74 69 6f 6e 20 22 6c 6d 64 ns location "lmd
0e40: 62 2e 68 22 29 29 29 0a 09 09 09 20 20 20 20 20 b.h")))....
0e50: 28 65 71 75 61 6c 3f 20 74 61 67 20 22 66 75 6e (equal? tag "fun
0e60: 63 74 69 6f 6e 22 29 0a 09 09 09 20 20 20 20 28 ction").... (
0e70: 73 74 72 69 6e 67 2d 70 72 65 66 69 78 3f 20 22 string-prefix? "
0e80: 6d 64 62 5f 22 20 6e 61 6d 65 29 29 0a 09 09 20 mdb_" name))...
0e90: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 5b (cond....[
0ea0: 28 6d 65 6d 71 20 28 73 74 72 69 6e 67 2d 3e 73 (memq (string->s
0eb0: 79 6d 62 6f 6c 20 28 61 6e 74 69 2d 63 61 6d 65 ymbol (anti-came
0ec0: 6c 20 6e 61 6d 65 29 29 20 62 6c 61 63 6b 6c 69 l name)) blackli
0ed0: 73 74 29 0a 09 09 09 20 28 70 72 69 6e 74 66 20 st).... (printf
0ee0: 22 3b 3b 62 6c 61 63 6b 6c 69 73 74 65 64 20 70 ";;blacklisted p
0ef0: 72 6f 62 61 62 6c 79 20 62 65 63 61 75 73 65 20 robably because
0f00: 69 74 20 75 73 65 73 20 61 20 73 74 72 75 63 74 it uses a struct
0f10: 20 61 73 20 76 61 6c 75 65 2e 5c 6e 28 64 65 66 as value.\n(def
0f20: 69 6e 65 20 7e 64 20 23 66 29 5c 6e 22 20 28 61 ine ~d #f)\n" (a
0f30: 6e 74 69 2d 63 61 6d 65 6c 20 6e 61 6d 65 29 29 nti-camel name))
0f40: 5d 0a 09 09 09 5b 65 6c 73 65 0a 09 09 09 20 20 ]....[else....
0f50: 20 28 70 72 69 6e 74 66 20 22 28 64 65 66 69 6e (printf "(defin
0f60: 65 2d 6c 6d 64 62 2d 66 75 6e 63 20 7e 64 20 7e e-lmdb-func ~d ~
0f70: 64 20 7e 64 20 5c 22 7e 64 5c 22 29 5c 6e 22 0a d ~d \"~d\")\n".
0f80: 09 09 09 09 20 20 20 28 64 65 63 6f 64 65 2d 74 .... (decode-t
0f90: 79 70 65 20 72 65 74 75 72 6e 2d 74 79 70 65 29 ype return-type)
0fa0: 20 0a 09 09 09 09 20 20 20 28 63 61 73 65 20 6e ..... (case n
0fb0: 61 6d 65 0a 09 09 09 09 20 20 20 20 20 5b 22 6d ame..... ["m
0fc0: 64 62 5f 65 6e 76 5f 63 72 65 61 74 65 22 20 22 db_env_create" "
0fd0: 6d 64 62 2d 65 6e 76 2d 63 72 65 61 74 65 25 22 mdb-env-create%"
0fe0: 5d 0a 09 09 09 09 20 20 20 20 20 5b 22 6d 64 62 ]..... ["mdb
0ff0: 5f 74 78 6e 5f 62 65 67 69 6e 22 20 22 6d 64 62 _txn_begin" "mdb
1000: 2d 74 78 6e 2d 62 65 67 69 6e 25 22 5d 0a 09 09 -txn-begin%"]...
1010: 09 09 20 20 20 20 20 5b 22 6d 64 62 5f 64 62 69 .. ["mdb_dbi
1020: 5f 6f 70 65 6e 22 20 22 6d 64 62 2d 64 62 69 2d _open" "mdb-dbi-
1030: 6f 70 65 6e 25 22 5d 0a 09 09 09 09 20 20 20 20 open%"].....
1040: 20 5b 22 6d 64 62 5f 63 75 72 73 6f 72 5f 6f 70 ["mdb_cursor_op
1050: 65 6e 22 20 22 6d 64 62 2d 63 75 72 73 6f 72 2d en" "mdb-cursor-
1060: 6f 70 65 6e 25 22 5d 0a 09 09 09 09 20 20 20 20 open%"].....
1070: 20 28 65 6c 73 65 20 28 61 6e 74 69 2d 63 61 6d (else (anti-cam
1080: 65 6c 20 6e 61 6d 65 29 29 29 0a 09 09 09 09 20 el name))).....
1090: 20 20 0a 09 09 09 09 20 20 20 28 6d 61 70 20 28 ..... (map (
10a0: 6c 61 6d 62 64 61 20 28 70 29 20 28 64 65 63 6f lambda (p) (deco
10b0: 64 65 2d 70 61 72 61 6d 20 70 29 29 20 28 76 65 de-param p)) (ve
10c0: 63 74 6f 72 2d 3e 6c 69 73 74 20 70 61 72 61 6d ctor->list param
10d0: 65 74 65 72 73 29 29 0a 09 09 09 09 20 20 20 6e eters))..... n
10e0: 61 6d 65 29 5d 29 29 29 29 0a 0a 28 66 6f 72 2d ame)]))))..(for-
10f0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6d 29 each (lambda (m)
1100: 20 0a 09 20 20 20 20 28 77 69 74 68 2d 6f 75 74 .. (with-out
1110: 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 73 74 72 put-to-file (str
1120: 69 6e 67 2d 61 70 70 65 6e 64 20 28 63 61 72 20 ing-append (car
1130: 6d 29 20 22 2d 66 75 6e 63 74 69 6f 6e 73 2e 73 m) "-functions.s
1140: 73 22 29 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 s").. (lamb
1150: 64 61 20 28 29 20 0a 09 09 28 76 65 63 74 6f 72 da () ...(vector
1160: 2d 66 6f 72 2d 65 61 63 68 20 0a 09 09 20 28 6c -for-each ... (l
1170: 61 6d 62 64 61 20 28 78 29 20 0a 09 09 20 20 20 ambda (x) ...
1180: 28 70 61 72 73 65 2d 6a 73 6f 6e 2d 66 75 6e 63 (parse-json-func
1190: 74 69 6f 6e 20 78 20 28 63 61 72 20 6d 29 29 29 tion x (car m)))
11a0: 0a 09 09 20 28 63 64 72 20 6d 29 29 29 0a 09 20 ... (cdr m)))..
11b0: 20 20 20 20 20 27 74 72 75 6e 63 61 74 65 29 29 'truncate))
11c0: 20 60 28 28 22 6c 6d 64 62 22 20 2e 20 2c 6c 6d `(("lmdb" . ,lm
11d0: 64 62 2d 6a 73 6f 6e 29 29 29 0a db-json))).