Artifact
6512a546eba2adaf9c37598c9010a7b1df88cb7c:
- File
ffi-utils.sls
— part of check-in
[75d1b77428]
at
2018-12-09 15:35:27
on branch trunk
— fixed bug for in args-fold.sls thanks to anonymous
(user:
aldo
size: 7782)
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 72 36 72 73 0a 0a 28 ense...#!r6rs..(
0260: 6c 69 62 72 61 72 79 0a 20 28 66 66 69 2d 75 74 library. (ffi-ut
0270: 69 6c 73 29 0a 20 28 65 78 70 6f 72 74 20 64 65 ils). (export de
0280: 66 69 6e 65 2d 65 6e 75 6d 65 72 61 74 69 6f 6e fine-enumeration
0290: 2a 20 64 65 66 69 6e 65 2d 66 75 6e 63 74 69 6f * define-functio
02a0: 6e 20 0a 09 20 64 65 66 69 6e 65 2d 66 6c 61 67 n .. define-flag
02b0: 73 20 6d 61 6b 65 2d 66 6c 61 67 73 20 66 6c 61 s make-flags fla
02c0: 67 73 20 66 6c 61 67 73 2d 6e 61 6d 65 20 66 6c gs flags-name fl
02d0: 61 67 73 2d 61 6c 69 73 74 20 66 6c 61 67 73 2d ags-alist flags-
02e0: 69 6e 64 65 78 65 72 20 66 6c 61 67 73 2d 72 65 indexer flags-re
02f0: 66 2d 6d 61 6b 65 72 20 66 6c 61 67 73 2d 64 65 f-maker flags-de
0300: 63 6f 64 65 2d 6d 61 6b 65 72 0a 09 20 6c 65 74 code-maker.. let
0310: 2d 73 74 72 75 63 74 0a 09 20 63 68 61 72 2a 2d -struct.. char*-
0320: 3e 62 79 74 65 76 65 63 74 6f 72 20 63 61 73 74 >bytevector cast
0330: 0a 09 20 29 0a 20 28 69 6d 70 6f 72 74 20 28 63 .. ). (import (c
0340: 68 65 7a 73 63 68 65 6d 65 29 29 0a 0a 3b 3b 20 hezscheme))..;;
0350: 54 4f 44 4f 3a 20 6d 61 79 62 65 20 77 65 20 73 TODO: maybe we s
0360: 68 6f 75 6c 64 20 73 75 70 70 6f 72 74 20 6d 75 hould support mu
0370: 6c 74 69 70 6c 65 20 73 74 72 75 63 74 73 3f 0a ltiple structs?.
0380: 3b 3b 20 61 6e 64 20 6d 61 79 62 65 20 61 6c 73 ;; and maybe als
0390: 6f 20 6e 6f 72 6d 61 6c 20 6c 65 74 20 65 6e 74 o normal let ent
03a0: 72 69 65 73 3f 20 6c 65 74 2d 73 74 72 75 63 74 ries? let-struct
03b0: 2a 20 61 6c 73 6f 3f 0a 0a 20 28 64 65 66 69 6e * also?.. (defin
03c0: 65 2d 73 79 6e 74 61 78 20 6c 65 74 2d 73 74 72 e-syntax let-str
03d0: 75 63 74 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 uct. (lambda (
03e0: 78 29 0a 20 20 20 20 20 28 73 79 6e 74 61 78 2d x). (syntax-
03f0: 63 61 73 65 20 78 20 28 29 0a 20 20 20 20 20 20 case x ().
0400: 20 5b 28 5f 20 6f 62 6a 65 63 74 20 66 74 79 70 [(_ object ftyp
0410: 65 2d 6e 61 6d 65 20 28 66 69 65 6c 64 20 2e 2e e-name (field ..
0420: 2e 29 20 62 6f 64 79 20 2e 2e 2e 29 0a 09 23 27 .) body ...)..#'
0430: 28 6c 65 74 20 28 5b 66 69 65 6c 64 20 28 66 74 (let ([field (ft
0440: 79 70 65 2d 72 65 66 20 66 74 79 70 65 2d 6e 61 ype-ref ftype-na
0450: 6d 65 20 28 66 69 65 6c 64 29 20 6f 62 6a 65 63 me (field) objec
0460: 74 29 5d 20 2e 2e 2e 29 0a 09 20 20 20 20 62 6f t)] ...).. bo
0470: 64 79 20 2e 2e 2e 29 5d 29 29 29 0a 0a 20 3b 3b dy ...)]))).. ;;
0480: 20 55 73 65 73 20 6d 61 6b 65 2d 65 6e 75 6d 65 Uses make-enume
0490: 72 61 74 69 6f 6e 20 74 6f 20 64 65 66 69 6e 65 ration to define
04a0: 20 61 6e 20 65 6e 75 6d 20 77 69 74 68 20 74 68 an enum with th
04b0: 65 20 66 6f 6c 6c 6f 77 69 6e 67 3a 0a 20 3b 3b e following:. ;;
04c0: 20 66 75 6e 63 74 69 6f 6e 20 28 6e 61 6d 65 20 function (name
04d0: 78 29 20 2d 3e 20 69 6e 64 65 78 0a 20 3b 3b 20 x) -> index. ;;
04e0: 66 75 6e 63 74 69 6f 6e 20 28 6e 61 6d 65 2d 72 function (name-r
04f0: 65 66 20 69 6e 64 65 78 29 20 2d 3e 20 73 79 6d ef index) -> sym
0500: 62 6f 6c 0a 20 3b 3b 20 76 61 72 69 61 62 6c 65 bol. ;; variable
0510: 20 6e 61 6d 65 2d 65 6e 75 6d 20 20 2d 3e 20 23 name-enum -> #
0520: 3e 65 6e 75 6d 2d 73 65 74 3e 0a 20 3b 3b 20 6e >enum-set>. ;; n
0530: 61 6d 65 2d 74 20 2d 3e 20 66 74 79 70 65 20 69 ame-t -> ftype i
0540: 6e 74 0a 20 3b 3b 20 75 73 61 67 65 3a 20 28 64 nt. ;; usage: (d
0550: 65 66 69 6e 65 2d 65 6e 75 6d 65 72 61 74 69 6f efine-enumeratio
0560: 6e 2a 20 4e 41 4d 45 20 28 74 61 67 31 20 74 61 n* NAME (tag1 ta
0570: 67 32 20 74 61 67 33 20 2e 2e 2e 29 29 0a 0a 20 g2 tag3 ...))..
0580: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 (define-syntax d
0590: 65 66 69 6e 65 2d 65 6e 75 6d 65 72 61 74 69 6f efine-enumeratio
05a0: 6e 2a 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 78 n*. (lambda (x
05b0: 29 0a 20 20 20 20 20 28 64 65 66 69 6e 65 20 67 ). (define g
05c0: 65 6e 2d 69 64 0a 20 20 20 20 20 20 20 28 6c 61 en-id. (la
05d0: 6d 62 64 61 20 28 74 65 6d 70 6c 61 74 65 2d 69 mbda (template-i
05e0: 64 20 2e 20 61 72 67 73 29 0a 09 20 28 64 61 74 d . args).. (dat
05f0: 75 6d 2d 3e 73 79 6e 74 61 78 0a 09 20 20 74 65 um->syntax.. te
0600: 6d 70 6c 61 74 65 2d 69 64 0a 09 20 20 28 73 74 mplate-id.. (st
0610: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 0a 09 20 20 ring->symbol..
0620: 20 28 61 70 70 6c 79 20 73 74 72 69 6e 67 2d 61 (apply string-a
0630: 70 70 65 6e 64 0a 09 09 20 20 28 6d 61 70 20 28 ppend... (map (
0640: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 20 28 lambda (x).... (
0650: 69 66 20 28 73 74 72 69 6e 67 3f 20 78 29 20 78 if (string? x) x
0660: 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 (symbol->string
0670: 20 28 73 79 6e 74 61 78 2d 3e 64 61 74 75 6d 20 (syntax->datum
0680: 78 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 61 x))))... a
0690: 72 67 73 29 29 29 29 29 29 0a 20 20 20 20 20 28 rgs)))))). (
06a0: 73 79 6e 74 61 78 2d 63 61 73 65 20 78 20 28 29 syntax-case x ()
06b0: 0a 20 20 20 20 20 20 20 5b 28 5f 20 6e 61 6d 65 . [(_ name
06c0: 20 28 6c 20 2e 2e 2e 29 29 0a 09 28 77 69 74 68 (l ...))..(with
06d0: 2d 73 79 6e 74 61 78 20 28 5b 62 61 73 65 2d 6e -syntax ([base-n
06e0: 61 6d 65 20 28 67 65 6e 2d 69 64 20 23 27 6e 61 ame (gen-id #'na
06f0: 6d 65 20 22 22 20 23 27 6e 61 6d 65 29 5d 0a 09 me "" #'name)]..
0700: 09 20 20 20 20 20 20 5b 65 6e 75 6d 2d 6e 61 6d . [enum-nam
0710: 65 20 28 67 65 6e 2d 69 64 20 23 27 6e 61 6d 65 e (gen-id #'name
0720: 20 23 27 6e 61 6d 65 20 22 2d 65 6e 75 6d 22 29 #'name "-enum")
0730: 5d 0a 09 09 20 20 20 20 20 20 5b 72 65 66 2d 6e ]... [ref-n
0740: 61 6d 65 20 28 67 65 6e 2d 69 64 20 23 27 6e 61 ame (gen-id #'na
0750: 6d 65 20 23 27 6e 61 6d 65 20 22 2d 72 65 66 22 me #'name "-ref"
0760: 29 5d 0a 09 09 20 20 20 20 20 20 5b 6e 61 6d 65 )]... [name
0770: 2f 74 20 28 67 65 6e 2d 69 64 20 23 27 6e 61 6d /t (gen-id #'nam
0780: 65 20 23 27 6e 61 6d 65 20 22 2d 74 22 29 5d 29 e #'name "-t")])
0790: 0a 09 09 20 20 20 20 20 28 69 6e 64 69 72 65 63 ... (indirec
07a0: 74 2d 65 78 70 6f 72 74 20 62 61 73 65 2d 6e 61 t-export base-na
07b0: 6d 65 20 65 6e 75 6d 2d 6e 61 6d 65 20 72 65 66 me enum-name ref
07c0: 2d 6e 61 6d 65 20 6e 61 6d 65 2f 74 29 0a 09 09 -name name/t)...
07d0: 20 20 20 20 20 23 27 28 62 65 67 69 6e 0a 09 09 #'(begin...
07e0: 09 20 28 64 65 66 69 6e 65 20 65 6e 75 6d 2d 6e . (define enum-n
07f0: 61 6d 65 20 28 6d 61 6b 65 2d 65 6e 75 6d 65 72 ame (make-enumer
0800: 61 74 69 6f 6e 20 27 28 6c 20 2e 2e 2e 29 29 29 ation '(l ...)))
0810: 0a 09 09 09 20 28 64 65 66 69 6e 65 20 62 61 73 .... (define bas
0820: 65 2d 6e 61 6d 65 0a 09 09 09 20 20 20 28 6c 61 e-name.... (la
0830: 6d 62 64 61 20 28 78 29 0a 09 09 09 20 20 20 20 mbda (x)....
0840: 20 28 6c 65 74 20 28 5b 72 20 28 28 65 6e 75 6d (let ([r ((enum
0850: 2d 73 65 74 2d 69 6e 64 65 78 65 72 20 65 6e 75 -set-indexer enu
0860: 6d 2d 6e 61 6d 65 29 20 78 29 5d 29 0a 09 09 09 m-name) x)])....
0870: 20 20 20 20 20 20 20 28 69 66 20 72 20 72 0a 09 (if r r..
0880: 09 09 09 20 20 20 28 61 73 73 65 72 74 69 6f 6e ... (assertion
0890: 2d 76 69 6f 6c 61 74 69 6f 6e 20 27 65 6e 75 6d -violation 'enum
08a0: 2d 6e 61 6d 65 0a 09 09 09 09 09 09 09 22 73 79 -name........"sy
08b0: 6d 62 6f 6c 20 6e 6f 74 20 66 6f 75 6e 64 22 0a mbol not found".
08c0: 09 09 09 09 09 09 09 78 29 29 29 29 29 0a 09 09 .......x)))))...
08d0: 09 20 28 64 65 66 69 6e 65 20 72 65 66 2d 6e 61 . (define ref-na
08e0: 6d 65 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 61 me.... (lambda
08f0: 20 28 69 6e 64 65 78 29 0a 09 09 09 20 20 20 20 (index)....
0900: 20 28 6c 69 73 74 2d 72 65 66 20 28 65 6e 75 6d (list-ref (enum
0910: 2d 73 65 74 2d 3e 6c 69 73 74 20 65 6e 75 6d 2d -set->list enum-
0920: 6e 61 6d 65 29 20 69 6e 64 65 78 29 29 29 0a 09 name) index)))..
0930: 09 09 20 28 64 65 66 69 6e 65 2d 66 74 79 70 65 .. (define-ftype
0940: 20 6e 61 6d 65 2f 74 20 69 6e 74 29 29 29 5d 29 name/t int)))])
0950: 29 29 0a 0a 20 28 64 65 66 69 6e 65 2d 73 79 6e )).. (define-syn
0960: 74 61 78 20 64 65 66 69 6e 65 2d 66 75 6e 63 74 tax define-funct
0970: 69 6f 6e 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ion. (lambda (
0980: 78 29 0a 20 20 20 20 20 28 73 79 6e 74 61 78 2d x). (syntax-
0990: 63 61 73 65 20 78 20 28 29 0a 20 20 20 20 20 20 case x ().
09a0: 20 5b 28 5f 20 6e 61 6d 65 20 28 28 61 72 67 2d [(_ name ((arg-
09b0: 6e 61 6d 65 20 61 72 67 2d 74 79 70 65 29 20 2e name arg-type) .
09c0: 2e 2e 29 20 72 65 74 29 0a 09 23 27 28 64 65 66 ..) ret)..#'(def
09d0: 69 6e 65 20 6e 61 6d 65 20 0a 09 20 20 20 20 28 ine name .. (
09e0: 6c 61 6d 62 64 61 20 28 61 72 67 2d 6e 61 6d 65 lambda (arg-name
09f0: 20 2e 2e 2e 29 0a 09 20 20 20 20 20 20 28 66 6f ...).. (fo
0a00: 72 65 69 67 6e 2d 70 72 6f 63 65 64 75 72 65 20 reign-procedure
0a10: 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 (symbol->string
0a20: 6e 61 6d 65 29 20 28 61 72 67 2d 74 79 70 65 20 name) (arg-type
0a30: 2e 2e 2e 29 20 72 65 74 29 29 29 5d 0a 20 20 20 ...) ret)))].
0a40: 20 20 20 20 5b 28 5f 20 72 65 74 20 6e 61 6d 65 [(_ ret name
0a50: 20 28 28 61 72 67 2d 6e 61 6d 65 20 61 72 67 2d ((arg-name arg-
0a60: 74 79 70 65 29 20 2e 2e 2e 29 29 0a 09 23 27 28 type) ...))..#'(
0a70: 64 65 66 69 6e 65 20 6e 61 6d 65 20 0a 09 20 20 define name ..
0a80: 20 20 28 6c 61 6d 62 64 61 20 28 61 72 67 2d 6e (lambda (arg-n
0a90: 61 6d 65 20 2e 2e 2e 29 0a 09 20 20 20 20 20 20 ame ...)..
0aa0: 28 66 6f 72 65 69 67 6e 2d 70 72 6f 63 65 64 75 (foreign-procedu
0ab0: 72 65 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 re (symbol->stri
0ac0: 6e 67 20 6e 61 6d 65 29 20 28 61 72 67 2d 74 79 ng name) (arg-ty
0ad0: 70 65 20 2e 2e 2e 29 20 72 65 74 29 29 29 5d 0a pe ...) ret)))].
0ae0: 20 20 20 20 20 20 20 3b 3b 20 57 49 54 48 20 4f ;; WITH O
0af0: 4e 4c 59 20 41 52 47 55 4d 45 4e 54 20 54 59 50 NLY ARGUMENT TYP
0b00: 45 53 0a 20 20 20 20 20 20 20 5b 28 5f 20 6e 61 ES. [(_ na
0b10: 6d 65 20 28 61 72 67 73 20 2e 2e 2e 29 20 72 65 me (args ...) re
0b20: 74 29 0a 09 23 27 28 64 65 66 69 6e 65 20 6e 61 t)..#'(define na
0b30: 6d 65 0a 09 20 20 20 20 28 66 6f 72 65 69 67 6e me.. (foreign
0b40: 2d 70 72 6f 63 65 64 75 72 65 20 28 73 79 6d 62 -procedure (symb
0b50: 6f 6c 2d 3e 73 74 72 69 6e 67 20 27 6e 61 6d 65 ol->string 'name
0b60: 29 20 28 61 72 67 73 20 2e 2e 2e 29 20 72 65 74 ) (args ...) ret
0b70: 29 29 5d 0a 20 20 20 20 20 20 20 5b 28 5f 20 72 ))]. [(_ r
0b80: 65 74 20 6e 61 6d 65 20 28 61 72 67 73 20 2e 2e et name (args ..
0b90: 2e 29 29 0a 09 23 27 28 64 65 66 69 6e 65 20 6e .))..#'(define n
0ba0: 61 6d 65 0a 09 20 20 20 20 28 66 6f 72 65 69 67 ame.. (foreig
0bb0: 6e 2d 70 72 6f 63 65 64 75 72 65 20 28 73 79 6d n-procedure (sym
0bc0: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 27 6e 61 6d bol->string 'nam
0bd0: 65 29 20 28 61 72 67 73 20 2e 2e 2e 29 20 72 65 e) (args ...) re
0be0: 74 29 29 5d 29 29 29 0a 0a 28 64 65 66 69 6e 65 t))])))..(define
0bf0: 2d 73 79 6e 74 61 78 20 64 65 66 69 6e 65 2d 66 -syntax define-f
0c00: 75 6e 63 74 69 6f 6e 2a 0a 20 20 28 6c 61 6d 62 unction*. (lamb
0c10: 64 61 20 28 78 29 0a 20 20 20 20 28 64 65 66 69 da (x). (defi
0c20: 6e 65 20 28 72 65 6e 61 6d 65 2d 73 63 68 65 6d ne (rename-schem
0c30: 65 2d 3e 63 20 74 79 70 65 29 0a 20 20 20 20 20 e->c type).
0c40: 20 74 79 70 65 29 0a 20 20 20 20 28 64 65 66 69 type). (defi
0c50: 6e 65 20 28 63 6f 6e 76 65 72 74 2d 73 63 68 65 ne (convert-sche
0c60: 6d 65 2d 3e 63 20 6e 61 6d 65 20 74 79 70 65 29 me->c name type)
0c70: 0a 20 20 20 20 20 20 6e 61 6d 65 29 0a 20 20 20 . name).
0c80: 20 28 73 79 6e 74 61 78 2d 63 61 73 65 20 78 20 (syntax-case x
0c90: 28 29 0a 20 20 20 20 20 20 5b 28 5f 20 6e 61 6d (). [(_ nam
0ca0: 65 20 28 28 61 72 67 2d 6e 61 6d 65 20 61 72 67 e ((arg-name arg
0cb0: 2d 74 79 70 65 29 20 2e 2e 2e 29 20 72 65 74 2d -type) ...) ret-
0cc0: 74 79 70 65 29 20 0a 20 20 20 20 20 20 20 28 77 type) . (w
0cd0: 69 74 68 2d 73 79 6e 74 61 78 20 28 5b 6e 61 6d ith-syntax ([nam
0ce0: 65 2f 73 74 72 69 6e 67 20 28 73 79 6d 62 6f 6c e/string (symbol
0cf0: 2d 3e 73 74 72 69 6e 67 20 28 73 79 6e 74 61 78 ->string (syntax
0d00: 2d 3e 64 61 74 75 6d 20 23 27 6e 61 6d 65 29 29 ->datum #'name))
0d10: 5d 0a 09 09 20 20 20 20 20 5b 28 72 65 6e 61 6d ]... [(renam
0d20: 65 64 2d 74 79 70 65 20 2e 2e 2e 29 20 28 6d 61 ed-type ...) (ma
0d30: 70 20 72 65 6e 61 6d 65 2d 73 63 68 65 6d 65 2d p rename-scheme-
0d40: 3e 63 20 23 27 28 61 72 67 2d 74 79 70 65 20 2e >c #'(arg-type .
0d50: 2e 2e 29 29 5d 0a 09 09 20 20 20 20 20 5b 72 65 ..))]... [re
0d60: 6e 61 6d 65 64 2d 72 65 74 20 23 27 72 65 74 2d named-ret #'ret-
0d70: 74 79 70 65 5d 0a 09 09 20 20 20 20 20 5b 28 28 type]... [((
0d80: 61 72 67 2d 6e 61 6d 65 20 61 72 67 2d 63 6f 6e arg-name arg-con
0d90: 76 65 72 74 29 20 2e 2e 2e 29 20 28 6d 61 70 20 vert) ...) (map
0da0: 28 6c 61 6d 62 64 61 20 28 6e 20 74 29 20 0a 09 (lambda (n t) ..
0db0: 09 09 09 09 09 09 20 20 28 6c 69 73 74 20 6e 20 ...... (list n
0dc0: 28 63 6f 6e 76 65 72 74 2d 73 63 68 65 6d 65 2d (convert-scheme-
0dd0: 3e 63 20 6e 20 74 29 29 29 20 0a 09 09 09 09 09 >c n t))) ......
0de0: 09 09 23 27 28 61 72 67 2d 6e 61 6d 65 20 2e 2e ..#'(arg-name ..
0df0: 2e 29 20 23 27 28 61 72 67 2d 74 79 70 65 20 2e .) #'(arg-type .
0e00: 2e 2e 29 29 5d 29 0a 09 09 20 20 20 20 23 60 28 ..))])... #`(
0e10: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 28 begin... (
0e20: 64 65 66 69 6e 65 20 28 6e 61 6d 65 20 61 72 67 define (name arg
0e30: 2d 6e 61 6d 65 20 2e 2e 2e 29 20 0a 09 09 09 20 -name ...) ....
0e40: 28 6c 65 74 20 28 5b 70 20 28 66 6f 72 65 69 67 (let ([p (foreig
0e50: 6e 2d 70 72 6f 63 65 64 75 72 65 20 6e 61 6d 65 n-procedure name
0e60: 2f 73 74 72 69 6e 67 20 28 72 65 6e 61 6d 65 64 /string (renamed
0e70: 2d 74 79 70 65 20 2e 2e 2e 29 20 72 65 6e 61 6d -type ...) renam
0e80: 65 64 2d 72 65 74 29 5d 0a 09 09 09 20 20 20 20 ed-ret)]....
0e90: 20 20 20 5b 61 72 67 2d 6e 61 6d 65 20 61 72 67 [arg-name arg
0ea0: 2d 63 6f 6e 76 65 72 74 5d 20 2e 2e 2e 29 0a 09 -convert] ...)..
0eb0: 09 09 20 20 20 28 70 20 61 72 67 2d 6e 61 6d 65 .. (p arg-name
0ec0: 20 2e 2e 2e 29 29 29 29 29 5d 29 29 29 0a 0a 3b ...)))))])))..;
0ed0: 28 73 63 2d 65 78 70 61 6e 64 20 27 28 64 65 66 (sc-expand '(def
0ee0: 69 6e 65 2d 66 75 6e 63 74 69 6f 6e 20 6d 65 6d ine-function mem
0ef0: 63 70 79 20 28 28 64 65 73 74 20 76 6f 69 64 2a cpy ((dest void*
0f00: 29 20 28 66 72 6f 6d 20 76 6f 69 64 2a 29 20 28 ) (from void*) (
0f10: 6e 20 69 6e 74 29 29 20 76 6f 69 64 2a 29 29 0a n int)) void*)).
0f20: 0a 3b 44 45 46 49 4e 45 20 46 4c 41 47 53 3a 0a .;DEFINE FLAGS:.
0f30: 3b 55 53 41 47 45 3a 20 28 64 65 66 69 6e 65 2d ;USAGE: (define-
0f40: 66 6c 61 67 73 20 66 6c 61 67 73 2d 6e 61 6d 65 flags flags-name
0f50: 20 28 6e 61 6d 65 20 76 61 6c 75 65 29 20 2e 2e (name value) ..
0f60: 2e 29 0a 3b 20 6e 61 6d 65 20 77 69 6c 6c 20 62 .).; name will b
0f70: 65 20 65 73 63 61 70 65 64 0a 3b 20 76 61 6c 75 e escaped.; valu
0f80: 65 20 77 69 6c 6c 20 62 65 20 65 76 61 6c 75 61 e will be evalua
0f90: 74 65 64 0a 3b 20 74 68 65 20 66 6f 6c 6c 6f 77 ted.; the follow
0fa0: 69 6e 67 20 66 75 6e 63 74 69 6f 6e 73 20 77 69 ing functions wi
0fb0: 6c 6c 20 62 65 20 64 65 66 69 6e 65 64 3a 0a 3b ll be defined:.;
0fc0: 20 3c 66 6c 61 67 73 2d 6e 61 6d 65 3e 2d 66 6c <flags-name>-fl
0fd0: 61 67 73 20 20 2d 3e 20 72 65 63 6f 72 64 20 64 ags -> record d
0fe0: 65 73 63 72 69 62 69 6e 67 20 74 68 65 20 66 6c escribing the fl
0ff0: 61 67 73 0a 3b 20 3c 66 6c 61 67 73 2d 6e 61 6d ags.; <flags-nam
1000: 65 3e 20 20 20 20 20 20 2d 3e 20 74 61 6b 65 73 e> -> takes
1010: 20 61 20 6c 69 73 74 20 6f 66 20 66 6c 61 67 73 a list of flags
1020: 20 61 6e 64 20 72 65 74 75 72 6e 73 20 61 20 6e and returns a n
1030: 75 6d 62 65 72 20 74 68 61 74 20 63 6f 72 72 65 umber that corre
1040: 73 70 6f 6e 64 20 0a 3b 20 20 20 20 20 20 20 20 spond .;
1050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 t
1060: 6f 20 74 68 65 20 62 69 74 77 69 73 65 20 6f 72 o the bitwise or
1070: 20 6f 66 20 74 68 65 20 63 6f 72 72 65 73 70 6f of the correspo
1080: 6e 64 69 6e 67 20 76 61 6c 75 65 73 0a 3b 20 3c nding values.; <
1090: 66 6c 61 67 73 2d 6e 61 6d 65 3e 2d 72 65 66 20 flags-name>-ref
10a0: 20 2d 3e 20 74 61 6b 65 73 20 61 20 6e 75 6d 62 -> takes a numb
10b0: 65 72 20 61 73 20 61 72 67 75 6d 65 6e 74 20 61 er as argument a
10c0: 6e 64 20 72 65 74 75 72 6e 73 20 74 68 65 20 66 nd returns the f
10d0: 6c 61 67 20 6e 61 6d 65 0a 3b 20 3c 66 6c 61 67 lag name.; <flag
10e0: 73 2d 6e 61 6d 65 3e 2d 64 65 63 6f 64 65 20 2d s-name>-decode -
10f0: 3e 20 74 61 6b 65 73 20 61 20 6e 75 6d 62 65 72 > takes a number
1100: 20 61 6e 64 20 72 65 74 75 72 6e 73 20 61 20 6c and returns a l
1110: 69 73 74 20 6f 66 20 66 6c 61 67 73 20 74 68 61 ist of flags tha
1120: 74 20 6d 61 74 63 68 20 74 6f 20 63 72 65 61 74 t match to creat
1130: 65 20 74 68 61 74 20 76 61 6c 75 65 0a 3b 20 79 e that value.; y
1140: 6f 75 20 63 61 6e 20 75 73 65 20 61 6c 73 6f 20 ou can use also
1150: 28 66 6c 61 67 73 2d 61 6c 69 73 74 20 3c 66 6c (flags-alist <fl
1160: 61 67 73 2d 6e 61 6d 65 3e 2d 66 6c 61 67 73 29 ags-name>-flags)
1170: 20 74 6f 20 67 65 74 20 74 68 65 20 61 6c 69 73 to get the alis
1180: 74 20 6f 66 20 66 6c 61 67 73 0a 3b 20 61 6e 64 t of flags.; and
1190: 20 28 66 6c 61 67 73 2d 6e 61 6d 65 20 3c 66 6c (flags-name <fl
11a0: 61 67 73 2d 6e 61 6d 65 3e 2d 66 6c 61 67 73 29 ags-name>-flags)
11b0: 20 74 6f 20 67 65 74 20 74 68 65 20 6e 61 6d 65 to get the name
11c0: 0a 0a 3b 45 58 41 4d 50 4c 45 3a 20 28 64 65 66 ..;EXAMPLE: (def
11d0: 69 6e 65 2d 66 6c 61 67 73 20 63 6f 6c 6f 72 73 ine-flags colors
11e0: 20 28 72 65 64 20 31 29 20 28 62 6c 75 65 20 32 (red 1) (blue 2
11f0: 29 20 28 67 72 65 65 6e 20 34 29 29 0a 3b 3e 20 ) (green 4)).;>
1200: 63 6f 6c 6f 72 2d 66 6c 61 67 73 20 2d 3e 20 23 color-flags -> #
1210: 5b 23 7b 66 6c 61 67 73 20 65 77 37 39 65 78 61 [#{flags ew79exa
1220: 30 71 35 71 69 32 33 6a 39 6b 31 66 61 61 38 2d 0q5qi23j9k1faa8-
1230: 35 31 7d 20 63 6f 6c 6f 72 20 28 28 72 65 64 20 51} color ((red
1240: 2e 20 31 29 20 28 62 6c 75 65 20 2e 20 32 29 20 . 1) (blue . 2)
1250: 28 67 72 65 65 6e 20 2e 20 34 29 29 5d 0a 3b 3e (green . 4))].;>
1260: 20 28 63 6f 6c 6f 72 20 27 62 6c 75 65 29 20 2d (color 'blue) -
1270: 3e 20 32 0a 3b 3e 20 28 63 6f 6c 6f 72 20 27 72 > 2.;> (color 'r
1280: 65 64 20 27 62 6c 75 65 29 20 2d 3e 20 33 0a 3b ed 'blue) -> 3.;
1290: 3e 20 28 63 6f 6c 6f 72 20 27 62 6c 61 63 6b 29 > (color 'black)
12a0: 20 2d 3e 20 45 78 63 65 70 74 69 6f 6e 20 69 6e -> Exception in
12b0: 20 63 6f 6c 6f 72 3a 20 73 79 6d 62 6f 6c 20 6e color: symbol n
12c0: 6f 74 20 66 6f 75 6e 64 20 77 69 74 68 20 69 72 ot found with ir
12d0: 72 69 74 61 6e 74 20 28 62 6c 61 63 6b 29 0a 3b ritant (black).;
12e0: 3e 20 28 63 6f 6c 6f 72 2d 72 65 66 20 31 29 20 > (color-ref 1)
12f0: 2d 3e 20 72 65 64 0a 3b 3e 20 28 63 6f 6c 6f 72 -> red.;> (color
1300: 2d 72 65 66 20 35 29 20 2d 3e 20 23 66 0a 3b 3e -ref 5) -> #f.;>
1310: 20 28 63 6f 6c 6f 72 2d 64 65 63 6f 64 65 20 33 (color-decode 3
1320: 29 20 2d 3e 20 28 72 65 64 20 62 6c 75 65 29 0a ) -> (red blue).
1330: 3b 3e 20 28 63 6f 6c 6f 72 2d 64 65 63 6f 64 65 ;> (color-decode
1340: 20 31 36 29 20 2d 3e 20 28 29 0a 3b 3e 20 28 63 16) -> ().;> (c
1350: 6f 6c 6f 72 2d 64 65 63 6f 64 65 20 36 29 20 2d olor-decode 6) -
1360: 3e 20 28 62 6c 75 65 20 67 72 65 65 6e 29 20 21 > (blue green) !
1370: 21 21 20 41 54 54 45 4e 54 49 4f 4e 20 73 68 6f !! ATTENTION sho
1380: 75 6c 64 20 72 61 69 73 65 20 65 78 63 65 70 74 uld raise except
1390: 69 6f 6e 3f 0a 3b 3e 20 28 66 6c 61 67 73 2d 61 ion?.;> (flags-a
13a0: 6c 69 73 74 20 63 6f 6c 6f 72 2d 66 6c 61 67 73 list color-flags
13b0: 29 20 2d 3e 20 28 28 72 65 64 20 2e 20 31 29 20 ) -> ((red . 1)
13c0: 28 62 6c 75 65 20 2e 20 32 29 20 28 67 72 65 65 (blue . 2) (gree
13d0: 6e 20 2e 20 34 29 29 0a 3b 3e 20 28 66 6c 61 67 n . 4)).;> (flag
13e0: 73 2d 6e 61 6d 65 20 63 6f 6c 6f 72 2d 66 6c 61 s-name color-fla
13f0: 67 73 29 20 2d 3e 20 63 6f 6c 6f 72 0a 0a 3b 3b gs) -> color..;;
1400: 20 54 4f 44 4f 2c 20 77 68 61 74 20 74 6f 20 64 TODO, what to d
1410: 6f 20 66 6f 72 20 76 61 6c 75 65 20 30 3f 0a 0a o for value 0?..
1420: 20 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 20 (define-record
1430: 66 6c 61 67 73 20 28 6e 61 6d 65 20 61 6c 69 73 flags (name alis
1440: 74 29 29 0a 20 0a 20 28 64 65 66 69 6e 65 20 28 t)). . (define (
1450: 66 6c 61 67 73 2d 69 6e 64 65 78 65 72 20 20 66 flags-indexer f
1460: 6c 61 67 73 29 0a 20 20 28 6c 61 6d 62 64 61 20 lags). (lambda
1470: 6e 61 6d 65 73 0a 20 20 20 20 28 6c 65 74 20 6c names. (let l
1480: 6f 6f 70 20 28 5b 66 20 6e 61 6d 65 73 5d 20 5b oop ([f names] [
1490: 72 65 73 75 6c 74 20 30 5d 29 0a 20 20 20 20 20 result 0]).
14a0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 29 20 72 (if (null? f) r
14b0: 65 73 75 6c 74 0a 09 20 20 28 6c 65 74 20 28 5b esult.. (let ([
14c0: 72 20 28 61 73 73 71 20 28 63 61 72 20 66 29 20 r (assq (car f)
14d0: 28 66 6c 61 67 73 2d 61 6c 69 73 74 20 66 6c 61 (flags-alist fla
14e0: 67 73 29 29 5d 29 0a 09 20 20 20 20 28 69 66 20 gs))]).. (if
14f0: 28 6e 6f 74 20 72 29 20 28 61 73 73 65 72 74 69 (not r) (asserti
1500: 6f 6e 2d 76 69 6f 6c 61 74 69 6f 6e 20 28 66 6c on-violation (fl
1510: 61 67 73 2d 6e 61 6d 65 20 66 6c 61 67 73 29 20 ags-name flags)
1520: 22 73 79 6d 62 6f 6c 20 6e 6f 74 20 66 6f 75 6e "symbol not foun
1530: 64 22 20 66 29 0a 09 09 28 6c 6f 6f 70 20 28 63 d" f)...(loop (c
1540: 64 72 20 66 29 20 28 6c 6f 67 6f 72 20 72 65 73 dr f) (logor res
1550: 75 6c 74 20 28 63 64 72 20 72 29 29 29 29 29 29 ult (cdr r))))))
1560: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6c )))..(define (fl
1570: 61 67 73 2d 72 65 66 2d 6d 61 6b 65 72 20 66 6c ags-ref-maker fl
1580: 61 67 73 29 0a 20 20 20 28 6c 61 6d 62 64 61 20 ags). (lambda
1590: 28 69 6e 64 65 78 29 0a 20 20 20 20 20 28 6c 65 (index). (le
15a0: 74 20 28 5b 70 20 28 66 69 6e 64 20 28 6c 61 6d t ([p (find (lam
15b0: 62 64 61 20 28 78 29 20 28 65 71 75 61 6c 3f 20 bda (x) (equal?
15c0: 69 6e 64 65 78 20 28 63 64 72 20 78 29 29 29 20 index (cdr x)))
15d0: 28 66 6c 61 67 73 2d 61 6c 69 73 74 20 66 6c 61 (flags-alist fla
15e0: 67 73 29 29 5d 29 0a 20 20 20 20 20 20 20 28 69 gs))]). (i
15f0: 66 20 70 20 28 63 61 72 20 70 29 20 70 29 29 29 f p (car p) p)))
1600: 29 0a 0a 3b 3b 20 46 49 58 4d 45 3a 20 57 48 41 )..;; FIXME: WHA
1610: 54 20 54 4f 20 44 4f 20 49 46 20 56 41 4c 55 45 T TO DO IF VALUE
1620: 53 20 4f 56 45 52 4c 41 50 3f 0a 3b 3b 20 41 54 S OVERLAP?.;; AT
1630: 20 54 48 45 20 4d 4f 4d 45 4e 54 20 52 45 53 55 THE MOMENT RESU
1640: 4c 54 20 4d 41 59 42 45 20 4e 4f 54 20 57 48 41 LT MAYBE NOT WHA
1650: 54 20 45 58 50 45 43 54 45 44 0a 20 28 64 65 66 T EXPECTED. (def
1660: 69 6e 65 20 28 66 6c 61 67 73 2d 64 65 63 6f 64 ine (flags-decod
1670: 65 2d 6d 61 6b 65 72 20 66 6c 61 67 73 29 0a 20 e-maker flags).
1680: 20 20 28 6c 61 6d 62 64 61 20 28 6d 61 73 6b 29 (lambda (mask)
1690: 0a 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 . (if (not (
16a0: 6e 75 6d 62 65 72 3f 20 6d 61 73 6b 29 29 20 28 number? mask)) (
16b0: 61 73 73 65 72 74 69 6f 6e 2d 76 69 6f 6c 61 74 assertion-violat
16c0: 69 6f 6e 20 28 66 6c 61 67 73 2d 6e 61 6d 65 20 ion (flags-name
16d0: 66 6c 61 67 73 29 20 22 64 65 63 6f 64 65 3a 20 flags) "decode:
16e0: 6d 61 73 6b 20 6d 75 73 74 20 62 65 20 61 6e 20 mask must be an
16f0: 69 6e 74 65 67 65 72 22 20 6d 61 73 6b 29 29 0a integer" mask)).
1700: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
1710: 5b 6c 20 28 66 6c 61 67 73 2d 61 6c 69 73 74 20 [l (flags-alist
1720: 66 6c 61 67 73 29 5d 20 5b 72 65 73 75 6c 74 20 flags)] [result
1730: 27 28 29 5d 29 0a 20 20 20 20 20 20 20 28 69 66 '()]). (if
1740: 20 28 6e 75 6c 6c 3f 20 6c 29 20 72 65 73 75 6c (null? l) resul
1750: 74 0a 09 20 20 20 28 6c 65 74 20 28 5b 69 74 65 t.. (let ([ite
1760: 6d 20 28 63 61 72 20 6c 29 5d 29 0a 09 20 20 20 m (car l)])..
1770: 20 20 28 69 66 20 28 7a 65 72 6f 3f 20 28 6c 6f (if (zero? (lo
1780: 67 61 6e 64 20 28 63 64 72 20 69 74 65 6d 29 20 gand (cdr item)
1790: 6d 61 73 6b 29 29 0a 09 09 20 28 6c 6f 6f 70 20 mask))... (loop
17a0: 28 63 64 72 20 6c 29 20 72 65 73 75 6c 74 29 0a (cdr l) result).
17b0: 09 09 20 28 6c 6f 6f 70 20 28 63 64 72 20 6c 29 .. (loop (cdr l)
17c0: 20 28 61 70 70 65 6e 64 20 72 65 73 75 6c 74 20 (append result
17d0: 28 6c 69 73 74 20 28 63 61 72 20 69 74 65 6d 29 (list (car item)
17e0: 29 29 29 29 29 29 29 29 29 0a 20 0a 20 28 64 65 ))))))))). . (de
17f0: 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 66 69 fine-syntax defi
1800: 6e 65 2d 66 6c 61 67 73 0a 20 20 20 28 6c 61 6d ne-flags. (lam
1810: 62 64 61 20 28 78 29 0a 20 20 20 20 20 28 64 65 bda (x). (de
1820: 66 69 6e 65 20 67 65 6e 2d 69 64 0a 20 20 20 20 fine gen-id.
1830: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 6d 70 (lambda (temp
1840: 6c 61 74 65 2d 69 64 20 2e 20 61 72 67 73 29 0a late-id . args).
1850: 09 20 28 64 61 74 75 6d 2d 3e 73 79 6e 74 61 78 . (datum->syntax
1860: 0a 09 20 20 74 65 6d 70 6c 61 74 65 2d 69 64 0a .. template-id.
1870: 09 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 . (string->symb
1880: 6f 6c 0a 09 20 20 20 28 61 70 70 6c 79 0a 09 20 ol.. (apply..
1890: 20 20 20 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 string-append
18a0: 0a 09 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 .. (map (lamb
18b0: 64 61 20 28 78 29 0a 09 09 20 20 20 28 69 66 20 da (x)... (if
18c0: 28 73 74 72 69 6e 67 3f 20 78 29 20 78 20 28 73 (string? x) x (s
18d0: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 28 73 ymbol->string (s
18e0: 79 6e 74 61 78 2d 3e 64 61 74 75 6d 20 78 29 29 yntax->datum x))
18f0: 29 29 0a 09 09 20 61 72 67 73 29 29 29 29 29 29 ))... args))))))
1900: 0a 20 20 20 20 20 28 73 79 6e 74 61 78 2d 63 61 . (syntax-ca
1910: 73 65 20 78 20 28 29 0a 20 20 20 20 20 20 20 5b se x (). [
1920: 28 6b 61 20 6e 61 6d 65 20 28 6b 20 20 76 29 20 (ka name (k v)
1930: 2e 2e 2e 29 0a 09 23 27 28 6b 61 20 6e 61 6d 65 ...)..#'(ka name
1940: 20 69 6e 74 20 28 6b 20 76 29 20 2e 2e 2e 29 5d int (k v) ...)]
1950: 20 0a 20 20 20 20 20 20 20 5b 28 79 20 6e 61 6d . [(y nam
1960: 65 20 74 79 70 65 20 28 6b 20 20 76 29 20 2e 2e e type (k v) ..
1970: 2e 29 0a 09 28 77 69 74 68 2d 73 79 6e 74 61 78 .)..(with-syntax
1980: 20 28 5b 62 61 73 65 2d 6e 61 6d 65 20 28 67 65 ([base-name (ge
1990: 6e 2d 69 64 20 23 27 79 20 22 22 20 23 27 6e 61 n-id #'y "" #'na
19a0: 6d 65 29 5d 0a 09 09 20 20 20 20 20 20 5b 66 6c me)]... [fl
19b0: 61 67 73 2d 6e 61 6d 65 20 28 67 65 6e 2d 69 64 ags-name (gen-id
19c0: 20 23 27 79 20 23 27 6e 61 6d 65 20 22 2d 66 6c #'y #'name "-fl
19d0: 61 67 73 22 29 5d 0a 09 09 20 20 20 20 20 20 5b ags")]... [
19e0: 72 65 66 2d 6e 61 6d 65 20 28 67 65 6e 2d 69 64 ref-name (gen-id
19f0: 20 23 27 79 20 23 27 6e 61 6d 65 20 22 2d 72 65 #'y #'name "-re
1a00: 66 22 29 5d 0a 09 09 20 20 20 20 20 20 5b 64 65 f")]... [de
1a10: 63 6f 64 65 2d 6e 61 6d 65 20 28 67 65 6e 2d 69 code-name (gen-i
1a20: 64 20 23 27 79 20 23 27 6e 61 6d 65 20 22 2d 64 d #'y #'name "-d
1a30: 65 63 6f 64 65 22 29 5d 0a 09 09 20 20 20 20 20 ecode")]...
1a40: 20 5b 6e 61 6d 65 2d 74 20 28 67 65 6e 2d 69 64 [name-t (gen-id
1a50: 20 23 27 79 20 23 27 6e 61 6d 65 20 22 2d 74 22 #'y #'name "-t"
1a60: 29 5d 0a 09 09 20 20 20 20 20 20 23 3b 5b 28 76 )]... #;[(v
1a70: 31 20 2e 2e 2e 29 20 28 6d 61 70 20 28 6c 61 6d 1 ...) (map (lam
1a80: 62 64 61 20 28 76 29 20 20 0a 09 09 09 09 09 20 bda (v) ......
1a90: 20 28 69 66 20 28 63 68 61 72 3f 20 28 64 61 74 (if (char? (dat
1aa0: 75 6d 20 76 29 29 0a 09 09 09 09 09 20 20 20 20 um v))......
1ab0: 20 20 20 28 64 61 74 75 6d 2d 3e 73 79 6e 74 61 (datum->synta
1ac0: 78 20 23 27 76 20 28 63 68 61 72 2d 3e 69 6e 74 x #'v (char->int
1ad0: 65 67 65 72 20 28 64 61 74 75 6d 20 76 29 29 29 eger (datum v)))
1ae0: 0a 09 09 09 09 09 20 20 20 20 20 20 76 29 29 0a ...... v)).
1af0: 09 09 09 09 20 20 20 20 20 20 20 20 23 27 28 76 .... #'(v
1b00: 20 2e 2e 2e 29 20 29 5d 29 0a 09 09 20 20 20 20 ...) )])...
1b10: 20 0a 09 09 20 20 20 20 20 28 69 6e 64 69 72 65 ... (indire
1b20: 63 74 2d 65 78 70 6f 72 74 20 66 6c 61 67 73 2d ct-export flags-
1b30: 69 6e 64 65 78 65 72 20 66 6c 61 67 73 2d 72 65 indexer flags-re
1b40: 66 2d 6d 61 6b 65 72 20 66 6c 61 67 73 2d 64 65 f-maker flags-de
1b50: 63 6f 64 65 2d 6d 61 6b 65 72 29 0a 09 09 20 20 code-maker)...
1b60: 20 20 20 23 60 28 62 65 67 69 6e 20 0a 09 09 3b #`(begin ...;
1b70: 09 20 28 69 6d 70 6f 72 74 20 28 66 66 69 2d 75 . (import (ffi-u
1b80: 74 69 6c 73 29 29 0a 09 09 09 20 28 64 65 66 69 tils)).... (defi
1b90: 6e 65 20 66 6c 61 67 73 2d 6e 61 6d 65 20 28 6d ne flags-name (m
1ba0: 61 6b 65 2d 66 6c 61 67 73 20 27 6e 61 6d 65 20 ake-flags 'name
1bb0: 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 6b 20 76 (list (cons 'k v
1bc0: 29 20 2e 2e 2e 29 29 29 0a 09 09 09 20 28 64 65 ) ...))).... (de
1bd0: 66 69 6e 65 20 62 61 73 65 2d 6e 61 6d 65 20 28 fine base-name (
1be0: 66 6c 61 67 73 2d 69 6e 64 65 78 65 72 20 66 6c flags-indexer fl
1bf0: 61 67 73 2d 6e 61 6d 65 29 29 0a 09 09 09 20 28 ags-name)).... (
1c00: 64 65 66 69 6e 65 20 72 65 66 2d 6e 61 6d 65 20 define ref-name
1c10: 28 66 6c 61 67 73 2d 72 65 66 2d 6d 61 6b 65 72 (flags-ref-maker
1c20: 20 66 6c 61 67 73 2d 6e 61 6d 65 29 29 0a 09 09 flags-name))...
1c30: 09 20 28 64 65 66 69 6e 65 20 64 65 63 6f 64 65 . (define decode
1c40: 2d 6e 61 6d 65 20 28 66 6c 61 67 73 2d 64 65 63 -name (flags-dec
1c50: 6f 64 65 2d 6d 61 6b 65 72 20 66 6c 61 67 73 2d ode-maker flags-
1c60: 6e 61 6d 65 29 29 0a 09 09 09 20 28 64 65 66 69 name)).... (defi
1c70: 6e 65 2d 66 74 79 70 65 20 6e 61 6d 65 2d 74 20 ne-ftype name-t
1c80: 74 79 70 65 29 0a 09 09 09 20 3b 28 69 6e 64 69 type).... ;(indi
1c90: 72 65 63 74 2d 65 78 70 6f 72 74 20 62 61 73 65 rect-export base
1ca0: 2d 6e 61 6d 65 20 66 6c 61 67 73 2d 6e 61 6d 65 -name flags-name
1cb0: 20 72 65 66 2d 6e 61 6d 65 20 64 65 63 6f 64 65 ref-name decode
1cc0: 2d 6e 61 6d 65 20 6e 61 6d 65 2d 74 20 29 0a 09 -name name-t )..
1cd0: 09 09 20 29 29 5d 29 29 29 0a 0a 0a 0a 20 28 64 .. ))]))).... (d
1ce0: 65 66 69 6e 65 20 28 63 68 61 72 2a 2d 3e 62 79 efine (char*->by
1cf0: 74 65 76 65 63 74 6f 72 20 66 70 74 72 20 62 79 tevector fptr by
1d00: 74 65 73 29 0a 20 20 20 28 64 65 66 69 6e 65 20 tes). (define
1d10: 62 62 20 28 6d 61 6b 65 2d 62 79 74 65 76 65 63 bb (make-bytevec
1d20: 74 6f 72 20 62 79 74 65 73 29 29 0a 20 20 20 28 tor bytes)). (
1d30: 6c 65 74 20 66 20 28 5b 69 20 30 5d 29 0a 20 20 let f ([i 0]).
1d40: 20 20 20 28 69 66 20 28 3c 20 69 20 20 62 79 74 (if (< i byt
1d50: 65 73 29 0a 09 20 28 6c 65 74 20 28 5b 63 20 28 es).. (let ([c (
1d60: 66 74 79 70 65 2d 72 65 66 20 63 68 61 72 20 28 ftype-ref char (
1d70: 29 20 66 70 74 72 20 69 29 5d 29 0a 09 20 20 20 ) fptr i)])..
1d80: 28 62 79 74 65 76 65 63 74 6f 72 2d 75 38 2d 73 (bytevector-u8-s
1d90: 65 74 21 20 62 62 20 69 20 28 63 68 61 72 2d 3e et! bb i (char->
1da0: 69 6e 74 65 67 65 72 20 63 29 29 0a 09 20 20 20 integer c))..
1db0: 28 66 20 28 66 78 2b 20 69 20 31 29 29 29 29 29 (f (fx+ i 1)))))
1dc0: 0a 20 20 20 62 62 29 0a 0a 0a 20 28 64 65 66 69 . bb)... (defi
1dd0: 6e 65 2d 73 79 6e 74 61 78 20 63 61 73 74 0a 20 ne-syntax cast.
1de0: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
1df0: 28 29 0a 20 20 20 20 20 5b 28 5f 20 66 74 79 70 (). [(_ ftyp
1e00: 65 20 66 70 74 72 29 0a 20 20 20 20 20 20 28 6d e fptr). (m
1e10: 61 6b 65 2d 66 74 79 70 65 2d 70 6f 69 6e 74 65 ake-ftype-pointe
1e20: 72 20 66 74 79 70 65 0a 09 09 09 20 20 28 66 74 r ftype.... (ft
1e30: 79 70 65 2d 70 6f 69 6e 74 65 72 2d 61 64 64 72 ype-pointer-addr
1e40: 65 73 73 20 66 70 74 72 29 29 5d 29 29 0a 0a 0a ess fptr))]))...
1e50: 20 29 3b 20 6c 69 62 72 61 72 79 20 66 66 69 2d ); library ffi-
1e60: 75 74 69 6c 73 0a utils.