Artifact 78fb417fba0fc577d95d2632602b0186ab9b5bd6:
- File lmdb/ffi.ss — part of check-in [112a40d018] at 2016-09-01 08:27:10 on branch trunk — various improvements, added lmdb , added license notices (user: ovenpasta@pizzahack.eu size: 1731)
0000: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax 0010: 63 61 73 74 0a 20 20 28 73 79 6e 74 61 78 2d 72 cast. (syntax-r 0020: 75 6c 65 73 20 28 29 0a 20 20 20 20 5b 28 5f 20 ules (). [(_ 0030: 74 79 70 65 20 70 74 72 29 0a 20 20 20 20 20 28 type ptr). ( 0040: 6d 61 6b 65 2d 66 74 79 70 65 2d 70 6f 69 6e 74 make-ftype-point 0050: 65 72 20 74 79 70 65 20 28 69 66 20 28 66 74 79 er type (if (fty 0060: 70 65 2d 70 6f 69 6e 74 65 72 3f 20 70 74 72 29 pe-pointer? ptr) 0070: 20 28 66 74 79 70 65 2d 70 6f 69 6e 74 65 72 2d (ftype-pointer- 0080: 61 64 64 72 65 73 73 20 70 74 72 29 0a 09 09 09 address ptr).... 0090: 09 20 20 70 74 72 29 29 5d 29 29 0a 0a 28 64 65 . ptr))]))..(de 00a0: 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 66 69 fine-syntax defi 00b0: 6e 65 2d 6d 64 62 2d 61 6c 6c 6f 63 61 74 6f 72 ne-mdb-allocator 00c0: 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 . (lambda (x) 00d0: 0a 20 20 20 20 20 28 73 79 6e 74 61 78 2d 63 61 . (syntax-ca 00e0: 73 65 20 78 20 28 29 20 0a 20 20 20 20 20 20 20 se x () . 00f0: 5b 28 5f 20 6e 61 6d 65 20 74 79 70 65 29 20 0a [(_ name type) . 0100: 09 28 62 65 67 69 6e 20 0a 09 20 20 23 60 28 62 .(begin .. #`(b 0110: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 66 egin.. (def 0120: 69 6e 65 20 28 6e 61 6d 65 29 20 0a 09 09 28 6d ine (name) ...(m 0130: 64 62 2d 67 75 61 72 64 2d 70 6f 69 6e 74 65 72 db-guard-pointer 0140: 20 28 6d 61 6b 65 2d 66 74 79 70 65 2d 70 6f 69 (make-ftype-poi 0150: 6e 74 65 72 20 74 79 70 65 20 28 66 6f 72 65 69 nter type (forei 0160: 67 6e 2d 61 6c 6c 6f 63 20 28 66 74 79 70 65 2d gn-alloc (ftype- 0170: 73 69 7a 65 6f 66 20 74 79 70 65 29 29 29 29 29 sizeof type))))) 0180: 0a 09 20 20 20 20 20 20 29 29 5d 29 29 29 0a 20 .. ))]))). 0190: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 (define-syntax d 01a0: 65 66 69 6e 65 2d 6d 64 62 2d 61 72 72 61 79 2d efine-mdb-array- 01b0: 61 6c 6c 6f 63 61 74 6f 72 20 0a 20 20 20 28 6c allocator . (l 01c0: 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 28 ambda (x). ( 01d0: 73 79 6e 74 61 78 2d 63 61 73 65 20 78 20 28 29 syntax-case x () 01e0: 20 0a 20 20 20 20 20 20 20 5b 28 5f 20 6e 61 6d . [(_ nam 01f0: 65 20 74 79 70 65 20 65 6c 65 6d 65 6e 74 2d 74 e type element-t 0200: 79 70 65 29 20 0a 09 28 62 65 67 69 6e 0a 09 20 ype) ..(begin.. 0210: 20 23 27 28 64 65 66 69 6e 65 20 28 6e 61 6d 65 #'(define (name 0220: 20 73 69 7a 65 29 20 0a 09 20 20 20 20 20 20 28 size) .. ( 0230: 6d 64 62 2d 67 75 61 72 64 2d 70 6f 69 6e 74 65 mdb-guard-pointe 0240: 72 20 28 6d 61 6b 65 2d 66 74 79 70 65 2d 70 6f r (make-ftype-po 0250: 69 6e 74 65 72 20 74 79 70 65 20 28 66 6f 72 65 inter type (fore 0260: 69 67 6e 2d 61 6c 6c 6f 63 20 28 2a 20 28 66 74 ign-alloc (* (ft 0270: 79 70 65 2d 73 69 7a 65 6f 66 20 65 6c 65 6d 65 ype-sizeof eleme 0280: 6e 74 2d 74 79 70 65 29 20 73 69 7a 65 29 29 29 nt-type) size))) 0290: 29 29 29 5d 29 29 29 0a 0a 20 28 64 65 66 69 6e )))]))).. (defin 02a0: 65 2d 73 79 6e 74 61 78 20 64 65 66 69 6e 65 2d e-syntax define- 02b0: 6c 6d 64 62 2d 66 75 6e 63 0a 20 20 20 28 6c 61 lmdb-func. (la 02c0: 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 28 73 mbda (x). (s 02d0: 79 6e 74 61 78 2d 63 61 73 65 20 78 20 28 29 0a yntax-case x (). 02e0: 20 20 20 20 20 20 20 5b 28 5f 20 72 65 74 2d 74 [(_ ret-t 02f0: 79 70 65 20 6e 61 6d 65 20 28 28 61 72 67 2d 6e ype name ((arg-n 0300: 61 6d 65 20 61 72 67 2d 74 79 70 65 29 20 2e 2e ame arg-type) .. 0310: 2e 29 20 63 2d 6e 61 6d 65 29 20 0a 09 28 77 69 .) c-name) ..(wi 0320: 74 68 2d 73 79 6e 74 61 78 20 0a 09 20 28 5b 66 th-syntax .. ([f 0330: 75 6e 63 74 69 6f 6e 2d 66 74 79 70 65 20 0a 09 unction-ftype .. 0340: 20 20 20 28 64 61 74 75 6d 2d 3e 73 79 6e 74 61 (datum->synta 0350: 78 20 23 27 6e 61 6d 65 20 0a 09 09 09 20 20 28 x #'name .... ( 0360: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 0a string->symbol . 0370: 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d 61 70 ... (string-ap 0380: 70 65 6e 64 20 0a 09 09 09 20 20 20 20 28 73 79 pend .... (sy 0390: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 0a 09 09 mbol->string ... 03a0: 09 20 20 20 20 20 28 73 79 6e 74 61 78 2d 3e 64 . (syntax->d 03b0: 61 74 75 6d 20 23 27 6e 61 6d 65 29 29 20 22 2d atum #'name)) "- 03c0: 66 74 22 29 29 29 5d 29 0a 09 20 23 60 28 62 65 ft")))]).. #`(be 03d0: 67 69 6e 0a 09 20 20 20 20 20 28 64 65 66 69 6e gin.. (defin 03e0: 65 20 6e 61 6d 65 20 28 6c 61 6d 62 64 61 20 28 e name (lambda ( 03f0: 61 72 67 2d 6e 61 6d 65 20 2e 2e 2e 29 0a 09 20 arg-name ...).. 0400: 20 20 20 20 20 20 28 64 65 66 69 6e 65 2d 66 74 (define-ft 0410: 79 70 65 20 66 75 6e 63 74 69 6f 6e 2d 66 74 79 ype function-fty 0420: 70 65 20 28 66 75 6e 63 74 69 6f 6e 20 28 61 72 pe (function (ar 0430: 67 2d 74 79 70 65 20 2e 2e 2e 29 20 72 65 74 2d g-type ...) ret- 0440: 74 79 70 65 29 29 0a 09 20 20 20 20 20 20 20 28 type)).. ( 0450: 6c 65 74 2a 20 28 5b 66 75 6e 63 74 69 6f 6e 2d let* ([function- 0460: 66 70 74 72 20 20 28 6d 61 6b 65 2d 66 74 79 70 fptr (make-ftyp 0470: 65 2d 70 6f 69 6e 74 65 72 20 66 75 6e 63 74 69 e-pointer functi 0480: 6f 6e 2d 66 74 79 70 65 20 63 2d 6e 61 6d 65 29 on-ftype c-name) 0490: 5d 0a 09 09 20 20 20 20 20 20 5b 66 75 6e 63 74 ]... [funct 04a0: 69 6f 6e 20 20 20 20 20 20 20 28 66 74 79 70 65 ion (ftype 04b0: 2d 72 65 66 20 66 75 6e 63 74 69 6f 6e 2d 66 74 -ref function-ft 04c0: 79 70 65 20 28 29 20 66 75 6e 63 74 69 6f 6e 2d ype () function- 04d0: 66 70 74 72 29 5d 29 0a 09 09 20 28 6c 65 74 20 fptr)])... (let 04e0: 28 5b 72 65 73 75 6c 74 20 28 66 75 6e 63 74 69 ([result (functi 04f0: 6f 6e 20 61 72 67 2d 6e 61 6d 65 20 2e 2e 2e 29 on arg-name ...) 0500: 5d 29 0a 09 09 20 20 20 23 2c 28 63 61 73 65 20 ])... #,(case 0510: 28 64 61 74 75 6d 20 23 27 72 65 74 2d 74 79 70 (datum #'ret-typ 0520: 65 29 0a 09 09 20 20 20 20 20 20 20 5b 28 23 27 e)... [(#' 0530: 69 6e 74 29 20 23 60 28 69 66 20 28 6e 6f 74 20 int) #`(if (not 0540: 28 3d 20 72 65 73 75 6c 74 20 30 29 29 0a 09 09 (= result 0))... 0550: 09 09 20 20 20 20 28 72 61 69 73 65 20 3b 28 63 .. (raise ;(c 0560: 6f 6e 64 69 74 69 6f 6e 20 0a 09 09 09 09 09 20 ondition ...... 0570: 20 20 20 3b 28 6d 61 6b 65 2d 65 72 72 6f 72 29 ;(make-error) 0580: 20 0a 09 09 09 09 09 20 20 20 20 3b 28 6d 61 6b ...... ;(mak 0590: 65 2d 6d 65 73 73 61 67 65 2d 63 6f 6e 64 69 74 e-message-condit 05a0: 69 6f 6e 20 22 72 65 74 75 72 6e 65 64 20 65 72 ion "returned er 05b0: 72 6f 72 20 7e 64 3a 20 7e 64 22 29 20 0a 09 09 ror ~d: ~d") ... 05c0: 09 09 09 20 20 20 20 3b 28 6d 61 6b 65 2d 69 72 ... ;(make-ir 05d0: 72 69 74 61 6e 74 73 2d 63 6f 6e 64 69 74 69 6f ritants-conditio 05e0: 6e 20 72 65 73 75 6c 74 20 28 6d 64 62 2d 73 74 n result (mdb-st 05f0: 72 65 72 72 6f 72 20 72 65 73 75 6c 74 29 29 0a rerror result)). 0600: 09 09 09 09 09 20 20 20 20 28 6d 61 6b 65 2d 6d ..... (make-m 0610: 64 62 2d 63 6f 6e 64 20 72 65 73 75 6c 74 20 28 db-cond result ( 0620: 6d 64 62 2d 73 74 72 65 72 72 6f 72 20 72 65 73 mdb-strerror res 0630: 75 6c 74 29 29 29 0a 09 09 09 09 09 20 20 20 0a ult)))...... . 0640: 09 09 09 09 20 20 20 20 23 2c 28 63 61 73 65 20 .... #,(case 0650: 28 64 61 74 75 6d 20 23 27 6e 61 6d 65 29 0a 09 (datum #'name).. 0660: 09 09 09 09 5b 65 6c 73 65 20 23 27 72 65 73 75 ....[else #'resu 0670: 6c 74 5d 29 29 5d 0a 09 09 20 20 20 20 20 20 20 lt]))]... 0680: 5b 65 6c 73 65 20 28 70 72 69 6e 74 66 20 22 65 [else (printf "e 0690: 6c 73 65 20 7e 64 7e 6e 22 20 28 64 61 74 75 6d lse ~d~n" (datum 06a0: 20 23 27 72 65 74 2d 74 79 70 65 29 29 20 23 27 #'ret-type)) #' 06b0: 72 65 73 75 6c 74 5d 29 29 29 29 29 29 29 5d 29 result])))))))]) 06c0: 29 29 0a )).