Artifact bb8d60127e0fea6f528bfd1bcc23d7c06a0f4818:
- File thunder-utils.sls — part of check-in [2b9e9a2608] at 2018-12-09 15:23:10 on branch trunk — added keyword and optional syntax for lambda and define (user: aldo size: 7847)
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 6c 69 62 72 61 72 79 20 ense...(library 0260: 28 74 68 75 6e 64 65 72 2d 75 74 69 6c 73 29 0a (thunder-utils). 0270: 20 20 28 65 78 70 6f 72 74 20 73 74 72 69 6e 67 (export string 0280: 2d 73 70 6c 69 74 20 73 74 72 69 6e 67 2d 72 65 -split string-re 0290: 70 6c 61 63 65 20 62 79 74 65 76 65 63 74 6f 72 place bytevector 02a0: 2d 63 6f 70 79 2a 20 72 65 61 64 2d 73 74 72 69 -copy* read-stri 02b0: 6e 67 0a 09 20 20 70 72 69 6e 74 2d 73 74 61 63 ng.. print-stac 02c0: 6b 2d 74 72 61 63 65 0a 09 20 20 73 75 62 2d 62 k-trace.. sub-b 02d0: 79 74 65 76 65 63 74 6f 72 20 20 73 75 62 2d 62 ytevector sub-b 02e0: 79 74 65 76 65 63 74 6f 72 3d 3f 0a 09 20 20 6c ytevector=?.. l 02f0: 6f 61 64 2d 62 79 74 65 76 65 63 74 6f 72 20 73 oad-bytevector s 0300: 61 76 65 2d 62 79 74 65 76 65 63 74 6f 72 0a 09 ave-bytevector.. 0310: 20 20 64 65 66 69 6e 65 2f 6f 70 74 69 6f 6e 61 define/optiona 0320: 6c 20 6c 61 6d 62 64 61 2f 6f 70 74 69 6f 6e 61 l lambda/optiona 0330: 6c 20 2f 6f 70 74 69 6f 6e 61 6c 0a 09 20 20 64 l /optional.. d 0340: 65 66 69 6e 65 2f 6b 65 79 73 20 6c 61 6d 62 64 efine/keys lambd 0350: 61 2f 6b 65 79 73 20 2f 6b 65 79 73 20 64 65 63 a/keys /keys dec 0360: 6f 64 65 2d 6b 65 79 73 29 0a 20 20 0a 20 20 28 ode-keys). . ( 0370: 69 6d 70 6f 72 74 20 28 73 63 68 65 6d 65 29 20 import (scheme) 0380: 28 73 72 66 69 20 73 31 34 20 63 68 61 72 2d 73 (srfi s14 char-s 0390: 65 74 73 29 0a 09 20 20 28 6f 6e 6c 79 20 28 73 ets).. (only (s 03a0: 72 66 69 20 73 31 20 6c 69 73 74 73 29 20 74 61 rfi s1 lists) ta 03b0: 6b 65 20 64 72 6f 70 29 0a 09 20 20 28 73 72 66 ke drop).. (srf 03c0: 69 20 70 72 69 76 61 74 65 20 61 75 78 69 6c 69 i private auxili 03d0: 61 72 79 2d 6b 65 79 77 6f 72 64 29 29 0a 0a 20 ary-keyword)).. 03e0: 20 3b 3b 20 73 20 69 73 20 61 20 73 74 72 69 6e ;; s is a strin 03f0: 67 20 2c 20 63 20 69 73 20 61 20 63 68 61 72 61 g , c is a chara 0400: 63 74 65 72 2d 73 65 74 20 6f 72 20 61 20 6c 69 cter-set or a li 0410: 73 74 20 6f 66 20 63 68 61 72 73 0a 20 20 3b 3b st of chars. ;; 0420: 20 6e 75 6c 6c 20 73 74 72 69 6e 67 73 20 61 72 null strings ar 0430: 65 20 64 69 73 63 61 72 64 65 64 20 66 72 6f 6d e discarded from 0440: 20 72 65 73 75 6c 74 20 62 79 20 64 65 66 61 75 result by defau 0450: 6c 74 20 75 6e 6c 65 73 73 20 23 66 20 69 73 20 lt unless #f is 0460: 73 70 65 63 69 66 69 65 64 20 61 73 20 74 68 69 specified as thi 0470: 72 64 20 61 72 67 75 6d 65 6e 74 0a 20 20 28 64 rd argument. (d 0480: 65 66 69 6e 65 20 73 74 72 69 6e 67 2d 73 70 6c efine string-spl 0490: 69 74 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d it. (case-lam 04a0: 62 64 61 0a 20 20 20 20 20 5b 28 73 20 63 29 0a bda. [(s c). 04b0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 (string-sp 04c0: 6c 69 74 20 73 20 63 20 23 74 29 5d 0a 20 20 20 lit s c #t)]. 04d0: 20 20 5b 28 73 20 63 20 64 69 73 63 61 72 64 2d [(s c discard- 04e0: 6e 75 6c 6c 3f 29 0a 20 20 20 20 20 20 28 64 65 null?). (de 04f0: 66 69 6e 65 20 72 65 73 20 27 28 29 29 0a 20 20 fine res '()). 0500: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 5b (let loop ([ 0510: 6c 20 28 73 74 72 69 6e 67 2d 3e 6c 69 73 74 20 l (string->list 0520: 73 29 5d 20 5b 74 20 27 28 29 5d 29 0a 09 28 69 s)] [t '()])..(i 0530: 66 20 28 6e 75 6c 6c 3f 20 6c 29 20 0a 09 20 20 f (null? l) .. 0540: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c (if (and (null 0550: 3f 20 74 29 20 64 69 73 63 61 72 64 2d 6e 75 6c ? t) discard-nul 0560: 6c 3f 29 0a 09 09 72 65 73 20 28 61 70 70 65 6e l?)...res (appen 0570: 64 20 72 65 73 20 28 6c 69 73 74 20 28 6c 69 73 d res (list (lis 0580: 74 2d 3e 73 74 72 69 6e 67 20 74 29 29 29 29 0a t->string t)))). 0590: 09 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e . (if (or (an 05a0: 64 20 28 63 68 61 72 2d 73 65 74 3f 20 63 29 20 d (char-set? c) 05b0: 28 63 68 61 72 2d 73 65 74 2d 63 6f 6e 74 61 69 (char-set-contai 05c0: 6e 73 3f 20 63 20 28 63 61 72 20 6c 29 29 29 0a ns? c (car l))). 05d0: 09 09 20 20 20 20 28 61 6e 64 20 28 70 61 69 72 .. (and (pair 05e0: 3f 20 63 29 20 28 6d 65 6d 76 20 28 63 61 72 20 ? c) (memv (car 05f0: 6c 29 20 63 29 29 29 0a 09 09 28 62 65 67 69 6e l) c)))...(begin 0600: 20 0a 09 09 20 20 28 75 6e 6c 65 73 73 20 28 61 ... (unless (a 0610: 6e 64 20 28 6e 75 6c 6c 3f 20 74 29 20 64 69 73 nd (null? t) dis 0620: 63 61 72 64 2d 6e 75 6c 6c 3f 29 0a 09 09 09 20 card-null?).... 0630: 20 28 73 65 74 21 20 72 65 73 20 28 61 70 70 65 (set! res (appe 0640: 6e 64 20 72 65 73 20 28 6c 69 73 74 20 28 6c 69 nd res (list (li 0650: 73 74 2d 3e 73 74 72 69 6e 67 20 74 29 29 29 29 st->string t)))) 0660: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 64 72 )... (loop (cdr 0670: 20 6c 29 20 27 28 29 29 29 0a 09 09 28 6c 6f 6f l) '()))...(loo 0680: 70 20 28 63 64 72 20 6c 29 20 28 61 70 70 65 6e p (cdr l) (appen 0690: 64 20 74 20 28 6c 69 73 74 20 28 63 61 72 20 6c d t (list (car l 06a0: 29 29 29 29 29 29 29 5d 29 29 0a 20 20 0a 20 20 )))))))])). . 06b0: 3b 3b 20 50 4f 53 53 49 42 4c 45 20 54 48 41 54 ;; POSSIBLE THAT 06c0: 20 54 48 49 53 20 4e 4f 54 20 45 58 49 53 54 3f THIS NOT EXIST? 06d0: 0a 20 20 3b 3b 20 69 66 20 78 20 69 73 20 61 20 . ;; if x is a 06e0: 63 68 61 72 61 63 74 65 72 3a 20 28 65 71 76 3f character: (eqv? 06f0: 20 20 73 5b 69 5d 20 78 29 20 3d 3e 20 73 5b 69 s[i] x) => s[i 0700: 5d 20 3d 20 79 0a 20 20 3b 3b 20 69 66 20 78 20 ] = y. ;; if x 0710: 69 73 20 61 20 6c 69 73 74 3a 20 20 20 20 20 20 is a list: 0720: 28 6d 65 6d 76 20 73 5b 69 5d 20 78 29 20 3d 3e (memv s[i] x) => 0730: 20 73 5b 69 5d 20 3d 20 79 0a 0a 20 20 28 64 65 s[i] = y.. (de 0740: 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 72 65 70 fine (string-rep 0750: 6c 61 63 65 20 73 20 78 20 79 29 0a 20 20 20 20 lace s x y). 0760: 28 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 20 0a (list->string . 0770: 20 20 20 20 20 28 6c 65 74 20 28 5b 63 6d 70 20 (let ([cmp 0780: 28 69 66 20 28 6c 69 73 74 3f 20 78 29 20 6d 65 (if (list? x) me 0790: 6d 76 20 65 71 76 3f 29 5d 29 0a 20 20 20 20 20 mv eqv?)]). 07a0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda ( 07b0: 7a 29 20 28 69 66 20 28 63 6d 70 20 7a 20 78 29 z) (if (cmp z x) 07c0: 20 79 20 7a 29 29 20 28 73 74 72 69 6e 67 2d 3e y z)) (string-> 07d0: 6c 69 73 74 20 73 29 29 29 29 29 0a 0a 20 20 3b list s))))).. ; 07e0: 3b 20 57 48 59 20 54 48 45 52 45 20 4e 4f 54 20 ; WHY THERE NOT 07f0: 45 58 49 53 54 53 20 42 59 54 45 56 45 43 54 4f EXISTS BYTEVECTO 0800: 52 2d 43 4f 50 59 20 57 49 54 48 20 73 72 63 2d R-COPY WITH src- 0810: 73 74 61 72 74 20 61 6e 64 20 6e 3f 20 46 2a 2a start and n? F** 0820: 2a 20 59 4f 55 0a 20 20 28 64 65 66 69 6e 65 20 * YOU. (define 0830: 62 79 74 65 76 65 63 74 6f 72 2d 63 6f 70 79 2a bytevector-copy* 0840: 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 . (case-lambd 0850: 61 0a 20 20 20 20 20 5b 28 62 76 29 20 28 62 79 a. [(bv) (by 0860: 74 65 76 65 63 74 6f 72 2d 63 6f 70 79 20 62 76 tevector-copy bv 0870: 29 5d 0a 20 20 20 20 20 5b 28 62 76 20 73 74 61 )]. [(bv sta 0880: 72 74 29 0a 20 20 20 20 20 20 28 62 79 74 65 76 rt). (bytev 0890: 65 63 74 6f 72 2d 63 6f 70 79 2a 20 62 76 20 73 ector-copy* bv s 08a0: 74 61 72 74 20 28 2d 20 28 62 79 74 65 76 65 63 tart (- (bytevec 08b0: 74 6f 72 2d 6c 65 6e 67 74 68 20 62 76 29 20 73 tor-length bv) s 08c0: 74 61 72 74 29 29 5d 0a 20 20 20 20 20 5b 28 62 tart))]. [(b 08d0: 76 20 73 74 61 72 74 20 6e 29 0a 20 20 20 20 20 v start n). 08e0: 20 28 6c 65 74 20 28 5b 64 73 74 20 28 6d 61 6b (let ([dst (mak 08f0: 65 2d 62 79 74 65 76 65 63 74 6f 72 20 6e 29 5d e-bytevector n)] 0900: 29 0a 09 28 62 79 74 65 76 65 63 74 6f 72 2d 63 )..(bytevector-c 0910: 6f 70 79 21 20 62 76 20 73 74 61 72 74 20 64 73 opy! bv start ds 0920: 74 20 30 20 6e 29 20 64 73 74 29 5d 29 29 0a 0a t 0 n) dst)])).. 0930: 20 20 28 64 65 66 69 6e 65 20 72 65 61 64 2d 73 (define read-s 0940: 74 72 69 6e 67 0a 20 20 20 20 28 63 61 73 65 2d tring. (case- 0950: 6c 61 6d 62 64 61 0a 20 20 20 20 20 5b 28 29 20 lambda. [() 0960: 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 29 (read-string #f) 0970: 5d 0a 20 20 20 20 20 5b 28 6e 29 20 28 72 65 61 ]. [(n) (rea 0980: 64 2d 73 74 72 69 6e 67 20 6e 20 28 63 75 72 72 d-string n (curr 0990: 65 6e 74 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 ent-input-port)) 09a0: 5d 0a 20 20 20 20 20 5b 28 6e 20 70 6f 72 74 29 ]. [(n port) 09b0: 0a 20 20 20 20 20 20 28 69 66 20 6e 0a 09 20 20 . (if n.. 09c0: 28 67 65 74 2d 73 74 72 69 6e 67 2d 6e 20 70 6f (get-string-n po 09d0: 72 74 20 6e 29 0a 09 20 20 28 67 65 74 2d 73 74 rt n).. (get-st 09e0: 72 69 6e 67 2d 61 6c 6c 20 70 6f 72 74 29 29 5d ring-all port))] 09f0: 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 70 )).. (define (p 0a00: 72 69 6e 74 2d 73 74 61 63 6b 2d 74 72 61 63 65 rint-stack-trace 0a10: 20 64 65 70 74 68 29 0a 20 20 20 20 28 70 72 69 depth). (pri 0a20: 6e 74 66 20 22 73 74 61 63 6b 2d 74 72 61 63 65 ntf "stack-trace 0a30: 3a 5c 6e 22 29 0a 20 20 20 20 28 63 61 6c 6c 2f :\n"). (call/ 0a40: 63 63 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 cc . (lambda 0a50: 20 28 6b 29 0a 20 20 20 20 20 20 20 28 6c 65 74 (k). (let 0a60: 20 6c 6f 6f 70 20 28 28 63 75 72 20 28 69 6e 73 loop ((cur (ins 0a70: 70 65 63 74 2f 6f 62 6a 65 63 74 20 6b 29 29 0a pect/object k)). 0a80: 09 09 20 20 28 69 20 30 29 29 0a 09 20 28 69 66 .. (i 0)).. (if 0a90: 20 28 61 6e 64 20 28 3c 20 69 20 64 65 70 74 68 (and (< i depth 0aa0: 29 0a 09 09 20 20 28 3e 20 28 63 75 72 20 27 64 )... (> (cur 'd 0ab0: 65 70 74 68 29 20 31 29 29 0a 09 20 20 20 20 20 epth) 1)).. 0ac0: 28 6c 65 74 2a 20 28 5b 6e 61 6d 65 20 28 63 6f (let* ([name (co 0ad0: 6e 64 20 5b 28 28 63 75 72 20 27 63 6f 64 65 29 nd [((cur 'code) 0ae0: 20 27 6e 61 6d 65 29 20 3d 3e 20 28 6c 61 6d 62 'name) => (lamb 0af0: 64 61 20 28 78 29 20 78 29 5d 0a 09 09 09 09 5b da (x) x)].....[ 0b00: 65 6c 73 65 20 22 2a 22 5d 29 5d 0a 09 09 20 20 else "*"])]... 0b10: 20 20 5b 73 6f 75 72 63 65 20 28 28 63 75 72 20 [source ((cur 0b20: 27 63 6f 64 65 29 20 27 73 6f 75 72 63 65 29 5d 'code) 'source)] 0b30: 0a 09 09 20 20 20 20 5b 73 6f 75 72 63 65 2d 74 ... [source-t 0b40: 78 74 20 28 69 66 20 73 6f 75 72 63 65 0a 09 09 xt (if source... 0b50: 09 09 20 20 20 20 28 6c 65 74 20 28 5b 73 73 20 .. (let ([ss 0b60: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to- 0b70: 73 74 72 69 6e 67 0a 09 09 09 09 09 09 28 6c 61 string.......(la 0b80: 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 20 20 mbda ()....... 0b90: 28 73 6f 75 72 63 65 20 27 77 72 69 74 65 20 28 (source 'write ( 0ba0: 63 75 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 current-output-p 0bb0: 6f 72 74 29 29 29 29 5d 29 0a 09 09 09 09 09 20 ort))))])...... 0bc0: 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d (if (> (string- 0bd0: 6c 65 6e 67 74 68 20 73 73 29 20 35 30 29 0a 09 length ss) 50).. 0be0: 09 09 09 09 20 20 20 20 20 20 28 73 74 72 69 6e .... (strin 0bf0: 67 2d 74 72 75 6e 63 61 74 65 21 20 73 73 20 35 g-truncate! ss 5 0c00: 30 29 0a 09 09 09 09 09 20 20 20 20 20 20 73 73 0)...... ss 0c10: 29 29 0a 09 09 09 09 20 20 20 20 22 2a 22 29 5d ))..... "*")] 0c20: 29 0a 09 20 20 20 20 20 20 20 28 63 61 6c 6c 2d ).. (call- 0c30: 77 69 74 68 2d 76 61 6c 75 65 73 0a 09 09 20 20 with-values... 0c40: 20 28 6c 61 6d 62 64 61 20 28 29 20 28 63 75 72 (lambda () (cur 0c50: 20 27 73 6f 75 72 63 65 2d 70 61 74 68 29 29 0a 'source-path)). 0c60: 09 09 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a .. (case-lambda. 0c70: 09 09 20 20 5b 28 29 20 28 70 72 69 6e 74 66 20 .. [() (printf 0c80: 22 5b 6e 6f 20 73 6f 75 72 63 65 5d 20 5b 7e 61 "[no source] [~a 0c90: 5d 3a 20 7e 61 5c 6e 22 20 6e 61 6d 65 20 73 6f ]: ~a\n" name so 0ca0: 75 72 63 65 2d 74 78 74 29 5d 0a 09 09 20 20 5b urce-txt)]... [ 0cb0: 28 66 6e 20 62 66 70 29 20 28 70 72 69 6e 74 66 (fn bfp) (printf 0cc0: 20 22 7e 61 20 63 68 61 72 20 7e 61 20 5b 7e 61 "~a char ~a [~a 0cd0: 5d 3a 20 7e 61 5c 6e 22 20 66 6e 20 62 66 70 20 ]: ~a\n" fn bfp 0ce0: 6e 61 6d 65 20 73 6f 75 72 63 65 2d 74 78 74 29 name source-txt) 0cf0: 5d 0a 09 09 20 20 5b 28 66 6e 20 6c 69 6e 65 20 ]... [(fn line 0d00: 63 68 61 72 29 20 28 70 72 69 6e 74 66 20 22 7e char) (printf "~ 0d10: 61 3a 7e 61 3a 7e 61 20 5b 7e 61 5d 3a 20 7e 61 a:~a:~a [~a]: ~a 0d20: 5c 6e 22 20 66 6e 20 6c 69 6e 65 20 63 68 61 72 \n" fn line char 0d30: 20 6e 61 6d 65 20 73 6f 75 72 63 65 2d 74 78 74 name source-txt 0d40: 29 5d 29 29 0a 09 20 20 20 20 20 20 20 28 6c 6f )])).. (lo 0d50: 6f 70 20 28 63 75 72 20 27 6c 69 6e 6b 29 20 28 op (cur 'link) ( 0d60: 2b 20 69 20 31 29 29 29 29 29 29 29 0a 20 20 20 + i 1))))))). 0d70: 20 28 70 72 69 6e 74 66 20 22 73 74 61 63 6b 2d (printf "stack- 0d80: 74 72 61 63 65 20 65 6e 64 2e 5c 6e 22 29 29 0a trace end.\n")). 0d90: 0a 0a 20 20 28 64 65 66 69 6e 65 20 73 75 62 2d .. (define sub- 0da0: 62 79 74 65 76 65 63 74 6f 72 0a 20 20 20 20 28 bytevector. ( 0db0: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 case-lambda. 0dc0: 20 20 5b 28 62 20 73 74 61 72 74 29 0a 20 20 20 [(b start). 0dd0: 20 20 20 20 28 73 75 62 2d 62 79 74 65 76 65 63 (sub-bytevec 0de0: 74 6f 72 20 62 20 73 74 61 72 74 20 28 62 79 74 tor b start (byt 0df0: 65 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 62 evector-length b 0e00: 29 29 5d 0a 20 20 20 20 20 20 5b 28 62 20 73 74 ))]. [(b st 0e10: 61 72 74 20 65 6e 64 29 0a 20 20 20 20 20 20 20 art end). 0e20: 28 6c 65 74 2a 20 28 5b 6e 20 28 2d 20 65 6e 64 (let* ([n (- end 0e30: 20 73 74 61 72 74 29 5d 0a 09 20 20 20 20 20 20 start)].. 0e40: 5b 78 20 28 6d 61 6b 65 2d 62 79 74 65 76 65 63 [x (make-bytevec 0e50: 74 6f 72 20 6e 29 5d 29 0a 09 20 28 62 79 74 65 tor n)]).. (byte 0e60: 76 65 63 74 6f 72 2d 63 6f 70 79 21 20 62 20 73 vector-copy! b s 0e70: 74 61 72 74 20 78 20 30 20 6e 29 0a 09 20 78 29 tart x 0 n).. x) 0e80: 5d 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 ])).. (define ( 0e90: 73 75 62 2d 62 79 74 65 76 65 63 74 6f 72 3d 3f sub-bytevector=? 0ea0: 20 62 31 20 73 74 61 72 74 31 20 62 32 20 73 74 b1 start1 b2 st 0eb0: 61 72 74 32 20 6c 65 6e 29 0a 20 20 20 20 28 62 art2 len). (b 0ec0: 79 74 65 76 65 63 74 6f 72 3d 3f 20 28 73 75 62 ytevector=? (sub 0ed0: 2d 62 79 74 65 76 65 63 74 6f 72 20 62 31 20 73 -bytevector b1 s 0ee0: 74 61 72 74 31 20 28 2b 20 73 74 61 72 74 31 20 tart1 (+ start1 0ef0: 6c 65 6e 29 29 0a 09 09 20 20 28 73 75 62 2d 62 len))... (sub-b 0f00: 79 74 65 76 65 63 74 6f 72 20 62 32 20 73 74 61 ytevector b2 sta 0f10: 72 74 32 20 28 2b 20 73 74 61 72 74 32 20 6c 65 rt2 (+ start2 le 0f20: 6e 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 n)))).. (define 0f30: 20 28 6c 6f 61 64 2d 62 79 74 65 76 65 63 74 6f (load-bytevecto 0f40: 72 20 70 61 74 68 29 0a 20 20 20 20 28 63 61 6c r path). (cal 0f50: 6c 2d 77 69 74 68 2d 70 6f 72 74 20 28 6f 70 65 l-with-port (ope 0f60: 6e 2d 66 69 6c 65 2d 69 6e 70 75 74 2d 70 6f 72 n-file-input-por 0f70: 74 20 70 61 74 68 29 0a 09 09 20 20 20 20 28 6c t path)... (l 0f80: 61 6d 62 64 61 20 28 70 29 20 28 67 65 74 2d 62 ambda (p) (get-b 0f90: 79 74 65 76 65 63 74 6f 72 2d 61 6c 6c 20 70 29 ytevector-all p) 0fa0: 29 29 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 ))). . (define 0fb0: 20 28 73 61 76 65 2d 62 79 74 65 76 65 63 74 6f (save-bytevecto 0fc0: 72 20 70 61 74 68 20 64 61 74 61 29 0a 20 20 20 r path data). 0fd0: 20 28 63 61 6c 6c 2d 77 69 74 68 2d 70 6f 72 74 (call-with-port 0fe0: 20 28 6f 70 65 6e 2d 66 69 6c 65 2d 6f 75 74 70 (open-file-outp 0ff0: 75 74 2d 70 6f 72 74 20 70 61 74 68 29 0a 09 09 ut-port path)... 1000: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 29 20 (lambda (p) 1010: 28 70 75 74 2d 62 79 74 65 76 65 63 74 6f 72 20 (put-bytevector 1020: 70 20 64 61 74 61 29 29 29 29 0a 0a 20 20 3b 3b p data)))).. ;; 1030: 20 66 72 6f 6d 20 68 74 74 70 73 3a 2f 2f 66 61 from https://fa 1040: 72 65 2e 6c 69 76 65 6a 6f 75 72 6e 61 6c 2e 63 re.livejournal.c 1050: 6f 6d 2f 31 38 39 37 34 31 2e 68 74 6d 6c 0a 20 om/189741.html. 1060: 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 (define-syntax 1070: 28 6e 65 73 74 20 73 74 78 29 0a 20 20 20 20 28 (nest stx). ( 1080: 73 79 6e 74 61 78 2d 63 61 73 65 20 73 74 78 20 syntax-case stx 1090: 28 29 0a 20 20 20 20 20 20 28 28 6e 65 73 74 20 (). ((nest 10a0: 6f 75 74 65 72 20 2e 2e 2e 20 69 6e 6e 65 72 29 outer ... inner) 10b0: 0a 20 20 20 20 20 20 20 28 66 6f 6c 64 2d 72 69 . (fold-ri 10c0: 67 68 74 20 28 6c 61 6d 62 64 61 20 28 6f 20 69 ght (lambda (o i 10d0: 29 0a 09 09 20 20 20 20 20 28 77 69 74 68 2d 73 )... (with-s 10e0: 79 6e 74 61 78 20 28 28 28 6f 75 74 65 72 20 2e yntax (((outer . 10f0: 2e 2e 29 20 6f 29 0a 09 09 09 09 20 20 20 28 69 ..) o)..... (i 1100: 6e 6e 65 72 20 69 29 29 0a 09 09 20 20 20 20 20 nner i))... 1110: 20 20 23 27 28 6f 75 74 65 72 20 2e 2e 2e 20 69 #'(outer ... i 1120: 6e 6e 65 72 29 29 29 0a 09 09 20 20 20 23 27 69 nner)))... #'i 1130: 6e 6e 65 72 20 28 73 79 6e 74 61 78 2d 3e 6c 69 nner (syntax->li 1140: 73 74 20 23 27 28 6f 75 74 65 72 20 2e 2e 2e 29 st #'(outer ...) 1150: 29 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 ))))).. (define 1160: 2d 61 75 78 69 6c 69 61 72 79 2d 6b 65 79 77 6f -auxiliary-keywo 1170: 72 64 73 20 2f 6f 70 74 69 6f 6e 61 6c 20 2f 6b rds /optional /k 1180: 65 79 73 29 0a 0a 20 20 28 64 65 66 69 6e 65 2d eys).. (define- 1190: 73 79 6e 74 61 78 20 64 65 66 69 6e 65 2f 6f 70 syntax define/op 11a0: 74 69 6f 6e 61 6c 0a 20 20 20 20 28 6c 61 6d 62 tional. (lamb 11b0: 64 61 20 28 73 74 78 29 0a 20 20 20 20 20 20 28 da (stx). ( 11c0: 73 79 6e 74 61 78 2d 63 61 73 65 20 73 74 78 20 syntax-case stx 11d0: 28 2f 6f 70 74 69 6f 6e 61 6c 29 0a 09 5b 28 5f (/optional)..[(_ 11e0: 20 28 6e 61 6d 65 20 70 61 72 61 6d 73 20 2e 2e (name params .. 11f0: 2e 20 28 2f 6f 70 74 69 6f 6e 61 6c 20 6f 70 74 . (/optional opt 1200: 73 20 2e 2e 2e 29 29 20 62 6f 64 79 20 2e 2e 2e s ...)) body ... 1210: 29 0a 09 20 28 6c 65 74 20 28 5b 6f 70 74 73 2d ).. (let ([opts- 1220: 6c 69 73 74 0a 09 09 28 6d 61 70 20 28 6c 61 6d list...(map (lam 1230: 62 64 61 20 28 6f 70 74 29 0a 09 09 20 20 20 20 bda (opt)... 1240: 20 20 20 28 6c 65 74 20 28 5b 78 20 28 73 79 6e (let ([x (syn 1250: 74 61 78 2d 3e 64 61 74 75 6d 20 6f 70 74 29 5d tax->datum opt)] 1260: 29 0a 09 09 09 20 28 69 66 20 28 6c 69 73 74 3f ).... (if (list? 1270: 20 78 29 0a 09 09 09 20 20 20 20 20 28 6c 69 73 x).... (lis 1280: 74 20 28 64 61 74 75 6d 2d 3e 73 79 6e 74 61 78 t (datum->syntax 1290: 20 28 63 61 72 20 28 73 79 6e 74 61 78 2d 3e 6c (car (syntax->l 12a0: 69 73 74 20 6f 70 74 29 29 20 28 63 61 72 20 78 ist opt)) (car x 12b0: 29 29 0a 09 09 09 09 20 20 20 28 64 61 74 75 6d ))..... (datum 12c0: 2d 3e 73 79 6e 74 61 78 20 28 63 61 72 20 28 73 ->syntax (car (s 12d0: 79 6e 74 61 78 2d 3e 6c 69 73 74 20 6f 70 74 29 yntax->list opt) 12e0: 29 20 28 63 61 64 72 20 78 29 20 29 29 0a 09 09 ) (cadr x) ))... 12f0: 09 20 20 20 20 20 28 6c 69 73 74 20 6f 70 74 20 . (list opt 1300: 23 66 29 29 29 29 0a 09 09 20 20 20 20 20 28 73 #f))))... (s 1310: 79 6e 74 61 78 2d 3e 6c 69 73 74 20 23 27 28 6f yntax->list #'(o 1320: 70 74 73 20 2e 2e 2e 29 29 29 5d 29 0a 09 20 20 pts ...)))]).. 1330: 20 23 60 28 64 65 66 69 6e 65 20 6e 61 6d 65 0a #`(define name. 1340: 09 20 20 20 20 20 20 20 28 63 61 73 65 2d 6c 61 . (case-la 1350: 6d 62 64 61 0a 09 09 20 23 2c 40 28 6d 61 70 20 mbda... #,@(map 1360: 28 6c 61 6d 62 64 61 20 28 69 29 0a 09 09 09 20 (lambda (i).... 1370: 20 20 23 60 5b 28 70 61 72 61 6d 73 20 2e 2e 2e #`[(params ... 1380: 20 23 2c 40 28 74 61 6b 65 20 28 6d 61 70 20 63 #,@(take (map c 1390: 61 72 20 6f 70 74 73 2d 6c 69 73 74 29 20 69 29 ar opts-list) i) 13a0: 29 0a 09 09 09 20 20 20 20 20 20 28 6e 61 6d 65 ).... (name 13b0: 20 70 61 72 61 6d 73 20 2e 2e 2e 0a 09 09 09 09 params ........ 13c0: 20 20 20 20 23 2c 40 28 74 61 6b 65 20 28 6d 61 #,@(take (ma 13d0: 70 20 63 61 72 20 6f 70 74 73 2d 6c 69 73 74 29 p car opts-list) 13e0: 20 69 29 0a 09 09 09 09 20 20 20 20 23 2c 40 28 i)..... #,@( 13f0: 64 72 6f 70 20 28 6d 61 70 20 63 61 64 72 20 6f drop (map cadr o 1400: 70 74 73 2d 6c 69 73 74 29 20 69 29 29 5d 29 0a pts-list) i))]). 1410: 09 09 09 20 28 69 6f 74 61 20 20 28 6c 65 6e 67 ... (iota (leng 1420: 74 68 20 6f 70 74 73 2d 6c 69 73 74 29 29 29 0a th opts-list))). 1430: 09 09 20 5b 28 70 61 72 61 6d 73 20 2e 2e 2e 20 .. [(params ... 1440: 23 2c 40 28 6d 61 70 20 63 61 72 20 6f 70 74 73 #,@(map car opts 1450: 2d 6c 69 73 74 29 29 0a 09 09 20 20 62 6f 64 79 -list))... body 1460: 20 2e 2e 2e 5d 29 29 29 5d 29 29 29 0a 0a 20 20 ...])))]))).. 1470: 0a 20 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 . (define-synta 1480: 78 20 6c 61 6d 62 64 61 2f 6f 70 74 69 6f 6e 61 x lambda/optiona 1490: 6c 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 l. (lambda (s 14a0: 74 78 29 0a 20 20 20 20 20 20 28 73 79 6e 74 61 tx). (synta 14b0: 78 2d 63 61 73 65 20 73 74 78 20 28 2f 6f 70 74 x-case stx (/opt 14c0: 69 6f 6e 61 6c 29 0a 09 5b 28 5f 20 28 70 61 72 ional)..[(_ (par 14d0: 61 6d 73 20 2e 2e 2e 20 28 2f 6f 70 74 69 6f 6e ams ... (/option 14e0: 61 6c 20 6f 70 74 73 20 2e 2e 2e 29 29 20 62 6f al opts ...)) bo 14f0: 64 79 20 2e 2e 2e 29 0a 09 20 28 6c 65 74 20 28 dy ...).. (let ( 1500: 5b 6f 70 74 73 2d 6c 69 73 74 0a 09 09 28 6d 61 [opts-list...(ma 1510: 70 20 28 6c 61 6d 62 64 61 20 28 6f 70 74 29 0a p (lambda (opt). 1520: 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 5b .. (let ([ 1530: 78 20 28 73 79 6e 74 61 78 2d 3e 64 61 74 75 6d x (syntax->datum 1540: 20 6f 70 74 29 5d 29 0a 09 09 09 20 28 69 66 20 opt)]).... (if 1550: 28 6c 69 73 74 3f 20 78 29 0a 09 09 09 20 20 20 (list? x).... 1560: 20 20 28 6c 69 73 74 20 28 64 61 74 75 6d 2d 3e (list (datum-> 1570: 73 79 6e 74 61 78 20 28 63 61 72 20 28 73 79 6e syntax (car (syn 1580: 74 61 78 2d 3e 6c 69 73 74 20 6f 70 74 29 29 20 tax->list opt)) 1590: 28 63 61 72 20 78 29 29 0a 09 09 09 09 20 20 20 (car x))..... 15a0: 28 64 61 74 75 6d 2d 3e 73 79 6e 74 61 78 20 28 (datum->syntax ( 15b0: 63 61 72 20 28 73 79 6e 74 61 78 2d 3e 6c 69 73 car (syntax->lis 15c0: 74 20 6f 70 74 29 29 20 28 63 61 64 72 20 78 29 t opt)) (cadr x) 15d0: 20 29 29 0a 09 09 09 20 20 20 20 20 28 6c 69 73 )).... (lis 15e0: 74 20 6f 70 74 20 23 66 29 29 29 29 0a 09 09 20 t opt #f))))... 15f0: 20 20 20 20 28 73 79 6e 74 61 78 2d 3e 6c 69 73 (syntax->lis 1600: 74 20 23 27 28 6f 70 74 73 20 2e 2e 2e 29 29 29 t #'(opts ...))) 1610: 5d 29 0a 09 20 20 20 23 60 28 6c 65 74 72 65 63 ]).. #`(letrec 1620: 20 28 5b 66 75 6e 63 20 0a 09 09 20 20 20 20 20 ([func ... 1630: 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 09 (case-lambda.. 1640: 09 09 20 23 2c 40 28 6d 61 70 20 28 6c 61 6d 62 .. #,@(map (lamb 1650: 64 61 20 28 69 29 0a 09 09 09 09 20 20 20 23 60 da (i)..... #` 1660: 5b 28 70 61 72 61 6d 73 20 2e 2e 2e 20 23 2c 40 [(params ... #,@ 1670: 28 74 61 6b 65 20 28 6d 61 70 20 63 61 72 20 6f (take (map car o 1680: 70 74 73 2d 6c 69 73 74 29 20 69 29 29 0a 09 09 pts-list) i))... 1690: 09 09 20 20 20 20 20 20 28 66 75 6e 63 20 70 61 .. (func pa 16a0: 72 61 6d 73 20 2e 2e 2e 0a 09 09 09 09 09 20 20 rams ......... 16b0: 20 20 23 2c 40 28 74 61 6b 65 20 28 6d 61 70 20 #,@(take (map 16c0: 63 61 72 20 6f 70 74 73 2d 6c 69 73 74 29 20 69 car opts-list) i 16d0: 29 0a 09 09 09 09 09 20 20 20 20 23 2c 40 28 64 )...... #,@(d 16e0: 72 6f 70 20 28 6d 61 70 20 63 61 64 72 20 6f 70 rop (map cadr op 16f0: 74 73 2d 6c 69 73 74 29 20 69 29 29 5d 29 0a 09 ts-list) i))]).. 1700: 09 09 09 20 28 69 6f 74 61 20 20 28 6c 65 6e 67 ... (iota (leng 1710: 74 68 20 6f 70 74 73 2d 6c 69 73 74 29 29 29 0a th opts-list))). 1720: 09 09 09 20 5b 28 70 61 72 61 6d 73 20 2e 2e 2e ... [(params ... 1730: 20 23 2c 40 28 6d 61 70 20 63 61 72 20 6f 70 74 #,@(map car opt 1740: 73 2d 6c 69 73 74 29 29 0a 09 09 09 20 20 62 6f s-list)).... bo 1750: 64 79 20 2e 2e 2e 5d 29 5d 29 0a 09 20 20 20 20 dy ...])]).. 1760: 20 20 20 66 75 6e 63 29 29 5d 29 29 29 0a 0a 20 func))]))).. 1770: 20 28 64 65 66 69 6e 65 20 28 64 65 63 6f 64 65 (define (decode 1780: 2d 6b 65 79 73 20 66 75 6e 63 2d 6e 61 6d 65 20 -keys func-name 1790: 6e 61 6d 65 73 20 6b 65 79 73 29 0a 20 20 20 20 names keys). 17a0: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd 17b0: 61 20 28 6b 29 0a 09 09 28 75 6e 6c 65 73 73 20 a (k)...(unless 17c0: 28 61 73 73 71 20 28 63 61 72 20 6b 29 20 6e 61 (assq (car k) na 17d0: 6d 65 73 29 0a 09 09 20 20 28 65 72 72 6f 72 66 mes)... (errorf 17e0: 20 66 75 6e 63 2d 6e 61 6d 65 20 22 75 6e 6b 6e func-name "unkn 17f0: 6f 77 6e 20 6b 65 79 77 6f 72 64 20 61 72 67 75 own keyword argu 1800: 6d 65 6e 74 20 7e 64 22 20 6b 29 29 29 0a 09 20 ment ~d" k))).. 1810: 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 20 28 keys). ( 1820: 61 70 70 6c 79 20 76 61 6c 75 65 73 20 28 6d 61 apply values (ma 1830: 70 20 28 6c 61 6d 62 64 61 20 28 6e 61 6d 65 29 p (lambda (name) 1840: 0a 09 09 09 20 28 6c 65 74 20 28 5b 70 20 28 61 .... (let ([p (a 1850: 73 73 71 20 28 69 66 20 28 70 61 69 72 3f 20 6e ssq (if (pair? n 1860: 61 6d 65 29 20 28 63 61 72 20 6e 61 6d 65 29 20 ame) (car name) 1870: 6e 61 6d 65 29 20 6b 65 79 73 29 5d 29 0a 09 09 name) keys)])... 1880: 09 20 20 20 28 69 66 20 70 0a 09 09 09 20 20 20 . (if p.... 1890: 20 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 28 (if (pair? ( 18a0: 63 64 72 20 70 29 29 0a 09 09 09 09 20 20 20 28 cdr p))..... ( 18b0: 63 61 64 72 20 70 29 0a 09 09 09 09 20 20 20 28 cadr p)..... ( 18c0: 63 64 72 20 70 29 29 0a 09 09 09 20 20 20 20 20 cdr p)).... 18d0: 20 20 28 69 66 20 28 70 61 69 72 3f 20 6e 61 6d (if (pair? nam 18e0: 65 29 0a 09 09 09 09 20 20 20 28 69 66 20 28 70 e)..... (if (p 18f0: 61 69 72 3f 20 28 63 64 72 20 6e 61 6d 65 29 29 air? (cdr name)) 1900: 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 61 64 ..... (cad 1910: 72 20 6e 61 6d 65 29 0a 09 09 09 09 20 20 20 20 r name)..... 1920: 20 20 20 28 63 64 72 20 6e 61 6d 65 29 29 0a 09 (cdr name)).. 1930: 09 09 09 20 20 20 23 66 29 29 29 29 0a 09 09 20 ... #f))))... 1940: 20 20 20 20 20 20 6e 61 6d 65 73 29 29 29 0a 20 names))). 1950: 20 0a 20 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 . (define-synt 1960: 61 78 20 64 65 66 69 6e 65 2f 6b 65 79 73 20 0a ax define/keys . 1970: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 78 (lambda (stx 1980: 29 0a 20 20 20 20 20 20 28 73 79 6e 74 61 78 2d ). (syntax- 1990: 63 61 73 65 20 73 74 78 20 28 2f 6b 65 79 73 29 case stx (/keys) 19a0: 0a 09 5b 28 5f 20 28 6e 61 6d 65 20 70 61 72 61 ..[(_ (name para 19b0: 6d 73 20 2e 2e 2e 20 28 2f 6b 65 79 73 20 6b 65 ms ... (/keys ke 19c0: 79 73 20 2e 2e 2e 29 29 20 62 6f 64 79 20 2e 2e ys ...)) body .. 19d0: 2e 29 0a 09 20 28 6c 65 74 20 28 5b 6b 65 79 73 .).. (let ([keys 19e0: 2d 6c 69 73 74 0a 09 09 28 6d 61 70 20 28 6c 61 -list...(map (la 19f0: 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 20 20 20 mbda (key)... 1a00: 20 20 20 20 28 6c 65 74 20 28 5b 78 20 28 73 79 (let ([x (sy 1a10: 6e 74 61 78 2d 3e 64 61 74 75 6d 20 6b 65 79 29 ntax->datum key) 1a20: 5d 29 0a 09 09 09 20 28 69 66 20 28 6c 69 73 74 ]).... (if (list 1a30: 3f 20 78 29 0a 09 09 09 20 20 20 20 20 28 6c 69 ? x).... (li 1a40: 73 74 20 28 64 61 74 75 6d 2d 3e 73 79 6e 74 61 st (datum->synta 1a50: 78 20 28 63 61 72 20 28 73 79 6e 74 61 78 2d 3e x (car (syntax-> 1a60: 6c 69 73 74 20 6b 65 79 29 29 20 28 63 61 72 20 list key)) (car 1a70: 78 29 29 0a 09 09 09 09 20 20 20 28 64 61 74 75 x))..... (datu 1a80: 6d 2d 3e 73 79 6e 74 61 78 20 28 63 61 72 20 28 m->syntax (car ( 1a90: 73 79 6e 74 61 78 2d 3e 6c 69 73 74 20 6b 65 79 syntax->list key 1aa0: 29 29 20 28 63 61 64 72 20 78 29 20 29 29 0a 09 )) (cadr x) )).. 1ab0: 09 09 20 20 20 20 20 28 6c 69 73 74 20 6b 65 79 .. (list key 1ac0: 20 23 66 29 29 29 29 0a 09 09 20 20 20 20 20 28 #f))))... ( 1ad0: 73 79 6e 74 61 78 2d 3e 6c 69 73 74 20 23 27 28 syntax->list #'( 1ae0: 6b 65 79 73 20 2e 2e 2e 29 29 29 5d 29 0a 20 09 keys ...)))]). . 1af0: 20 20 20 23 60 28 64 65 66 69 6e 65 20 6e 61 6d #`(define nam 1b00: 65 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 e.. (lambd 1b10: 61 20 28 70 61 72 61 6d 73 20 2e 2e 2e 20 2e 20 a (params ... . 1b20: 6b 65 79 73 2a 29 0a 09 09 20 28 69 6d 70 6f 72 keys*)... (impor 1b30: 74 20 28 6f 6e 6c 79 20 28 64 61 74 61 2d 73 74 t (only (data-st 1b40: 72 75 63 74 75 72 65 73 29 20 63 68 6f 70 29 29 ructures) chop)) 1b50: 0a 09 09 20 28 69 6d 70 6f 72 74 20 28 6f 6e 6c ... (import (onl 1b60: 79 20 28 74 68 75 6e 64 65 72 2d 75 74 69 6c 73 y (thunder-utils 1b70: 29 20 64 65 63 6f 64 65 2d 6b 65 79 73 29 29 0a ) decode-keys)). 1b80: 09 09 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 .. (let-values ( 1b90: 5b 28 23 2c 40 28 6d 61 70 20 63 61 72 20 6b 65 [(#,@(map car ke 1ba0: 79 73 2d 6c 69 73 74 29 29 0a 09 09 09 20 20 20 ys-list)).... 1bb0: 20 20 20 20 28 64 65 63 6f 64 65 2d 6b 65 79 73 (decode-keys 1bc0: 20 27 6e 61 6d 65 20 27 23 2c 6b 65 79 73 2d 6c 'name '#,keys-l 1bd0: 69 73 74 20 28 63 68 6f 70 20 6b 65 79 73 2a 20 ist (chop keys* 1be0: 32 29 29 5d 29 0a 09 09 20 20 20 62 6f 64 79 20 2))])... body 1bf0: 2e 2e 2e 29 29 29 29 5d 29 29 29 0a 0a 20 20 0a ...))))]))).. . 1c00: 20 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 (define-syntax 1c10: 20 6c 61 6d 62 64 61 2f 6b 65 79 73 20 0a 20 20 lambda/keys . 1c20: 20 20 28 6c 61 6d 62 64 61 20 28 73 74 78 29 0a (lambda (stx). 1c30: 20 20 20 20 20 20 28 73 79 6e 74 61 78 2d 63 61 (syntax-ca 1c40: 73 65 20 73 74 78 20 28 2f 6b 65 79 73 29 0a 09 se stx (/keys).. 1c50: 5b 28 5f 20 28 70 61 72 61 6d 73 20 2e 2e 2e 20 [(_ (params ... 1c60: 28 2f 6b 65 79 73 20 6b 65 79 73 20 2e 2e 2e 29 (/keys keys ...) 1c70: 29 20 62 6f 64 79 20 2e 2e 2e 29 0a 09 20 28 6c ) body ...).. (l 1c80: 65 74 20 28 5b 6b 65 79 73 2d 6c 69 73 74 0a 09 et ([keys-list.. 1c90: 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b .(map (lambda (k 1ca0: 65 79 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 ey)... (le 1cb0: 74 20 28 5b 78 20 28 73 79 6e 74 61 78 2d 3e 64 t ([x (syntax->d 1cc0: 61 74 75 6d 20 6b 65 79 29 5d 29 0a 09 09 09 20 atum key)]).... 1cd0: 28 69 66 20 28 6c 69 73 74 3f 20 78 29 0a 09 09 (if (list? x)... 1ce0: 09 20 20 20 20 20 28 6c 69 73 74 20 28 64 61 74 . (list (dat 1cf0: 75 6d 2d 3e 73 79 6e 74 61 78 20 28 63 61 72 20 um->syntax (car 1d00: 28 73 79 6e 74 61 78 2d 3e 6c 69 73 74 20 6b 65 (syntax->list ke 1d10: 79 29 29 20 28 63 61 72 20 78 29 29 0a 09 09 09 y)) (car x)).... 1d20: 09 20 20 20 28 64 61 74 75 6d 2d 3e 73 79 6e 74 . (datum->synt 1d30: 61 78 20 28 63 61 72 20 28 73 79 6e 74 61 78 2d ax (car (syntax- 1d40: 3e 6c 69 73 74 20 6b 65 79 29 29 20 28 63 61 64 >list key)) (cad 1d50: 72 20 78 29 20 29 29 0a 09 09 09 20 20 20 20 20 r x) )).... 1d60: 28 6c 69 73 74 20 6b 65 79 20 23 66 29 29 29 29 (list key #f)))) 1d70: 0a 09 09 20 20 20 20 20 28 73 79 6e 74 61 78 2d ... (syntax- 1d80: 3e 6c 69 73 74 20 23 27 28 6b 65 79 73 20 2e 2e >list #'(keys .. 1d90: 2e 29 29 29 5d 29 0a 20 09 20 20 20 23 60 28 6c .)))]). . #`(l 1da0: 61 6d 62 64 61 20 28 70 61 72 61 6d 73 20 2e 2e ambda (params .. 1db0: 2e 20 2e 20 6b 65 79 73 2a 29 0a 09 20 20 20 20 . . keys*).. 1dc0: 20 20 20 28 69 6d 70 6f 72 74 20 28 6f 6e 6c 79 (import (only 1dd0: 20 28 64 61 74 61 2d 73 74 72 75 63 74 75 72 65 (data-structure 1de0: 73 29 20 63 68 6f 70 29 29 0a 09 20 20 20 20 20 s) chop)).. 1df0: 20 20 28 69 6d 70 6f 72 74 20 28 6f 6e 6c 79 20 (import (only 1e00: 28 74 68 75 6e 64 65 72 2d 75 74 69 6c 73 29 20 (thunder-utils) 1e10: 64 65 63 6f 64 65 2d 6b 65 79 73 29 29 0a 09 20 decode-keys)).. 1e20: 20 20 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 (let-value 1e30: 73 20 28 5b 28 23 2c 40 28 6d 61 70 20 63 61 72 s ([(#,@(map car 1e40: 20 6b 65 79 73 2d 6c 69 73 74 29 29 0a 09 09 09 keys-list)).... 1e50: 20 20 20 20 20 28 64 65 63 6f 64 65 2d 6b 65 79 (decode-key 1e60: 73 20 27 66 75 6e 63 20 27 23 2c 6b 65 79 73 2d s 'func '#,keys- 1e70: 6c 69 73 74 20 28 63 68 6f 70 20 6b 65 79 73 2a list (chop keys* 1e80: 20 32 29 29 5d 29 0a 09 09 20 62 6f 64 79 20 2e 2))])... body . 1e90: 2e 2e 29 29 29 5d 29 29 29 0a 20 20 29 3b 6c 69 ..)))]))). );li 1ea0: 62 72 61 72 79 0a 0a brary..