Artifact 0bc19e89c9f768c6d739c42eb8cdaf16f4c27866:
- File srfi-99.scm — part of check-in [6e33be7cc6] at 2018-08-14 11:27:46 on branch chicken-5 — Added imports for extend-procedure and procedure-data, re-enabled tests (user: murphy size: 17285)
0000: 3b 3b 20 2d 2a 2d 20 6d 6f 64 65 3a 20 53 63 68 ;; -*- mode: Sch 0010: 65 6d 65 3b 20 2d 2a 2d 0a 3b 3b 0a 3b 3b 20 54 eme; -*-.;;.;; T 0020: 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 72 74 his file is part 0030: 20 6f 66 20 53 52 46 49 2d 39 39 20 66 6f 72 20 of SRFI-99 for 0040: 43 48 49 43 4b 45 4e 0a 3b 3b 20 43 6f 70 79 72 CHICKEN.;; Copyr 0050: 69 67 68 74 20 28 63 29 20 32 30 31 31 20 62 79 ight (c) 2011 by 0060: 20 54 68 6f 6d 61 73 20 43 68 75 73 74 2e 20 20 Thomas Chust. 0070: 41 6c 6c 20 72 69 67 68 74 73 20 72 65 73 65 72 All rights reser 0080: 76 65 64 2e 0a 3b 3b 0a 3b 3b 20 50 65 72 6d 69 ved..;;.;; Permi 0090: 73 73 69 6f 6e 20 69 73 20 68 65 72 65 62 79 20 ssion is hereby 00a0: 67 72 61 6e 74 65 64 2c 20 66 72 65 65 20 6f 66 granted, free of 00b0: 20 63 68 61 72 67 65 2c 20 74 6f 20 61 6e 79 20 charge, to any 00c0: 70 65 72 73 6f 6e 0a 3b 3b 20 6f 62 74 61 69 6e person.;; obtain 00d0: 69 6e 67 20 61 20 63 6f 70 79 20 6f 66 20 74 68 ing a copy of th 00e0: 69 73 20 73 6f 66 74 77 61 72 65 20 61 6e 64 20 is software and 00f0: 61 73 73 6f 63 69 61 74 65 64 20 64 6f 63 75 6d associated docum 0100: 65 6e 74 61 74 69 6f 6e 0a 3b 3b 20 66 69 6c 65 entation.;; file 0110: 73 20 28 74 68 65 20 53 6f 66 74 77 61 72 65 29 s (the Software) 0120: 2c 20 74 6f 20 64 65 61 6c 20 69 6e 20 74 68 65 , to deal in the 0130: 20 53 6f 66 74 77 61 72 65 20 77 69 74 68 6f 75 Software withou 0140: 74 20 72 65 73 74 72 69 63 74 69 6f 6e 2c 0a 3b t restriction,.; 0150: 3b 20 69 6e 63 6c 75 64 69 6e 67 20 77 69 74 68 ; including with 0160: 6f 75 74 20 6c 69 6d 69 74 61 74 69 6f 6e 20 74 out limitation t 0170: 68 65 20 72 69 67 68 74 73 20 74 6f 20 75 73 65 he rights to use 0180: 2c 20 63 6f 70 79 2c 20 6d 6f 64 69 66 79 2c 0a , copy, modify,. 0190: 3b 3b 20 6d 65 72 67 65 2c 20 70 75 62 6c 69 73 ;; merge, publis 01a0: 68 2c 20 64 69 73 74 72 69 62 75 74 65 2c 20 73 h, distribute, s 01b0: 75 62 6c 69 63 65 6e 73 65 2c 20 61 6e 64 2f 6f ublicense, and/o 01c0: 72 20 73 65 6c 6c 20 63 6f 70 69 65 73 20 6f 66 r sell copies of 01d0: 20 74 68 65 0a 3b 3b 20 53 6f 66 74 77 61 72 65 the.;; Software 01e0: 2c 20 61 6e 64 20 74 6f 20 70 65 72 6d 69 74 20 , and to permit 01f0: 70 65 72 73 6f 6e 73 20 74 6f 20 77 68 6f 6d 20 persons to whom 0200: 74 68 65 20 53 6f 66 74 77 61 72 65 20 69 73 20 the Software is 0210: 66 75 72 6e 69 73 68 65 64 0a 3b 3b 20 74 6f 20 furnished.;; to 0220: 64 6f 20 73 6f 2c 20 73 75 62 6a 65 63 74 20 74 do so, subject t 0230: 6f 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 o the following 0240: 63 6f 6e 64 69 74 69 6f 6e 73 3a 0a 3b 3b 20 0a conditions:.;; . 0250: 3b 3b 20 54 68 65 20 61 62 6f 76 65 20 63 6f 70 ;; The above cop 0260: 79 72 69 67 68 74 20 6e 6f 74 69 63 65 20 61 6e yright notice an 0270: 64 20 74 68 69 73 20 70 65 72 6d 69 73 73 69 6f d this permissio 0280: 6e 20 6e 6f 74 69 63 65 20 73 68 61 6c 6c 20 62 n notice shall b 0290: 65 0a 3b 3b 20 69 6e 63 6c 75 64 65 64 20 69 6e e.;; included in 02a0: 20 61 6c 6c 20 63 6f 70 69 65 73 20 6f 72 20 73 all copies or s 02b0: 75 62 73 74 61 6e 74 69 61 6c 20 70 6f 72 74 69 ubstantial porti 02c0: 6f 6e 73 20 6f 66 20 74 68 65 20 53 6f 66 74 77 ons of the Softw 02d0: 61 72 65 2e 0a 3b 3b 20 0a 3b 3b 20 54 48 45 20 are..;; .;; THE 02e0: 53 4f 46 54 57 41 52 45 20 49 53 20 50 52 4f 56 SOFTWARE IS PROV 02f0: 49 44 45 44 20 41 53 49 53 2c 20 57 49 54 48 4f IDED ASIS, WITHO 0300: 55 54 20 57 41 52 52 41 4e 54 59 20 4f 46 20 41 UT WARRANTY OF A 0310: 4e 59 20 4b 49 4e 44 2c 0a 3b 3b 20 45 58 50 52 NY KIND,.;; EXPR 0320: 45 53 53 20 4f 52 20 49 4d 50 4c 49 45 44 2c 20 ESS OR IMPLIED, 0330: 49 4e 43 4c 55 44 49 4e 47 20 42 55 54 20 4e 4f INCLUDING BUT NO 0340: 54 20 4c 49 4d 49 54 45 44 20 54 4f 20 54 48 45 T LIMITED TO THE 0350: 20 57 41 52 52 41 4e 54 49 45 53 20 4f 46 0a 3b WARRANTIES OF.; 0360: 3b 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 ; MERCHANTABILIT 0370: 59 2c 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 Y, FITNESS FOR A 0380: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP 0390: 4f 53 45 20 41 4e 44 0a 3b 3b 20 4e 4f 4e 49 4e OSE AND.;; NONIN 03a0: 46 52 49 4e 47 45 4d 45 4e 54 2e 20 49 4e 20 4e FRINGEMENT. IN N 03b0: 4f 20 45 56 45 4e 54 20 53 48 41 4c 4c 20 54 48 O EVENT SHALL TH 03c0: 45 20 41 55 54 48 4f 52 53 20 4f 52 20 43 4f 50 E AUTHORS OR COP 03d0: 59 52 49 47 48 54 20 48 4f 4c 44 45 52 53 0a 3b YRIGHT HOLDERS.; 03e0: 3b 20 42 45 20 4c 49 41 42 4c 45 20 46 4f 52 20 ; BE LIABLE FOR 03f0: 41 4e 59 20 43 4c 41 49 4d 2c 20 44 41 4d 41 47 ANY CLAIM, DAMAG 0400: 45 53 20 4f 52 20 4f 54 48 45 52 20 4c 49 41 42 ES OR OTHER LIAB 0410: 49 4c 49 54 59 2c 20 57 48 45 54 48 45 52 20 49 ILITY, WHETHER I 0420: 4e 20 41 4e 0a 3b 3b 20 41 43 54 49 4f 4e 20 4f N AN.;; ACTION O 0430: 46 20 43 4f 4e 54 52 41 43 54 2c 20 54 4f 52 54 F CONTRACT, TORT 0440: 20 4f 52 20 4f 54 48 45 52 57 49 53 45 2c 20 41 OR OTHERWISE, A 0450: 52 49 53 49 4e 47 20 46 52 4f 4d 2c 20 4f 55 54 RISING FROM, OUT 0460: 20 4f 46 20 4f 52 20 49 4e 0a 3b 3b 20 43 4f 4e OF OR IN.;; CON 0470: 4e 45 43 54 49 4f 4e 20 57 49 54 48 20 54 48 45 NECTION WITH THE 0480: 20 53 4f 46 54 57 41 52 45 20 4f 52 20 54 48 45 SOFTWARE OR THE 0490: 20 55 53 45 20 4f 52 20 4f 54 48 45 52 20 44 45 USE OR OTHER DE 04a0: 41 4c 49 4e 47 53 20 49 4e 20 54 48 45 0a 3b 3b ALINGS IN THE.;; 04b0: 20 53 4f 46 54 57 41 52 45 2e 0a 0a 28 6d 6f 64 SOFTWARE...(mod 04c0: 75 6c 65 20 73 72 66 69 2d 39 39 2d 70 72 69 6d ule srfi-99-prim 04d0: 69 74 69 76 65 73 0a 20 20 28 25 6d 61 6b 65 2d itives. (%make- 04e0: 72 74 64 20 25 67 65 74 2d 72 74 64 20 72 74 64 rtd %get-rtd rtd 04f0: 3f 20 72 65 63 6f 72 64 3f 0a 20 20 20 25 72 74 ? record?. %rt 0500: 64 2d 6e 61 6d 65 20 25 72 74 64 2d 75 69 64 20 d-name %rtd-uid 0510: 25 72 74 64 2d 63 68 69 6c 64 2d 75 69 64 73 20 %rtd-child-uids 0520: 25 72 74 64 2d 66 69 65 6c 64 73 20 25 72 74 64 %rtd-fields %rtd 0530: 2d 70 61 72 65 6e 74 20 25 72 74 64 2d 70 72 6f -parent %rtd-pro 0540: 70 65 72 74 69 65 73 0a 20 20 20 25 72 74 64 2d perties. %rtd- 0550: 63 68 69 6c 64 2d 75 69 64 3f 0a 20 20 20 25 72 child-uid?. %r 0560: 74 64 2d 63 6f 75 6e 74 2d 66 69 65 6c 64 73 20 td-count-fields 0570: 25 72 74 64 2d 63 6f 75 6e 74 2d 61 6c 6c 2d 66 %rtd-count-all-f 0580: 69 65 6c 64 73 0a 20 20 20 25 72 74 64 2d 66 69 ields. %rtd-fi 0590: 65 6c 64 2d 72 65 66 20 25 72 74 64 2d 66 69 65 eld-ref %rtd-fie 05a0: 6c 64 2d 66 69 6e 64 29 0a 20 20 28 69 6d 70 6f ld-find). (impo 05b0: 72 74 0a 20 20 20 73 63 68 65 6d 65 0a 20 20 20 rt. scheme. 05c0: 28 63 68 69 63 6b 65 6e 20 62 61 73 65 29 0a 20 (chicken base). 05d0: 20 20 28 63 68 69 63 6b 65 6e 20 66 69 78 6e 75 (chicken fixnu 05e0: 6d 29 0a 20 20 20 28 63 68 69 63 6b 65 6e 20 70 m). (chicken p 05f0: 6c 69 73 74 29 0a 20 20 20 28 63 68 69 63 6b 65 list). (chicke 0600: 6e 20 67 63 29 0a 20 20 20 6d 69 73 63 6d 61 63 n gc). miscmac 0610: 72 6f 73 0a 20 20 20 73 72 66 69 2d 36 39 29 0a ros. srfi-69). 0620: 0a 28 64 65 66 69 6e 65 2d 76 61 6c 75 65 73 20 .(define-values 0630: 28 25 6d 61 6b 65 2d 72 74 64 20 25 67 65 74 2d (%make-rtd %get- 0640: 72 74 64 29 0a 20 20 28 6c 65 74 72 65 63 20 28 rtd). (letrec ( 0650: 28 25 6c 69 6e 6b 21 0a 09 20 20 20 20 28 6c 61 (%link!.. (la 0660: 6d 62 64 61 20 28 72 74 64 29 0a 09 20 20 20 20 mbda (rtd).. 0670: 20 20 28 64 6f 20 28 28 72 74 64 20 72 74 64 20 (do ((rtd rtd 0680: 28 25 72 74 64 2d 70 61 72 65 6e 74 20 72 74 64 (%rtd-parent rtd 0690: 29 29 20 28 75 69 64 20 28 25 72 74 64 2d 75 69 )) (uid (%rtd-ui 06a0: 64 20 72 74 64 29 29 29 20 28 28 6e 6f 74 20 72 d rtd))) ((not r 06b0: 74 64 29 29 0a 09 09 28 63 6f 6e 64 0a 09 09 20 td))...(cond... 06c0: 28 28 25 72 74 64 2d 63 68 69 6c 64 2d 75 69 64 ((%rtd-child-uid 06d0: 73 20 72 74 64 29 20 3d 3e 20 28 63 75 74 20 68 s rtd) => (cut h 06e0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 3c ash-table-set! < 06f0: 3e 20 75 69 64 20 23 74 29 29 29 29 29 29 0a 09 > uid #t)))))).. 0700: 20 20 20 28 25 75 6e 6c 69 6e 6b 21 0a 09 20 20 (%unlink!.. 0710: 20 20 28 6c 61 6d 62 64 61 20 28 72 74 64 29 0a (lambda (rtd). 0720: 09 20 20 20 20 20 20 28 64 6f 20 28 28 72 74 64 . (do ((rtd 0730: 20 72 74 64 20 28 25 72 74 64 2d 70 61 72 65 6e rtd (%rtd-paren 0740: 74 20 72 74 64 29 29 20 28 75 69 64 20 28 25 72 t rtd)) (uid (%r 0750: 74 64 2d 75 69 64 20 72 74 64 29 29 29 20 28 28 td-uid rtd))) (( 0760: 6e 6f 74 20 72 74 64 29 29 0a 09 09 28 63 6f 6e not rtd))...(con 0770: 64 0a 09 09 20 28 28 25 72 74 64 2d 63 68 69 6c d... ((%rtd-chil 0780: 64 2d 75 69 64 73 20 72 74 64 29 20 3d 3e 20 28 d-uids rtd) => ( 0790: 63 75 74 20 68 61 73 68 2d 74 61 62 6c 65 2d 64 cut hash-table-d 07a0: 65 6c 65 74 65 21 20 3c 3e 20 75 69 64 29 29 29 elete! <> uid))) 07b0: 29 29 29 0a 09 20 20 20 28 25 6d 61 6b 65 2d 72 ))).. (%make-r 07c0: 74 64 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 td.. (lambda 07d0: 28 6e 61 6d 65 20 75 69 64 20 66 69 65 6c 64 73 (name uid fields 07e0: 20 70 61 72 65 6e 74 20 73 65 61 6c 65 64 3f 20 parent sealed? 07f0: 6f 70 61 71 75 65 3f 29 0a 09 20 20 20 20 20 20 opaque?).. 0800: 28 6c 65 74 20 28 28 72 74 64 20 28 23 23 73 79 (let ((rtd (##sy 0810: 73 23 6d 61 6b 65 2d 73 74 72 75 63 74 75 72 65 s#make-structure 0820: 0a 09 09 09 20 20 27 72 74 64 0a 09 09 09 20 20 .... 'rtd.... 0830: 6e 61 6d 65 20 75 69 64 0a 09 09 09 20 20 28 61 name uid.... (a 0840: 6e 64 20 28 6e 6f 74 20 73 65 61 6c 65 64 3f 29 nd (not sealed?) 0850: 0a 09 09 09 20 20 20 20 20 20 20 28 6d 61 6b 65 .... (make 0860: 2d 68 61 73 68 2d 74 61 62 6c 65 20 23 3a 74 65 -hash-table #:te 0870: 73 74 20 65 71 3f 20 23 3a 68 61 73 68 20 65 71 st eq? #:hash eq 0880: 3f 2d 68 61 73 68 29 29 0a 09 09 09 20 20 66 69 ?-hash)).... fi 0890: 65 6c 64 73 20 70 61 72 65 6e 74 0a 09 09 09 20 elds parent.... 08a0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl 08b0: 65 20 23 3a 74 65 73 74 20 65 71 3f 20 23 3a 68 e #:test eq? #:h 08c0: 61 73 68 20 65 71 3f 2d 68 61 73 68 29 29 29 29 ash eq?-hash)))) 08d0: 0a 09 09 28 73 65 74 2d 66 69 6e 61 6c 69 7a 65 ...(set-finalize 08e0: 72 21 20 72 74 64 20 25 75 6e 6c 69 6e 6b 21 29 r! rtd %unlink!) 08f0: 0a 09 09 28 25 6c 69 6e 6b 21 20 72 74 64 29 0a ...(%link! rtd). 0900: 09 09 28 75 6e 6c 65 73 73 20 6f 70 61 71 75 65 ..(unless opaque 0910: 3f 20 28 70 75 74 21 20 75 69 64 20 27 72 74 64 ? (put! uid 'rtd 0920: 20 72 74 64 29 29 0a 09 09 72 74 64 29 29 29 0a rtd))...rtd))). 0930: 09 20 20 20 28 25 67 65 74 2d 72 74 64 0a 09 20 . (%get-rtd.. 0940: 20 20 20 28 6c 61 6d 62 64 61 20 28 75 69 64 29 (lambda (uid) 0950: 0a 09 20 20 20 20 20 20 28 67 65 74 20 75 69 64 .. (get uid 0960: 20 27 72 74 64 20 23 66 29 29 29 29 0a 20 20 20 'rtd #f)))). 0970: 20 28 76 61 6c 75 65 73 20 25 6d 61 6b 65 2d 72 (values %make-r 0980: 74 64 20 25 67 65 74 2d 72 74 64 29 29 29 0a 20 td %get-rtd))). 0990: 20 0a 28 64 65 66 69 6e 65 20 28 72 74 64 3f 20 .(define (rtd? 09a0: 76 29 20 28 23 23 73 79 73 23 73 74 72 75 63 74 v) (##sys#struct 09b0: 75 72 65 3f 20 76 20 27 72 74 64 29 29 0a 0a 28 ure? v 'rtd))..( 09c0: 64 65 66 69 6e 65 20 28 72 65 63 6f 72 64 3f 20 define (record? 09d0: 76 29 0a 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 v). (and (not ( 09e0: 23 23 73 79 73 23 69 6d 6d 65 64 69 61 74 65 3f ##sys#immediate? 09f0: 20 76 29 29 0a 20 20 20 20 20 20 20 28 23 23 73 v)). (##s 0a00: 79 73 23 67 65 6e 65 72 69 63 2d 73 74 72 75 63 ys#generic-struc 0a10: 74 75 72 65 3f 20 76 29 29 29 0a 0a 28 64 65 66 ture? v)))..(def 0a20: 69 6e 65 20 28 25 72 74 64 2d 6e 61 6d 65 20 72 ine (%rtd-name r 0a30: 74 64 29 20 28 23 23 73 79 73 23 73 6c 6f 74 20 td) (##sys#slot 0a40: 72 74 64 20 31 29 29 0a 28 64 65 66 69 6e 65 20 rtd 1)).(define 0a50: 28 25 72 74 64 2d 75 69 64 20 72 74 64 29 20 28 (%rtd-uid rtd) ( 0a60: 23 23 73 79 73 23 73 6c 6f 74 20 72 74 64 20 32 ##sys#slot rtd 2 0a70: 29 29 0a 28 64 65 66 69 6e 65 20 28 25 72 74 64 )).(define (%rtd 0a80: 2d 63 68 69 6c 64 2d 75 69 64 73 20 72 74 64 29 -child-uids rtd) 0a90: 20 28 23 23 73 79 73 23 73 6c 6f 74 20 72 74 64 (##sys#slot rtd 0aa0: 20 33 29 29 0a 28 64 65 66 69 6e 65 20 28 25 72 3)).(define (%r 0ab0: 74 64 2d 66 69 65 6c 64 73 20 72 74 64 29 20 28 td-fields rtd) ( 0ac0: 23 23 73 79 73 23 73 6c 6f 74 20 72 74 64 20 34 ##sys#slot rtd 4 0ad0: 29 29 0a 28 64 65 66 69 6e 65 20 28 25 72 74 64 )).(define (%rtd 0ae0: 2d 70 61 72 65 6e 74 20 72 74 64 29 20 28 23 23 -parent rtd) (## 0af0: 73 79 73 23 73 6c 6f 74 20 72 74 64 20 35 29 29 sys#slot rtd 5)) 0b00: 0a 28 64 65 66 69 6e 65 20 28 25 72 74 64 2d 70 .(define (%rtd-p 0b10: 72 6f 70 65 72 74 69 65 73 20 72 74 64 29 20 28 roperties rtd) ( 0b20: 23 23 73 79 73 23 73 6c 6f 74 20 72 74 64 20 36 ##sys#slot rtd 6 0b30: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 25 72 74 ))..(define (%rt 0b40: 64 2d 63 68 69 6c 64 2d 75 69 64 3f 20 72 74 64 d-child-uid? rtd 0b50: 20 75 69 64 29 0a 20 20 28 63 6f 6e 64 0a 20 20 uid). (cond. 0b60: 20 28 28 25 72 74 64 2d 63 68 69 6c 64 2d 75 69 ((%rtd-child-ui 0b70: 64 73 20 72 74 64 29 20 3d 3e 20 28 63 75 74 20 ds rtd) => (cut 0b80: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d 0b90: 65 66 61 75 6c 74 20 3c 3e 20 75 69 64 20 23 66 efault <> uid #f 0ba0: 29 29 0a 20 20 20 28 65 6c 73 65 20 28 65 71 3f )). (else (eq? 0bb0: 20 75 69 64 20 28 25 72 74 64 2d 75 69 64 20 72 uid (%rtd-uid r 0bc0: 74 64 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 td)))))..(define 0bd0: 20 28 25 72 74 64 2d 63 6f 75 6e 74 2d 66 69 65 (%rtd-count-fie 0be0: 6c 64 73 20 72 74 64 29 0a 20 20 28 76 65 63 74 lds rtd). (vect 0bf0: 6f 72 2d 6c 65 6e 67 74 68 20 28 25 72 74 64 2d or-length (%rtd- 0c00: 66 69 65 6c 64 73 20 72 74 64 29 29 29 0a 0a 28 fields rtd)))..( 0c10: 64 65 66 69 6e 65 20 28 25 72 74 64 2d 63 6f 75 define (%rtd-cou 0c20: 6e 74 2d 61 6c 6c 2d 66 69 65 6c 64 73 20 72 74 nt-all-fields rt 0c30: 64 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 d). (let loop ( 0c40: 28 72 74 64 20 72 74 64 29 20 28 6e 20 30 29 29 (rtd rtd) (n 0)) 0c50: 0a 20 20 20 20 28 69 66 20 72 74 64 0a 09 28 6c . (if rtd..(l 0c60: 6f 6f 70 20 28 25 72 74 64 2d 70 61 72 65 6e 74 oop (%rtd-parent 0c70: 20 72 74 64 29 20 28 2b 20 6e 20 28 25 72 74 64 rtd) (+ n (%rtd 0c80: 2d 63 6f 75 6e 74 2d 66 69 65 6c 64 73 20 72 74 -count-fields rt 0c90: 64 29 29 29 0a 09 6e 29 29 29 0a 0a 28 64 65 66 d)))..n)))..(def 0ca0: 69 6e 65 20 28 25 72 74 64 2d 66 69 65 6c 64 2d ine (%rtd-field- 0cb0: 72 65 66 20 72 74 64 20 69 29 0a 20 20 28 6c 65 ref rtd i). (le 0cc0: 74 20 28 28 62 61 73 65 20 28 2d 20 28 25 72 74 t ((base (- (%rt 0cd0: 64 2d 63 6f 75 6e 74 2d 61 6c 6c 2d 66 69 65 6c d-count-all-fiel 0ce0: 64 73 20 72 74 64 29 20 28 25 72 74 64 2d 63 6f ds rtd) (%rtd-co 0cf0: 75 6e 74 2d 66 69 65 6c 64 73 20 72 74 64 29 29 unt-fields rtd)) 0d00: 29 29 0a 20 20 20 20 28 69 66 20 28 3e 3d 20 69 )). (if (>= i 0d10: 20 62 61 73 65 29 0a 09 28 76 65 63 74 6f 72 2d base)..(vector- 0d20: 72 65 66 20 28 25 72 74 64 2d 66 69 65 6c 64 73 ref (%rtd-fields 0d30: 20 72 74 64 29 20 28 2d 20 69 20 62 61 73 65 29 rtd) (- i base) 0d40: 29 0a 09 28 25 72 74 64 2d 66 69 65 6c 64 2d 72 )..(%rtd-field-r 0d50: 65 66 20 28 25 72 74 64 2d 70 61 72 65 6e 74 20 ef (%rtd-parent 0d60: 72 74 64 29 20 69 29 29 29 29 0a 0a 28 64 65 66 rtd) i))))..(def 0d70: 69 6e 65 20 28 25 72 74 64 2d 66 69 65 6c 64 2d ine (%rtd-field- 0d80: 66 69 6e 64 20 72 74 64 20 6e 61 6d 65 29 0a 20 find rtd name). 0d90: 20 28 6c 65 74 20 28 28 6e 20 28 25 72 74 64 2d (let ((n (%rtd- 0da0: 63 6f 75 6e 74 2d 61 6c 6c 2d 66 69 65 6c 64 73 count-all-fields 0db0: 20 72 74 64 29 29 29 0a 20 20 20 20 28 6c 65 74 rtd))). (let 0dc0: 20 6c 6f 6f 70 20 28 28 69 20 28 66 78 2d 20 6e loop ((i (fx- n 0dd0: 20 31 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 1))). (if 0de0: 28 6e 65 67 61 74 69 76 65 3f 20 69 29 0a 09 20 (negative? i).. 0df0: 20 28 65 72 72 6f 72 20 22 6e 6f 20 73 75 63 68 (error "no such 0e00: 20 66 69 65 6c 64 20 69 6e 20 72 65 63 6f 72 64 field in record 0e10: 22 20 6e 61 6d 65 20 28 25 72 74 64 2d 6e 61 6d " name (%rtd-nam 0e20: 65 20 72 74 64 29 29 0a 09 20 20 28 6c 65 74 20 e rtd)).. (let 0e30: 28 28 66 69 65 6c 64 20 28 25 72 74 64 2d 66 69 ((field (%rtd-fi 0e40: 65 6c 64 2d 72 65 66 20 72 74 64 20 69 29 29 29 eld-ref rtd i))) 0e50: 0a 09 20 20 20 20 28 69 66 20 28 65 71 3f 20 28 .. (if (eq? ( 0e60: 63 61 64 72 20 66 69 65 6c 64 29 20 6e 61 6d 65 cadr field) name 0e70: 29 0a 09 09 28 61 70 70 6c 79 20 76 61 6c 75 65 )...(apply value 0e80: 73 20 69 20 66 69 65 6c 64 29 0a 09 09 28 6c 6f s i field)...(lo 0e90: 6f 70 20 28 66 78 2d 20 69 20 31 29 29 29 29 29 op (fx- i 1))))) 0ea0: 29 29 29 0a 0a 29 0a 0a 28 6d 6f 64 75 6c 65 20 )))..)..(module 0eb0: 73 72 66 69 2d 39 39 2d 72 65 63 6f 72 64 73 2d srfi-99-records- 0ec0: 70 72 6f 63 65 64 75 72 61 6c 0a 20 20 28 6d 61 procedural. (ma 0ed0: 6b 65 2d 72 74 64 20 72 74 64 3f 0a 20 20 20 72 ke-rtd rtd?. r 0ee0: 74 64 2d 63 6f 6e 73 74 72 75 63 74 6f 72 20 72 td-constructor r 0ef0: 74 64 2d 70 72 65 64 69 63 61 74 65 20 72 74 64 td-predicate rtd 0f00: 2d 61 63 63 65 73 73 6f 72 20 72 74 64 2d 6d 75 -accessor rtd-mu 0f10: 74 61 74 6f 72 29 0a 20 20 28 69 6d 70 6f 72 74 tator). (import 0f20: 0a 20 20 20 73 63 68 65 6d 65 20 28 63 68 69 63 . scheme (chic 0f30: 6b 65 6e 20 62 61 73 65 29 20 28 63 68 69 63 6b ken base) (chick 0f40: 65 6e 20 66 69 78 6e 75 6d 29 0a 20 20 20 6d 69 en fixnum). mi 0f50: 73 63 6d 61 63 72 6f 73 0a 20 20 20 73 72 66 69 scmacros. srfi 0f60: 2d 31 20 73 72 66 69 2d 36 39 20 73 72 66 69 2d -1 srfi-69 srfi- 0f70: 39 39 2d 70 72 69 6d 69 74 69 76 65 73 29 0a 0a 99-primitives).. 0f80: 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 72 74 (define (make-rt 0f90: 64 20 6e 61 6d 65 20 66 69 65 6c 64 73 20 2e 20 d name fields . 0fa0: 61 72 67 73 29 0a 20 20 28 6c 65 74 2d 76 61 6c args). (let-val 0fb0: 75 65 73 20 28 28 28 66 69 65 6c 64 73 29 0a 09 ues (((fields).. 0fc0: 09 28 6c 69 73 74 2d 3e 76 65 63 74 6f 72 0a 09 .(list->vector.. 0fd0: 09 20 28 6d 61 70 0a 09 09 20 20 28 6c 61 6d 62 . (map... (lamb 0fe0: 64 61 20 28 66 69 65 6c 64 29 0a 09 09 20 20 20 da (field)... 0ff0: 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 28 28 (cond... (( 1000: 73 79 6d 62 6f 6c 3f 20 66 69 65 6c 64 29 0a 09 symbol? field).. 1010: 09 20 20 20 20 20 20 28 6c 69 73 74 20 27 69 6d . (list 'im 1020: 6d 75 74 61 62 6c 65 20 66 69 65 6c 64 29 29 0a mutable field)). 1030: 09 09 20 20 20 20 20 28 28 61 6e 64 20 28 70 61 .. ((and (pa 1040: 69 72 3f 20 66 69 65 6c 64 29 20 28 73 79 6d 62 ir? field) (symb 1050: 6f 6c 3f 20 28 63 61 72 20 66 69 65 6c 64 29 29 ol? (car field)) 1060: 0a 09 09 09 20 20 20 28 6e 75 6c 6c 3f 20 28 63 .... (null? (c 1070: 64 72 20 66 69 65 6c 64 29 29 29 0a 09 09 20 20 dr field)))... 1080: 20 20 20 20 28 63 6f 6e 73 20 27 6d 75 74 61 62 (cons 'mutab 1090: 6c 65 20 66 69 65 6c 64 29 29 0a 09 09 20 20 20 le field))... 10a0: 20 20 28 28 61 6e 64 20 28 70 61 69 72 3f 20 66 ((and (pair? f 10b0: 69 65 6c 64 29 20 28 6d 65 6d 71 20 28 63 61 72 ield) (memq (car 10c0: 20 66 69 65 6c 64 29 20 27 28 6d 75 74 61 62 6c field) '(mutabl 10d0: 65 20 69 6d 6d 75 74 61 62 6c 65 29 29 0a 09 09 e immutable))... 10e0: 09 20 20 20 28 70 61 69 72 3f 20 28 63 64 72 20 . (pair? (cdr 10f0: 66 69 65 6c 64 29 29 20 28 73 79 6d 62 6f 6c 3f field)) (symbol? 1100: 20 28 63 61 64 72 20 66 69 65 6c 64 29 29 0a 09 (cadr field)).. 1110: 09 09 20 20 20 28 6e 75 6c 6c 3f 20 28 63 64 64 .. (null? (cdd 1120: 72 20 66 69 65 6c 64 29 29 29 0a 09 09 20 20 20 r field)))... 1130: 20 20 20 66 69 65 6c 64 29 0a 09 09 20 20 20 20 field)... 1140: 20 28 65 6c 73 65 0a 09 09 20 20 20 20 20 20 28 (else... ( 1150: 65 72 72 6f 72 20 27 6d 61 6b 65 2d 72 74 64 20 error 'make-rtd 1160: 22 62 61 64 20 66 69 65 6c 64 20 73 70 65 63 69 "bad field speci 1170: 66 69 63 61 74 69 6f 6e 22 20 66 69 65 6c 64 29 fication" field) 1180: 29 29 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d )))... (vector- 1190: 3e 6c 69 73 74 20 66 69 65 6c 64 73 29 29 29 29 >list fields)))) 11a0: 0a 09 20 20 20 20 20 20 20 28 28 70 61 72 65 6e .. ((paren 11b0: 74 20 75 69 64 20 73 65 61 6c 65 64 3f 20 6f 70 t uid sealed? op 11c0: 61 71 75 65 3f 20 70 72 6f 70 65 72 74 69 65 73 aque? properties 11d0: 29 0a 09 09 28 6c 65 74 20 6e 65 78 74 20 28 28 )...(let next (( 11e0: 61 72 67 73 20 61 72 67 73 29 0a 09 09 09 20 20 args args).... 11f0: 20 28 70 61 72 65 6e 74 20 23 66 29 20 28 75 69 (parent #f) (ui 1200: 64 20 23 66 29 20 28 73 65 61 6c 65 64 3f 20 23 d #f) (sealed? # 1210: 66 29 20 28 6f 70 61 71 75 65 3f 20 23 66 29 0a f) (opaque? #f). 1220: 09 09 09 20 20 20 28 70 72 6f 70 65 72 74 69 65 ... (propertie 1230: 73 20 27 28 29 29 29 0a 09 09 20 20 28 69 66 20 s '()))... (if 1240: 28 6e 75 6c 6c 3f 20 61 72 67 73 29 0a 09 09 20 (null? args)... 1250: 20 20 20 20 20 28 76 61 6c 75 65 73 20 70 61 72 (values par 1260: 65 6e 74 20 75 69 64 20 73 65 61 6c 65 64 3f 20 ent uid sealed? 1270: 6f 70 61 71 75 65 3f 20 70 72 6f 70 65 72 74 69 opaque? properti 1280: 65 73 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 es)... (let 1290: 2d 76 61 6c 75 65 73 20 28 28 28 61 72 67 30 20 -values (((arg0 12a0: 61 72 67 73 29 20 28 63 61 72 2b 63 64 72 20 61 args) (car+cdr a 12b0: 72 67 73 29 29 29 0a 09 09 09 28 63 61 73 65 20 rgs)))....(case 12c0: 61 72 67 30 0a 09 09 09 20 20 28 28 23 3a 70 61 arg0.... ((#:pa 12d0: 72 65 6e 74 29 0a 09 09 09 20 20 20 28 6e 65 78 rent).... (nex 12e0: 74 20 28 63 64 72 20 61 72 67 73 29 0a 09 09 09 t (cdr args).... 12f0: 09 20 28 63 61 72 20 61 72 67 73 29 20 75 69 64 . (car args) uid 1300: 20 73 65 61 6c 65 64 3f 20 6f 70 61 71 75 65 3f sealed? opaque? 1310: 20 70 72 6f 70 65 72 74 69 65 73 29 29 0a 09 09 properties))... 1320: 09 20 20 28 28 23 3a 75 69 64 29 0a 09 09 09 20 . ((#:uid).... 1330: 20 20 28 6e 65 78 74 20 28 63 64 72 20 61 72 67 (next (cdr arg 1340: 73 29 0a 09 09 09 09 20 70 61 72 65 6e 74 20 28 s)..... parent ( 1350: 63 61 72 20 61 72 67 73 29 20 73 65 61 6c 65 64 car args) sealed 1360: 3f 20 6f 70 61 71 75 65 3f 20 70 72 6f 70 65 72 ? opaque? proper 1370: 74 69 65 73 29 29 0a 09 09 09 20 20 28 28 23 3a ties)).... ((#: 1380: 73 65 61 6c 65 64 29 0a 09 09 09 20 20 20 28 6e sealed).... (n 1390: 65 78 74 20 28 63 64 72 20 61 72 67 73 29 0a 09 ext (cdr args).. 13a0: 09 09 09 20 70 61 72 65 6e 74 20 75 69 64 20 28 ... parent uid ( 13b0: 63 61 72 20 61 72 67 73 29 20 6f 70 61 71 75 65 car args) opaque 13c0: 3f 20 70 72 6f 70 65 72 74 69 65 73 29 29 0a 09 ? properties)).. 13d0: 09 09 20 20 28 28 23 3a 6f 70 61 71 75 65 29 0a .. ((#:opaque). 13e0: 09 09 09 20 20 20 28 6e 65 78 74 20 28 63 64 72 ... (next (cdr 13f0: 20 61 72 67 73 29 0a 09 09 09 09 20 70 61 72 65 args)..... pare 1400: 6e 74 20 75 69 64 20 73 65 61 6c 65 64 3f 20 28 nt uid sealed? ( 1410: 63 61 72 20 61 72 67 73 29 20 70 72 6f 70 65 72 car args) proper 1420: 74 69 65 73 29 29 0a 09 09 09 20 20 28 28 23 3a ties)).... ((#: 1430: 70 72 6f 70 65 72 74 79 29 0a 09 09 09 20 20 20 property).... 1440: 28 6e 65 78 74 20 28 63 64 64 72 20 61 72 67 73 (next (cddr args 1450: 29 0a 09 09 09 09 20 70 61 72 65 6e 74 20 75 69 )..... parent ui 1460: 64 20 73 65 61 6c 65 64 3f 20 6f 70 61 71 75 65 d sealed? opaque 1470: 3f 0a 09 09 09 09 20 28 63 6f 6e 73 20 28 63 6f ?..... (cons (co 1480: 6e 73 20 28 63 61 72 20 61 72 67 73 29 20 28 63 ns (car args) (c 1490: 61 64 72 20 61 72 67 73 29 29 0a 09 09 09 09 20 adr args))..... 14a0: 20 20 20 20 20 20 70 72 6f 70 65 72 74 69 65 73 properties 14b0: 29 29 29 0a 09 09 09 20 20 28 65 6c 73 65 0a 09 ))).... (else.. 14c0: 09 09 20 20 20 28 6e 65 78 74 20 61 72 67 73 0a .. (next args. 14d0: 09 09 09 09 20 61 72 67 30 20 75 69 64 20 73 65 .... arg0 uid se 14e0: 61 6c 65 64 3f 20 6f 70 61 71 75 65 3f 20 70 72 aled? opaque? pr 14f0: 6f 70 65 72 74 69 65 73 29 29 29 29 29 29 29 29 operties)))))))) 1500: 0a 20 20 20 20 28 23 23 73 79 73 23 63 68 65 63 . (##sys#chec 1510: 6b 2d 73 79 6d 62 6f 6c 20 6e 61 6d 65 20 27 6d k-symbol name 'm 1520: 61 6b 65 2d 72 74 64 29 0a 20 20 20 20 28 23 23 ake-rtd). (## 1530: 73 79 73 23 63 68 65 63 6b 2d 76 65 63 74 6f 72 sys#check-vector 1540: 20 66 69 65 6c 64 73 20 27 6d 61 6b 65 2d 72 74 fields 'make-rt 1550: 64 29 0a 20 20 20 20 28 77 68 65 6e 20 70 61 72 d). (when par 1560: 65 6e 74 0a 20 20 20 20 20 20 28 23 23 73 79 73 ent. (##sys 1570: 23 63 68 65 63 6b 2d 73 74 72 75 63 74 75 72 65 #check-structure 1580: 20 70 61 72 65 6e 74 20 27 72 74 64 29 0a 20 20 parent 'rtd). 1590: 20 20 20 20 28 65 6e 73 75 72 65 20 25 72 74 64 (ensure %rtd 15a0: 2d 63 68 69 6c 64 2d 75 69 64 73 20 70 61 72 65 -child-uids pare 15b0: 6e 74 0a 09 20 20 20 20 20 20 27 6d 61 6b 65 2d nt.. 'make- 15c0: 72 74 64 20 22 65 78 70 65 63 74 65 64 20 75 6e rtd "expected un 15d0: 73 65 61 6c 65 64 20 70 61 72 65 6e 74 22 20 70 sealed parent" p 15e0: 61 72 65 6e 74 29 29 0a 20 20 20 20 28 77 68 65 arent)). (whe 15f0: 6e 20 75 69 64 0a 20 20 20 20 20 20 28 23 23 73 n uid. (##s 1600: 79 73 23 63 68 65 63 6b 2d 73 79 6d 62 6f 6c 20 ys#check-symbol 1610: 75 69 64 20 27 6d 61 6b 65 2d 72 74 64 29 29 0a uid 'make-rtd)). 1620: 20 20 20 20 28 6c 65 74 20 28 28 72 74 64 20 28 (let ((rtd ( 1630: 25 6d 61 6b 65 2d 72 74 64 20 6e 61 6d 65 20 28 %make-rtd name ( 1640: 6f 72 20 75 69 64 20 28 67 65 6e 73 79 6d 20 6e or uid (gensym n 1650: 61 6d 65 29 29 20 66 69 65 6c 64 73 0a 09 09 09 ame)) fields.... 1660: 20 20 70 61 72 65 6e 74 20 73 65 61 6c 65 64 3f parent sealed? 1670: 20 6f 70 61 71 75 65 3f 29 29 29 0a 20 20 20 20 opaque?))). 1680: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each. 1690: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 74 70 2b (lambda (rtp+ 16a0: 61 63 63 65 73 73 6f 72 29 0a 09 20 28 6c 65 74 accessor).. (let 16b0: 2d 76 61 6c 75 65 73 20 28 28 28 72 74 70 20 61 -values (((rtp a 16c0: 63 63 65 73 73 6f 72 29 20 28 63 61 72 2b 63 64 ccessor) (car+cd 16d0: 72 20 72 74 70 2b 61 63 63 65 73 73 6f 72 29 29 r rtp+accessor)) 16e0: 29 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ).. (hash-tabl 16f0: 65 2d 73 65 74 21 0a 09 20 20 20 20 28 25 72 74 e-set!.. (%rt 1700: 64 2d 70 72 6f 70 65 72 74 69 65 73 20 72 74 64 d-properties rtd 1710: 29 20 72 74 70 0a 09 20 20 20 20 28 63 6f 6e 64 ) rtp.. (cond 1720: 0a 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 .. ((procedu 1730: 72 65 3f 20 61 63 63 65 73 73 6f 72 29 0a 09 20 re? accessor).. 1740: 20 20 20 20 20 61 63 63 65 73 73 6f 72 29 0a 09 accessor).. 1750: 20 20 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 61 ((symbol? a 1760: 63 63 65 73 73 6f 72 29 0a 09 20 20 20 20 20 20 ccessor).. 1770: 28 72 74 64 2d 61 63 63 65 73 73 6f 72 20 72 74 (rtd-accessor rt 1780: 64 20 61 63 63 65 73 73 6f 72 29 29 0a 09 20 20 d accessor)).. 1790: 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 (else.. 17a0: 28 63 6f 6e 73 74 61 6e 74 6c 79 20 61 63 63 65 (constantly acce 17b0: 73 73 6f 72 29 29 29 29 29 29 0a 20 20 20 20 20 ssor)))))). 17c0: 20 20 70 72 6f 70 65 72 74 69 65 73 29 0a 20 20 properties). 17d0: 20 20 20 20 72 74 64 29 29 29 0a 0a 28 64 65 66 rtd)))..(def 17e0: 69 6e 65 20 28 72 74 64 2d 63 6f 6e 73 74 72 75 ine (rtd-constru 17f0: 63 74 6f 72 20 72 74 64 20 23 21 6f 70 74 69 6f ctor rtd #!optio 1800: 6e 61 6c 20 66 69 65 6c 64 73 29 0a 20 20 28 23 nal fields). (# 1810: 23 73 79 73 23 63 68 65 63 6b 2d 73 74 72 75 63 #sys#check-struc 1820: 74 75 72 65 20 72 74 64 20 27 72 74 64 20 27 72 ture rtd 'rtd 'r 1830: 74 64 2d 63 6f 6e 73 74 72 75 63 74 6f 72 29 0a td-constructor). 1840: 20 20 28 6c 65 74 2a 20 28 28 6e 20 28 25 72 74 (let* ((n (%rt 1850: 64 2d 63 6f 75 6e 74 2d 61 6c 6c 2d 66 69 65 6c d-count-all-fiel 1860: 64 73 20 72 74 64 29 29 0a 09 20 28 69 73 20 28 ds rtd)).. (is ( 1870: 69 66 20 66 69 65 6c 64 73 0a 09 09 20 28 6d 61 if fields... (ma 1880: 70 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 28 6e p... (lambda (n 1890: 61 6d 65 29 0a 09 09 20 20 20 20 28 6c 65 74 2d ame)... (let- 18a0: 76 61 6c 75 65 73 20 28 28 28 69 20 61 63 63 65 values (((i acce 18b0: 73 73 20 66 69 65 6c 64 29 20 28 25 72 74 64 2d ss field) (%rtd- 18c0: 66 69 65 6c 64 2d 66 69 6e 64 20 72 74 64 20 6e field-find rtd n 18d0: 61 6d 65 29 29 29 0a 09 09 20 20 20 20 20 20 28 ame)))... ( 18e0: 66 78 2b 20 69 20 31 29 29 29 0a 09 09 20 20 28 fx+ i 1)))... ( 18f0: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 66 69 65 vector->list fie 1900: 6c 64 73 29 29 0a 09 09 20 28 69 6f 74 61 20 6e lds))... (iota n 1910: 20 31 29 29 29 29 0a 20 20 20 20 28 6c 61 6d 62 1)))). (lamb 1920: 64 61 20 76 73 0a 20 20 20 20 20 20 28 75 6e 6c da vs. (unl 1930: 65 73 73 20 28 3d 20 28 6c 65 6e 67 74 68 20 76 ess (= (length v 1940: 73 29 20 28 6c 65 6e 67 74 68 20 69 73 29 29 0a s) (length is)). 1950: 09 28 23 23 73 79 73 23 73 69 67 6e 61 6c 2d 68 .(##sys#signal-h 1960: 6f 6f 6b 0a 09 20 23 3a 61 72 69 74 79 2d 65 72 ook.. #:arity-er 1970: 72 6f 72 0a 09 20 28 73 74 72 69 6e 67 2d 61 70 ror.. (string-ap 1980: 70 65 6e 64 0a 09 20 20 22 62 61 64 20 61 72 67 pend.. "bad arg 1990: 75 6d 65 6e 74 20 63 6f 75 6e 74 20 2d 20 72 65 ument count - re 19a0: 63 65 69 76 65 64 20 22 20 28 6e 75 6d 62 65 72 ceived " (number 19b0: 2d 3e 73 74 72 69 6e 67 20 28 6c 65 6e 67 74 68 ->string (length 19c0: 20 76 73 29 29 0a 09 20 20 22 20 62 75 74 20 65 vs)).. " but e 19d0: 78 70 65 63 74 65 64 20 22 20 28 6e 75 6d 62 65 xpected " (numbe 19e0: 72 2d 3e 73 74 72 69 6e 67 20 28 6c 65 6e 67 74 r->string (lengt 19f0: 68 20 69 73 29 29 29 29 29 0a 20 20 20 20 20 20 h is))))). 1a00: 28 6c 65 74 20 28 28 72 20 28 23 23 73 79 73 23 (let ((r (##sys# 1a10: 61 6c 6c 6f 63 61 74 65 2d 76 65 63 74 6f 72 20 allocate-vector 1a20: 28 66 78 2b 20 6e 20 31 29 20 23 66 20 28 76 6f (fx+ n 1) #f (vo 1a30: 69 64 29 20 23 66 29 29 29 0a 09 28 23 23 73 79 id) #f)))..(##sy 1a40: 73 23 73 65 74 73 6c 6f 74 20 72 20 30 20 28 25 s#setslot r 0 (% 1a50: 72 74 64 2d 75 69 64 20 72 74 64 29 29 0a 09 28 rtd-uid rtd))..( 1a60: 23 23 63 6f 72 65 23 69 6e 6c 69 6e 65 20 22 43 ##core#inline "C 1a70: 5f 76 65 63 74 6f 72 5f 74 6f 5f 73 74 72 75 63 _vector_to_struc 1a80: 74 75 72 65 22 20 72 29 0a 09 28 66 6f 72 2d 65 ture" r)..(for-e 1a90: 61 63 68 20 28 63 75 74 20 23 23 73 79 73 23 73 ach (cut ##sys#s 1aa0: 65 74 73 6c 6f 74 20 72 20 3c 3e 20 3c 3e 29 20 etslot r <> <>) 1ab0: 69 73 20 76 73 29 0a 09 72 29 29 29 29 0a 0a 28 is vs)..r))))..( 1ac0: 64 65 66 69 6e 65 20 28 25 72 74 64 2d 70 72 65 define (%rtd-pre 1ad0: 64 69 63 61 74 65 20 72 74 64 29 0a 20 20 28 6c dicate rtd). (l 1ae0: 61 6d 62 64 61 20 28 76 29 0a 20 20 20 20 28 61 ambda (v). (a 1af0: 6e 64 20 28 72 65 63 6f 72 64 3f 20 76 29 0a 09 nd (record? v).. 1b00: 20 28 25 72 74 64 2d 63 68 69 6c 64 2d 75 69 64 (%rtd-child-uid 1b10: 3f 20 72 74 64 20 28 23 23 73 79 73 23 73 6c 6f ? rtd (##sys#slo 1b20: 74 20 76 20 30 29 29 29 29 29 0a 0a 28 64 65 66 t v 0)))))..(def 1b30: 69 6e 65 20 28 72 74 64 2d 70 72 65 64 69 63 61 ine (rtd-predica 1b40: 74 65 20 72 74 64 29 0a 20 20 28 23 23 73 79 73 te rtd). (##sys 1b50: 23 63 68 65 63 6b 2d 73 74 72 75 63 74 75 72 65 #check-structure 1b60: 20 72 74 64 20 27 72 74 64 20 27 72 74 64 2d 70 rtd 'rtd 'rtd-p 1b70: 72 65 64 69 63 61 74 65 29 0a 20 20 28 25 72 74 redicate). (%rt 1b80: 64 2d 70 72 65 64 69 63 61 74 65 20 72 74 64 29 d-predicate rtd) 1b90: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 74 64 2d )..(define (rtd- 1ba0: 61 63 63 65 73 73 6f 72 20 72 74 64 20 6e 61 6d accessor rtd nam 1bb0: 65 29 0a 20 20 28 23 23 73 79 73 23 63 68 65 63 e). (##sys#chec 1bc0: 6b 2d 73 74 72 75 63 74 75 72 65 20 72 74 64 20 k-structure rtd 1bd0: 27 72 74 64 20 27 72 74 64 2d 61 63 63 65 73 73 'rtd 'rtd-access 1be0: 6f 72 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 or). (let-value 1bf0: 73 20 28 28 28 69 6e 73 74 61 6e 63 65 3f 29 20 s (((instance?) 1c00: 28 25 72 74 64 2d 70 72 65 64 69 63 61 74 65 20 (%rtd-predicate 1c10: 72 74 64 29 29 0a 09 20 20 20 20 20 20 20 28 28 rtd)).. (( 1c20: 69 20 61 63 63 65 73 73 20 66 69 65 6c 64 29 20 i access field) 1c30: 28 25 72 74 64 2d 66 69 65 6c 64 2d 66 69 6e 64 (%rtd-field-find 1c40: 20 72 74 64 20 6e 61 6d 65 29 29 29 0a 20 20 20 rtd name))). 1c50: 20 28 73 65 74 21 20 69 20 28 66 78 2b 20 69 20 (set! i (fx+ i 1c60: 31 29 29 0a 20 20 20 20 28 28 69 66 20 28 65 71 1)). ((if (eq 1c70: 3f 20 61 63 63 65 73 73 20 27 6d 75 74 61 62 6c ? access 'mutabl 1c80: 65 29 0a 09 20 28 63 75 74 20 67 65 74 74 65 72 e).. (cut getter 1c90: 2d 77 69 74 68 2d 73 65 74 74 65 72 20 3c 3e 0a -with-setter <>. 1ca0: 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda ( 1cb0: 72 20 76 29 0a 09 09 28 65 6e 73 75 72 65 20 69 r v)...(ensure i 1cc0: 6e 73 74 61 6e 63 65 3f 20 72 29 0a 09 09 28 23 nstance? r)...(# 1cd0: 23 73 79 73 23 73 65 74 73 6c 6f 74 20 72 20 69 #sys#setslot r i 1ce0: 20 76 29 29 29 0a 09 20 69 64 65 6e 74 69 74 79 v))).. identity 1cf0: 29 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 ). (lambda ( 1d00: 72 29 0a 20 20 20 20 20 20 20 28 65 6e 73 75 72 r). (ensur 1d10: 65 20 69 6e 73 74 61 6e 63 65 3f 20 72 29 0a 20 e instance? r). 1d20: 20 20 20 20 20 20 28 23 23 73 79 73 23 73 6c 6f (##sys#slo 1d30: 74 20 72 20 69 29 29 29 29 29 0a 0a 28 64 65 66 t r i)))))..(def 1d40: 69 6e 65 20 28 72 74 64 2d 6d 75 74 61 74 6f 72 ine (rtd-mutator 1d50: 20 72 74 64 20 6e 61 6d 65 29 0a 20 20 28 23 23 rtd name). (## 1d60: 73 79 73 23 63 68 65 63 6b 2d 73 74 72 75 63 74 sys#check-struct 1d70: 75 72 65 20 72 74 64 20 27 72 74 64 20 27 72 74 ure rtd 'rtd 'rt 1d80: 64 2d 61 63 63 65 73 73 6f 72 29 0a 20 20 28 23 d-accessor). (# 1d90: 23 73 79 73 23 63 68 65 63 6b 2d 73 74 72 75 63 #sys#check-struc 1da0: 74 75 72 65 20 72 74 64 20 27 72 74 64 20 27 72 ture rtd 'rtd 'r 1db0: 74 64 2d 61 63 63 65 73 73 6f 72 29 0a 20 20 28 td-accessor). ( 1dc0: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e let-values (((in 1dd0: 73 74 61 6e 63 65 3f 29 20 28 25 72 74 64 2d 70 stance?) (%rtd-p 1de0: 72 65 64 69 63 61 74 65 20 72 74 64 29 29 0a 09 redicate rtd)).. 1df0: 20 20 20 20 20 20 20 28 28 69 20 61 63 63 65 73 ((i acces 1e00: 73 20 66 69 65 6c 64 29 20 28 25 72 74 64 2d 66 s field) (%rtd-f 1e10: 69 65 6c 64 2d 66 69 6e 64 20 72 74 64 20 6e 61 ield-find rtd na 1e20: 6d 65 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 me))). (set! 1e30: 69 20 28 66 78 2b 20 69 20 31 29 29 0a 20 20 20 i (fx+ i 1)). 1e40: 20 28 61 6e 64 20 28 65 71 3f 20 61 63 63 65 73 (and (eq? acces 1e50: 73 20 27 6d 75 74 61 62 6c 65 29 0a 09 20 28 6c s 'mutable).. (l 1e60: 61 6d 62 64 61 20 28 72 20 76 29 0a 09 20 20 20 ambda (r v).. 1e70: 28 65 6e 73 75 72 65 20 69 6e 73 74 61 6e 63 65 (ensure instance 1e80: 3f 20 72 29 0a 09 20 20 20 28 23 23 73 79 73 23 ? r).. (##sys# 1e90: 73 65 74 73 6c 6f 74 20 72 20 69 20 76 29 29 29 setslot r i v))) 1ea0: 29 29 0a 0a 29 0a 0a 28 6d 6f 64 75 6c 65 20 73 ))..)..(module s 1eb0: 72 66 69 2d 39 39 2d 72 65 63 6f 72 64 73 2d 69 rfi-99-records-i 1ec0: 6e 73 70 65 63 74 69 6f 6e 0a 20 20 28 72 65 63 nspection. (rec 1ed0: 6f 72 64 3f 20 72 65 63 6f 72 64 2d 72 74 64 0a ord? record-rtd. 1ee0: 20 20 20 72 74 64 2d 6e 61 6d 65 20 72 74 64 2d rtd-name rtd- 1ef0: 75 69 64 20 72 74 64 2d 73 65 61 6c 65 64 3f 20 uid rtd-sealed? 1f00: 72 74 64 2d 6f 70 61 71 75 65 3f 20 72 74 64 2d rtd-opaque? rtd- 1f10: 70 61 72 65 6e 74 0a 20 20 20 72 74 64 2d 66 69 parent. rtd-fi 1f20: 65 6c 64 2d 6e 61 6d 65 73 20 72 74 64 2d 61 6c eld-names rtd-al 1f30: 6c 2d 66 69 65 6c 64 2d 6e 61 6d 65 73 20 72 74 l-field-names rt 1f40: 64 2d 66 69 65 6c 64 2d 6d 75 74 61 62 6c 65 3f d-field-mutable? 1f50: 0a 20 20 20 6d 61 6b 65 2d 72 74 70 20 72 74 64 . make-rtp rtd 1f60: 2d 70 72 6f 70 65 72 74 69 65 73 20 72 74 64 2d -properties rtd- 1f70: 61 6c 6c 2d 70 72 6f 70 65 72 74 69 65 73 29 0a all-properties). 1f80: 20 20 28 69 6d 70 6f 72 74 0a 20 20 20 73 63 68 (import. sch 1f90: 65 6d 65 20 28 63 68 69 63 6b 65 6e 20 62 61 73 eme (chicken bas 1fa0: 65 29 20 28 63 68 69 63 6b 65 6e 20 66 69 78 6e e) (chicken fixn 1fb0: 75 6d 29 0a 20 20 20 73 72 66 69 2d 31 20 73 72 um). srfi-1 sr 1fc0: 66 69 2d 36 39 20 73 72 66 69 2d 39 39 2d 70 72 fi-69 srfi-99-pr 1fd0: 69 6d 69 74 69 76 65 73 20 73 72 66 69 2d 39 39 imitives srfi-99 1fe0: 2d 72 65 63 6f 72 64 73 2d 70 72 6f 63 65 64 75 -records-procedu 1ff0: 72 61 6c 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ral)..(define (r 2000: 65 63 6f 72 64 2d 72 74 64 20 76 29 0a 20 20 28 ecord-rtd v). ( 2010: 61 6e 64 20 28 72 65 63 6f 72 64 3f 20 76 29 0a and (record? v). 2020: 20 20 20 20 20 20 20 28 25 67 65 74 2d 72 74 64 (%get-rtd 2030: 20 28 23 23 73 79 73 23 73 6c 6f 74 20 76 20 30 (##sys#slot v 0 2040: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ))))..(define (r 2050: 74 64 2d 6e 61 6d 65 20 72 74 64 29 0a 20 20 28 td-name rtd). ( 2060: 23 23 73 79 73 23 63 68 65 63 6b 2d 73 74 72 75 ##sys#check-stru 2070: 63 74 75 72 65 20 72 74 64 20 27 72 74 64 20 27 cture rtd 'rtd ' 2080: 72 74 64 2d 6e 61 6d 65 29 0a 20 20 28 25 72 74 rtd-name). (%rt 2090: 64 2d 6e 61 6d 65 20 72 74 64 29 29 0a 0a 28 64 d-name rtd))..(d 20a0: 65 66 69 6e 65 20 28 72 74 64 2d 75 69 64 20 72 efine (rtd-uid r 20b0: 74 64 29 0a 20 20 28 23 23 73 79 73 23 63 68 65 td). (##sys#che 20c0: 63 6b 2d 73 74 72 75 63 74 75 72 65 20 72 74 64 ck-structure rtd 20d0: 20 27 72 74 64 20 27 72 74 64 2d 75 69 64 29 0a 'rtd 'rtd-uid). 20e0: 20 20 28 25 72 74 64 2d 75 69 64 20 72 74 64 29 (%rtd-uid rtd) 20f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 74 64 2d )..(define (rtd- 2100: 73 65 61 6c 65 64 3f 20 72 74 64 29 0a 20 20 28 sealed? rtd). ( 2110: 23 23 73 79 73 23 63 68 65 63 6b 2d 73 74 72 75 ##sys#check-stru 2120: 63 74 75 72 65 20 72 74 64 20 27 72 74 64 20 27 cture rtd 'rtd ' 2130: 72 74 64 2d 73 65 61 6c 65 64 3f 29 0a 20 20 28 rtd-sealed?). ( 2140: 6e 6f 74 20 28 25 72 74 64 2d 63 68 69 6c 64 2d not (%rtd-child- 2150: 75 69 64 73 20 72 74 64 29 29 29 0a 0a 28 64 65 uids rtd)))..(de 2160: 66 69 6e 65 20 28 72 74 64 2d 6f 70 61 71 75 65 fine (rtd-opaque 2170: 3f 20 72 74 64 29 0a 20 20 28 23 23 73 79 73 23 ? rtd). (##sys# 2180: 63 68 65 63 6b 2d 73 74 72 75 63 74 75 72 65 20 check-structure 2190: 72 74 64 20 27 72 74 64 20 27 72 74 64 2d 6f 70 rtd 'rtd 'rtd-op 21a0: 61 71 75 65 3f 29 0a 20 20 28 6e 6f 74 20 28 65 aque?). (not (e 21b0: 71 3f 20 28 25 67 65 74 2d 72 74 64 20 28 25 72 q? (%get-rtd (%r 21c0: 74 64 2d 75 69 64 20 72 74 64 29 29 20 72 74 64 td-uid rtd)) rtd 21d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 74 )))..(define (rt 21e0: 64 2d 70 61 72 65 6e 74 20 72 74 64 29 0a 20 20 d-parent rtd). 21f0: 28 23 23 73 79 73 23 63 68 65 63 6b 2d 73 74 72 (##sys#check-str 2200: 75 63 74 75 72 65 20 72 74 64 20 27 72 74 64 20 ucture rtd 'rtd 2210: 27 72 74 64 2d 70 61 72 65 6e 74 29 0a 20 20 28 'rtd-parent). ( 2220: 25 72 74 64 2d 70 61 72 65 6e 74 20 72 74 64 29 %rtd-parent rtd) 2230: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 74 64 2d )..(define (rtd- 2240: 66 69 65 6c 64 2d 6e 61 6d 65 73 20 72 74 64 29 field-names rtd) 2250: 0a 20 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d . (##sys#check- 2260: 73 74 72 75 63 74 75 72 65 20 72 74 64 20 27 72 structure rtd 'r 2270: 74 64 20 27 72 74 64 2d 66 69 65 6c 64 2d 6e 61 td 'rtd-field-na 2280: 6d 65 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6e mes). (let* ((n 2290: 20 28 25 72 74 64 2d 63 6f 75 6e 74 2d 66 69 65 (%rtd-count-fie 22a0: 6c 64 73 20 72 74 64 29 29 0a 09 20 28 6e 2d 61 lds rtd)).. (n-a 22b0: 6c 6c 20 28 25 72 74 64 2d 63 6f 75 6e 74 2d 61 ll (%rtd-count-a 22c0: 6c 6c 2d 66 69 65 6c 64 73 20 72 74 64 29 29 0a ll-fields rtd)). 22d0: 09 20 28 62 61 73 65 20 28 2d 20 6e 2d 61 6c 6c . (base (- n-all 22e0: 20 6e 29 29 29 0a 20 20 20 20 28 64 6f 20 28 28 n))). (do (( 22f0: 6e 61 6d 65 73 20 28 6d 61 6b 65 2d 76 65 63 74 names (make-vect 2300: 6f 72 20 6e 29 29 20 28 69 20 62 61 73 65 20 28 or n)) (i base ( 2310: 66 78 2b 20 69 20 31 29 29 29 20 28 28 3e 3d 20 fx+ i 1))) ((>= 2320: 69 20 6e 2d 61 6c 6c 29 20 6e 61 6d 65 73 29 0a i n-all) names). 2330: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se 2340: 74 21 20 6e 61 6d 65 73 20 28 2d 20 69 20 62 61 t! names (- i ba 2350: 73 65 29 20 28 63 61 64 72 20 28 25 72 74 64 2d se) (cadr (%rtd- 2360: 66 69 65 6c 64 2d 72 65 66 20 72 74 64 20 69 29 field-ref rtd i) 2370: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define ( 2380: 72 74 64 2d 61 6c 6c 2d 66 69 65 6c 64 2d 6e 61 rtd-all-field-na 2390: 6d 65 73 20 72 74 64 29 0a 20 20 28 23 23 73 79 mes rtd). (##sy 23a0: 73 23 63 68 65 63 6b 2d 73 74 72 75 63 74 75 72 s#check-structur 23b0: 65 20 72 74 64 20 27 72 74 64 20 27 72 74 64 2d e rtd 'rtd 'rtd- 23c0: 61 6c 6c 2d 66 69 65 6c 64 2d 6e 61 6d 65 73 29 all-field-names) 23d0: 0a 20 20 28 6c 65 74 20 28 28 6e 20 28 25 72 74 . (let ((n (%rt 23e0: 64 2d 63 6f 75 6e 74 2d 66 69 65 6c 64 73 20 72 d-count-fields r 23f0: 74 64 29 29 0a 09 28 6e 2d 61 6c 6c 20 28 25 72 td))..(n-all (%r 2400: 74 64 2d 63 6f 75 6e 74 2d 61 6c 6c 2d 66 69 65 td-count-all-fie 2410: 6c 64 73 20 72 74 64 29 29 29 0a 20 20 20 20 28 lds rtd))). ( 2420: 64 6f 20 28 28 6e 61 6d 65 73 20 28 6d 61 6b 65 do ((names (make 2430: 2d 76 65 63 74 6f 72 20 6e 2d 61 6c 6c 29 29 20 -vector n-all)) 2440: 28 69 20 30 20 28 66 78 2b 20 69 20 31 29 29 29 (i 0 (fx+ i 1))) 2450: 20 28 28 3e 3d 20 69 20 6e 2d 61 6c 6c 29 20 6e ((>= i n-all) n 2460: 61 6d 65 73 29 0a 20 20 20 20 20 20 28 76 65 63 ames). (vec 2470: 74 6f 72 2d 73 65 74 21 20 6e 61 6d 65 73 20 69 tor-set! names i 2480: 20 28 63 61 64 72 20 28 25 72 74 64 2d 66 69 65 (cadr (%rtd-fie 2490: 6c 64 2d 72 65 66 20 72 74 64 20 69 29 29 29 29 ld-ref rtd i)))) 24a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 74 64 ))..(define (rtd 24b0: 2d 66 69 65 6c 64 2d 6d 75 74 61 62 6c 65 3f 20 -field-mutable? 24c0: 72 74 64 20 6e 61 6d 65 29 0a 20 20 28 23 23 73 rtd name). (##s 24d0: 79 73 23 63 68 65 63 6b 2d 73 74 72 75 63 74 75 ys#check-structu 24e0: 72 65 20 72 74 64 20 27 72 74 64 20 27 72 74 64 re rtd 'rtd 'rtd 24f0: 2d 66 69 65 6c 64 2d 6d 75 74 61 62 6c 65 3f 29 -field-mutable?) 2500: 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 . (let-values ( 2510: 28 28 69 20 61 63 63 65 73 73 20 66 69 65 6c 64 ((i access field 2520: 29 20 28 25 72 74 64 2d 66 69 65 6c 64 2d 66 69 ) (%rtd-field-fi 2530: 6e 64 20 72 74 64 20 6e 61 6d 65 29 29 29 0a 20 nd rtd name))). 2540: 20 20 20 28 65 71 3f 20 61 63 63 65 73 73 20 27 (eq? access ' 2550: 6d 75 74 61 62 6c 65 29 29 29 0a 0a 28 64 65 66 mutable)))..(def 2560: 69 6e 65 20 28 25 72 74 70 2d 61 63 63 65 73 73 ine (%rtp-access 2570: 6f 72 20 72 74 64 20 72 74 70 20 64 65 66 61 75 or rtd rtp defau 2580: 6c 74 29 0a 20 20 28 6c 65 74 20 6e 65 78 74 20 lt). (let next 2590: 28 28 72 74 64 20 28 61 6e 64 20 28 23 23 73 79 ((rtd (and (##sy 25a0: 73 23 73 74 72 75 63 74 75 72 65 3f 20 72 74 64 s#structure? rtd 25b0: 20 27 72 74 64 29 20 72 74 64 29 29 29 0a 20 20 'rtd) rtd))). 25c0: 20 20 28 69 66 20 72 74 64 0a 09 28 68 61 73 68 (if rtd..(hash 25d0: 2d 74 61 62 6c 65 2d 72 65 66 20 28 25 72 74 64 -table-ref (%rtd 25e0: 2d 70 72 6f 70 65 72 74 69 65 73 20 72 74 64 29 -properties rtd) 25f0: 20 72 74 70 0a 09 09 09 28 63 75 74 20 6e 65 78 rtp....(cut nex 2600: 74 20 28 25 72 74 64 2d 70 61 72 65 6e 74 20 72 t (%rtd-parent r 2610: 74 64 29 29 29 0a 09 64 65 66 61 75 6c 74 29 29 td)))..default)) 2620: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 )..(define (make 2630: 2d 72 74 70 20 23 21 6f 70 74 69 6f 6e 61 6c 20 -rtp #!optional 2640: 64 65 66 61 75 6c 74 29 0a 20 20 28 75 6e 6c 65 default). (unle 2650: 73 73 20 28 70 72 6f 63 65 64 75 72 65 3f 20 64 ss (procedure? d 2660: 65 66 61 75 6c 74 29 0a 20 20 20 20 28 73 65 74 efault). (set 2670: 21 20 64 65 66 61 75 6c 74 20 28 63 6f 6e 73 74 ! default (const 2680: 61 6e 74 6c 79 20 64 65 66 61 75 6c 74 29 29 29 antly default))) 2690: 0a 20 20 28 6c 65 74 72 65 63 20 28 28 72 74 70 . (letrec ((rtp 26a0: 2d 67 65 74 0a 20 20 20 20 20 20 20 20 20 20 20 -get. 26b0: 20 28 6c 61 6d 62 64 61 20 28 76 20 72 74 64 29 (lambda (v rtd) 26c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 . (( 26d0: 25 72 74 70 2d 61 63 63 65 73 73 6f 72 20 72 74 %rtp-accessor rt 26e0: 64 20 72 74 70 20 64 65 66 61 75 6c 74 29 20 76 d rtp default) v 26f0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ))). ( 2700: 72 74 70 2d 73 65 74 21 0a 20 20 20 20 20 20 20 rtp-set!. 2710: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 20 (lambda (v 2720: 70 76 20 72 74 64 29 0a 20 20 20 20 20 20 20 20 pv rtd). 2730: 20 20 20 20 20 28 28 73 65 74 74 65 72 20 28 25 ((setter (% 2740: 72 74 70 2d 61 63 63 65 73 73 6f 72 20 72 74 64 rtp-accessor rtd 2750: 20 72 74 70 20 64 65 66 61 75 6c 74 29 29 20 76 rtp default)) v 2760: 20 70 76 29 29 29 0a 09 20 20 20 28 72 74 70 0a pv))).. (rtp. 2770: 09 20 20 20 20 28 67 65 74 74 65 72 2d 77 69 74 . (getter-wit 2780: 68 2d 73 65 74 74 65 72 0a 09 20 20 20 20 20 28 h-setter.. ( 2790: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 09 20 20 20 case-lambda.. 27a0: 20 20 20 20 28 28 76 29 20 28 72 74 70 2d 67 65 ((v) (rtp-ge 27b0: 74 20 76 20 28 72 65 63 6f 72 64 2d 72 74 64 20 t v (record-rtd 27c0: 76 29 29 29 0a 09 20 20 20 20 20 20 20 28 28 76 v))).. ((v 27d0: 20 72 74 64 29 20 28 72 74 70 2d 67 65 74 20 76 rtd) (rtp-get v 27e0: 20 72 74 64 29 29 29 0a 09 20 20 20 20 20 28 63 rtd))).. (c 27f0: 61 73 65 2d 6c 61 6d 62 64 61 0a 09 20 20 20 20 ase-lambda.. 2800: 20 20 20 28 28 76 20 70 76 29 20 28 72 74 70 2d ((v pv) (rtp- 2810: 73 65 74 21 20 76 20 70 76 20 28 72 65 63 6f 72 set! v pv (recor 2820: 64 2d 72 74 64 20 76 29 29 29 0a 09 20 20 20 20 d-rtd v))).. 2830: 20 20 20 28 28 76 20 72 74 64 20 70 76 29 20 28 ((v rtd pv) ( 2840: 72 74 70 2d 73 65 74 21 20 76 20 70 76 20 72 74 rtp-set! v pv rt 2850: 64 29 29 29 29 29 29 0a 20 20 20 20 72 74 70 29 d)))))). rtp) 2860: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 74 64 2d )..(define (rtd- 2870: 70 72 6f 70 65 72 74 69 65 73 20 72 74 64 29 0a properties rtd). 2880: 20 20 28 69 66 20 28 23 23 73 79 73 23 73 74 72 (if (##sys#str 2890: 75 63 74 75 72 65 3f 20 72 74 64 20 27 72 74 64 ucture? rtd 'rtd 28a0: 29 0a 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 ). (hash-ta 28b0: 62 6c 65 2d 6b 65 79 73 20 28 25 72 74 64 2d 70 ble-keys (%rtd-p 28c0: 72 6f 70 65 72 74 69 65 73 20 72 74 64 29 29 0a roperties rtd)). 28d0: 20 20 20 20 20 20 27 28 29 29 29 0a 0a 28 64 65 '()))..(de 28e0: 66 69 6e 65 20 28 72 74 64 2d 61 6c 6c 2d 70 72 fine (rtd-all-pr 28f0: 6f 70 65 72 74 69 65 73 20 72 74 64 29 0a 20 20 operties rtd). 2900: 28 6c 65 74 20 28 28 72 74 70 73 20 28 6d 61 6b (let ((rtps (mak 2910: 65 2d 68 61 73 68 2d 74 61 62 6c 65 20 23 3a 74 e-hash-table #:t 2920: 65 73 74 20 65 71 3f 20 23 3a 68 61 73 68 20 65 est eq? #:hash e 2930: 71 3f 2d 68 61 73 68 29 29 29 0a 20 20 20 20 28 q?-hash))). ( 2940: 6c 65 74 20 6e 65 78 74 20 28 28 72 74 64 20 28 let next ((rtd ( 2950: 61 6e 64 20 28 23 23 73 79 73 23 73 74 72 75 63 and (##sys#struc 2960: 74 75 72 65 3f 20 72 74 64 20 27 72 74 64 29 20 ture? rtd 'rtd) 2970: 72 74 64 29 29 29 0a 20 20 20 20 20 20 28 69 66 rtd))). (if 2980: 20 72 74 64 0a 09 20 20 28 62 65 67 69 6e 0a 09 rtd.. (begin.. 2990: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table- 29a0: 77 61 6c 6b 0a 09 20 20 20 20 20 28 25 72 74 64 walk.. (%rtd 29b0: 2d 70 72 6f 70 65 72 74 69 65 73 20 72 74 64 29 -properties rtd) 29c0: 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda ( 29d0: 72 74 70 20 61 63 63 65 73 73 6f 72 29 20 28 68 rtp accessor) (h 29e0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 ash-table-set! r 29f0: 74 70 73 20 72 74 70 20 23 74 29 29 29 0a 09 20 tps rtp #t))).. 2a00: 20 20 20 28 6e 65 78 74 20 28 25 72 74 64 2d 70 (next (%rtd-p 2a10: 61 72 65 6e 74 20 72 74 64 29 29 29 0a 09 20 20 arent rtd))).. 2a20: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys 2a30: 20 72 74 70 73 29 29 29 29 29 0a 0a 29 0a 0a 28 rtps)))))..)..( 2a40: 6d 6f 64 75 6c 65 20 73 72 66 69 2d 39 39 2d 72 module srfi-99-r 2a50: 65 63 6f 72 64 73 2d 73 79 6e 74 61 63 74 69 63 ecords-syntactic 2a60: 0a 20 20 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 . (define-recor 2a70: 64 2d 74 79 70 65 0a 20 20 20 64 65 66 69 6e 65 d-type. define 2a80: 2d 72 65 63 6f 72 64 2d 63 6f 6e 73 74 72 75 63 -record-construc 2a90: 74 6f 72 0a 20 20 20 25 64 65 66 69 6e 65 2d 72 tor. %define-r 2aa0: 65 63 6f 72 64 2d 63 6f 6e 73 74 72 75 63 74 6f ecord-constructo 2ab0: 72 2f 64 65 66 61 75 6c 74 0a 20 20 20 64 65 66 r/default. def 2ac0: 69 6e 65 2d 72 65 63 6f 72 64 2d 70 72 65 64 69 ine-record-predi 2ad0: 63 61 74 65 0a 20 20 20 25 64 65 66 69 6e 65 2d cate. %define- 2ae0: 72 65 63 6f 72 64 2d 70 72 65 64 69 63 61 74 65 record-predicate 2af0: 2f 64 65 66 61 75 6c 74 0a 20 20 20 64 65 66 69 /default. defi 2b00: 6e 65 2d 72 65 63 6f 72 64 2d 66 69 65 6c 64 0a ne-record-field. 2b10: 20 20 20 25 64 65 66 69 6e 65 2d 72 65 63 6f 72 %define-recor 2b20: 64 2d 66 69 65 6c 64 2f 6d 75 74 61 62 6c 65 2d d-field/mutable- 2b30: 64 65 66 61 75 6c 74 20 25 64 65 66 69 6e 65 2d default %define- 2b40: 72 65 63 6f 72 64 2d 66 69 65 6c 64 2f 69 6d 6d record-field/imm 2b50: 75 74 61 62 6c 65 2d 64 65 66 61 75 6c 74 0a 20 utable-default. 2b60: 20 20 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d define-record- 2b70: 70 72 6f 70 65 72 74 79 0a 20 20 20 64 65 66 69 property. defi 2b80: 6e 65 2d 72 65 63 6f 72 64 2d 70 72 69 6e 74 65 ne-record-printe 2b90: 72 29 0a 20 20 28 69 6d 70 6f 72 74 0a 20 20 20 r). (import. 2ba0: 73 63 68 65 6d 65 20 28 65 78 63 65 70 74 20 28 scheme (except ( 2bb0: 63 68 69 63 6b 65 6e 20 62 61 73 65 29 20 64 65 chicken base) de 2bc0: 66 69 6e 65 2d 72 65 63 6f 72 64 2d 74 79 70 65 fine-record-type 2bd0: 20 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 70 define-record-p 2be0: 72 69 6e 74 65 72 29 0a 20 20 20 73 72 66 69 2d rinter). srfi- 2bf0: 39 39 2d 72 65 63 6f 72 64 73 2d 70 72 6f 63 65 99-records-proce 2c00: 64 75 72 61 6c 29 0a 0a 28 64 65 66 69 6e 65 2d dural)..(define- 2c10: 73 79 6e 74 61 78 20 25 64 65 66 69 6e 65 2d 72 syntax %define-r 2c20: 65 63 6f 72 64 2d 63 6f 6e 73 74 72 75 63 74 6f ecord-constructo 2c30: 72 2f 64 65 66 61 75 6c 74 0a 20 20 28 69 72 2d r/default. (ir- 2c40: 6d 61 63 72 6f 2d 74 72 61 6e 73 66 6f 72 6d 65 macro-transforme 2c50: 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 r. (lambda (st 2c60: 78 20 69 6e 6a 65 63 74 20 69 64 3d 29 0a 20 20 x inject id=). 2c70: 20 20 20 28 6c 65 74 2a 20 28 28 72 74 64 20 28 (let* ((rtd ( 2c80: 63 61 64 72 20 73 74 78 29 29 0a 09 20 20 20 20 cadr stx)).. 2c90: 28 6e 61 6d 65 20 28 73 79 6d 62 6f 6c 2d 61 70 (name (symbol-ap 2ca0: 70 65 6e 64 20 27 6d 61 6b 65 2d 20 28 73 74 72 pend 'make- (str 2cb0: 69 70 2d 73 79 6e 74 61 78 20 72 74 64 29 29 29 ip-syntax rtd))) 2cc0: 29 0a 20 20 20 20 20 20 20 60 28 64 65 66 69 6e ). `(defin 2cd0: 65 2d 72 65 63 6f 72 64 2d 63 6f 6e 73 74 72 75 e-record-constru 2ce0: 63 74 6f 72 20 2c 72 74 64 20 2c 28 69 6e 6a 65 ctor ,rtd ,(inje 2cf0: 63 74 20 6e 61 6d 65 29 29 29 29 29 29 0a 0a 28 ct name))))))..( 2d00: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 define-syntax de 2d10: 66 69 6e 65 2d 72 65 63 6f 72 64 2d 63 6f 6e 73 fine-record-cons 2d20: 74 72 75 63 74 6f 72 0a 20 20 28 73 79 6e 74 61 tructor. (synta 2d30: 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 x-rules (). ( 2d40: 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 63 (define-record-c 2d50: 6f 6e 73 74 72 75 63 74 6f 72 20 72 74 64 20 23 onstructor rtd # 2d60: 66 29 0a 20 20 20 20 20 28 62 65 67 69 6e 29 29 f). (begin)) 2d70: 0a 20 20 20 20 28 28 64 65 66 69 6e 65 2d 72 65 . ((define-re 2d80: 63 6f 72 64 2d 63 6f 6e 73 74 72 75 63 74 6f 72 cord-constructor 2d90: 20 72 74 64 20 23 74 29 0a 20 20 20 20 20 28 25 rtd #t). (% 2da0: 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 63 6f define-record-co 2db0: 6e 73 74 72 75 63 74 6f 72 2f 64 65 66 61 75 6c nstructor/defaul 2dc0: 74 20 72 74 64 29 29 0a 20 20 20 20 28 28 64 65 t rtd)). ((de 2dd0: 66 69 6e 65 2d 72 65 63 6f 72 64 2d 63 6f 6e 73 fine-record-cons 2de0: 74 72 75 63 74 6f 72 20 72 74 64 20 28 6e 61 6d tructor rtd (nam 2df0: 65 20 66 69 65 6c 64 20 2e 2e 2e 29 29 0a 20 20 e field ...)). 2e00: 20 20 20 28 64 65 66 69 6e 65 20 6e 61 6d 65 0a (define name. 2e10: 20 20 20 20 20 20 20 28 72 74 64 2d 63 6f 6e 73 (rtd-cons 2e20: 74 72 75 63 74 6f 72 20 72 74 64 20 28 76 65 63 tructor rtd (vec 2e30: 74 6f 72 20 27 66 69 65 6c 64 20 2e 2e 2e 29 29 tor 'field ...)) 2e40: 29 29 0a 20 20 20 20 28 28 64 65 66 69 6e 65 2d )). ((define- 2e50: 72 65 63 6f 72 64 2d 63 6f 6e 73 74 72 75 63 74 record-construct 2e60: 6f 72 20 72 74 64 20 6e 61 6d 65 29 0a 20 20 20 or rtd name). 2e70: 20 20 28 64 65 66 69 6e 65 20 6e 61 6d 65 0a 20 (define name. 2e80: 20 20 20 20 20 20 28 72 74 64 2d 63 6f 6e 73 74 (rtd-const 2e90: 72 75 63 74 6f 72 20 72 74 64 29 29 29 29 29 0a ructor rtd))))). 2ea0: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax 2eb0: 25 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 70 %define-record-p 2ec0: 72 65 64 69 63 61 74 65 2f 64 65 66 61 75 6c 74 redicate/default 2ed0: 0a 20 20 28 69 72 2d 6d 61 63 72 6f 2d 74 72 61 . (ir-macro-tra 2ee0: 6e 73 66 6f 72 6d 65 72 0a 20 20 20 28 6c 61 6d nsformer. (lam 2ef0: 62 64 61 20 28 73 74 78 20 69 6e 6a 65 63 74 20 bda (stx inject 2f00: 69 64 3d 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 id=). (let* 2f10: 28 28 72 74 64 20 28 63 61 64 72 20 73 74 78 29 ((rtd (cadr stx) 2f20: 29 0a 09 20 20 20 20 28 6e 61 6d 65 20 28 73 79 ).. (name (sy 2f30: 6d 62 6f 6c 2d 61 70 70 65 6e 64 20 28 73 74 72 mbol-append (str 2f40: 69 70 2d 73 79 6e 74 61 78 20 72 74 64 29 20 27 ip-syntax rtd) ' 2f50: 3f 29 29 29 0a 20 20 20 20 20 20 20 60 28 64 65 ?))). `(de 2f60: 66 69 6e 65 2d 72 65 63 6f 72 64 2d 70 72 65 64 fine-record-pred 2f70: 69 63 61 74 65 20 2c 72 74 64 20 2c 28 69 6e 6a icate ,rtd ,(inj 2f80: 65 63 74 20 6e 61 6d 65 29 29 29 29 29 29 0a 0a ect name)))))).. 2f90: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 (define-syntax d 2fa0: 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 70 72 65 efine-record-pre 2fb0: 64 69 63 61 74 65 0a 20 20 28 73 79 6e 74 61 78 dicate. (syntax 2fc0: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). (( 2fd0: 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 70 72 define-record-pr 2fe0: 65 64 69 63 61 74 65 20 72 74 64 20 23 66 29 0a edicate rtd #f). 2ff0: 20 20 20 20 20 28 62 65 67 69 6e 29 29 0a 20 20 (begin)). 3000: 20 20 28 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 ((define-recor 3010: 64 2d 70 72 65 64 69 63 61 74 65 20 72 74 64 20 d-predicate rtd 3020: 23 74 29 0a 20 20 20 20 20 28 25 64 65 66 69 6e #t). (%defin 3030: 65 2d 72 65 63 6f 72 64 2d 70 72 65 64 69 63 61 e-record-predica 3040: 74 65 2f 64 65 66 61 75 6c 74 20 72 74 64 29 29 te/default rtd)) 3050: 0a 20 20 20 20 28 28 64 65 66 69 6e 65 2d 72 65 . ((define-re 3060: 63 6f 72 64 2d 70 72 65 64 69 63 61 74 65 20 72 cord-predicate r 3070: 74 64 20 6e 61 6d 65 29 0a 20 20 20 20 20 28 64 td name). (d 3080: 65 66 69 6e 65 20 6e 61 6d 65 0a 20 20 20 20 20 efine name. 3090: 20 20 28 72 74 64 2d 70 72 65 64 69 63 61 74 65 (rtd-predicate 30a0: 20 72 74 64 29 29 29 29 29 0a 0a 28 64 65 66 69 rtd)))))..(defi 30b0: 6e 65 2d 73 79 6e 74 61 78 20 25 64 65 66 69 6e ne-syntax %defin 30c0: 65 2d 72 65 63 6f 72 64 2d 66 69 65 6c 64 2f 6d e-record-field/m 30d0: 75 74 61 62 6c 65 2d 64 65 66 61 75 6c 74 0a 20 utable-default. 30e0: 20 28 69 72 2d 6d 61 63 72 6f 2d 74 72 61 6e 73 (ir-macro-trans 30f0: 66 6f 72 6d 65 72 0a 20 20 20 28 6c 61 6d 62 64 former. (lambd 3100: 61 20 28 73 74 78 20 69 6e 6a 65 63 74 20 69 64 a (stx inject id 3110: 3d 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 28 =). (let* (( 3120: 72 74 64 20 28 63 61 64 72 20 73 74 78 29 29 0a rtd (cadr stx)). 3130: 09 20 20 20 20 28 6e 61 6d 65 20 28 63 61 64 64 . (name (cadd 3140: 72 20 73 74 78 29 29 0a 09 20 20 20 20 28 61 63 r stx)).. (ac 3150: 63 65 73 73 6f 72 20 28 73 79 6d 62 6f 6c 2d 61 cessor (symbol-a 3160: 70 70 65 6e 64 20 28 73 74 72 69 70 2d 73 79 6e ppend (strip-syn 3170: 74 61 78 20 72 74 64 29 20 27 2d 20 28 73 74 72 tax rtd) '- (str 3180: 69 70 2d 73 79 6e 74 61 78 20 6e 61 6d 65 29 29 ip-syntax name)) 3190: 29 0a 09 20 20 20 20 28 6d 75 74 61 74 6f 72 20 ).. (mutator 31a0: 28 73 79 6d 62 6f 6c 2d 61 70 70 65 6e 64 20 61 (symbol-append a 31b0: 63 63 65 73 73 6f 72 20 27 2d 73 65 74 21 29 29 ccessor '-set!)) 31c0: 29 0a 20 20 20 20 20 20 20 60 28 64 65 66 69 6e ). `(defin 31d0: 65 2d 72 65 63 6f 72 64 2d 66 69 65 6c 64 20 2c e-record-field , 31e0: 72 74 64 20 28 2c 6e 61 6d 65 20 2c 28 69 6e 6a rtd (,name ,(inj 31f0: 65 63 74 20 61 63 63 65 73 73 6f 72 29 20 2c 28 ect accessor) ,( 3200: 69 6e 6a 65 63 74 20 6d 75 74 61 74 6f 72 29 29 inject mutator)) 3210: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 )))))..(define-s 3220: 79 6e 74 61 78 20 25 64 65 66 69 6e 65 2d 72 65 yntax %define-re 3230: 63 6f 72 64 2d 66 69 65 6c 64 2f 69 6d 6d 75 74 cord-field/immut 3240: 61 62 6c 65 2d 64 65 66 61 75 6c 74 0a 20 20 28 able-default. ( 3250: 69 72 2d 6d 61 63 72 6f 2d 74 72 61 6e 73 66 6f ir-macro-transfo 3260: 72 6d 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 rmer. (lambda 3270: 28 73 74 78 20 69 6e 6a 65 63 74 20 69 64 3d 29 (stx inject id=) 3280: 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 74 . (let* ((rt 3290: 64 20 28 63 61 64 72 20 73 74 78 29 29 0a 09 20 d (cadr stx)).. 32a0: 20 20 20 28 6e 61 6d 65 20 28 63 61 64 64 72 20 (name (caddr 32b0: 73 74 78 29 29 0a 09 20 20 20 20 28 61 63 63 65 stx)).. (acce 32c0: 73 73 6f 72 20 28 73 79 6d 62 6f 6c 2d 61 70 70 ssor (symbol-app 32d0: 65 6e 64 20 28 73 74 72 69 70 2d 73 79 6e 74 61 end (strip-synta 32e0: 78 20 72 74 64 29 20 27 2d 20 28 73 74 72 69 70 x rtd) '- (strip 32f0: 2d 73 79 6e 74 61 78 20 6e 61 6d 65 29 29 29 29 -syntax name)))) 3300: 0a 20 20 20 20 20 20 20 60 28 64 65 66 69 6e 65 . `(define 3310: 2d 72 65 63 6f 72 64 2d 66 69 65 6c 64 20 2c 72 -record-field ,r 3320: 74 64 20 28 2c 6e 61 6d 65 20 2c 28 69 6e 6a 65 td (,name ,(inje 3330: 63 74 20 61 63 63 65 73 73 6f 72 29 29 29 29 29 ct accessor))))) 3340: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ))..(define-synt 3350: 61 78 20 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 ax define-record 3360: 2d 66 69 65 6c 64 0a 20 20 28 73 79 6e 74 61 78 -field. (syntax 3370: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). (( 3380: 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 66 69 define-record-fi 3390: 65 6c 64 20 72 74 64 20 28 6e 61 6d 65 20 61 63 eld rtd (name ac 33a0: 63 65 73 73 6f 72 20 6d 75 74 61 74 6f 72 29 29 cessor mutator)) 33b0: 0a 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 . (begin. 33c0: 20 20 20 20 28 64 65 66 69 6e 65 20 61 63 63 65 (define acce 33d0: 73 73 6f 72 0a 09 20 28 72 74 64 2d 61 63 63 65 ssor.. (rtd-acce 33e0: 73 73 6f 72 20 72 74 64 20 27 6e 61 6d 65 29 29 ssor rtd 'name)) 33f0: 0a 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 . (define 3400: 6d 75 74 61 74 6f 72 0a 09 20 28 72 74 64 2d 6d mutator.. (rtd-m 3410: 75 74 61 74 6f 72 20 72 74 64 20 27 6e 61 6d 65 utator rtd 'name 3420: 29 29 29 29 0a 20 20 20 20 28 28 64 65 66 69 6e )))). ((defin 3430: 65 2d 72 65 63 6f 72 64 2d 66 69 65 6c 64 20 72 e-record-field r 3440: 74 64 20 28 6e 61 6d 65 20 61 63 63 65 73 73 6f td (name accesso 3450: 72 29 29 0a 20 20 20 20 20 28 64 65 66 69 6e 65 r)). (define 3460: 20 61 63 63 65 73 73 6f 72 0a 20 20 20 20 20 20 accessor. 3470: 20 28 72 74 64 2d 61 63 63 65 73 73 6f 72 20 72 (rtd-accessor r 3480: 74 64 20 27 6e 61 6d 65 29 29 29 0a 20 20 20 20 td 'name))). 3490: 28 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d ((define-record- 34a0: 66 69 65 6c 64 20 72 74 64 20 28 6e 61 6d 65 29 field rtd (name) 34b0: 29 0a 20 20 20 20 20 28 25 64 65 66 69 6e 65 2d ). (%define- 34c0: 72 65 63 6f 72 64 2d 66 69 65 6c 64 2f 6d 75 74 record-field/mut 34d0: 61 62 6c 65 2d 64 65 66 61 75 6c 74 20 72 74 64 able-default rtd 34e0: 20 6e 61 6d 65 29 29 0a 20 20 20 20 28 28 64 65 name)). ((de 34f0: 66 69 6e 65 2d 72 65 63 6f 72 64 2d 66 69 65 6c fine-record-fiel 3500: 64 20 72 74 64 20 6e 61 6d 65 29 0a 20 20 20 20 d rtd name). 3510: 20 28 25 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 (%define-record 3520: 2d 66 69 65 6c 64 2f 69 6d 6d 75 74 61 62 6c 65 -field/immutable 3530: 2d 64 65 66 61 75 6c 74 20 72 74 64 20 6e 61 6d -default rtd nam 3540: 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 e))))..(define-s 3550: 79 6e 74 61 78 20 64 65 66 69 6e 65 2d 72 65 63 yntax define-rec 3560: 6f 72 64 2d 74 79 70 65 0a 20 20 28 73 79 6e 74 ord-type. (synt 3570: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules (). 3580: 28 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d ((define-record- 3590: 74 79 70 65 20 28 72 74 64 20 6f 70 74 69 6f 6e type (rtd option 35a0: 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 63 6f 6e ...). con 35b0: 73 74 72 75 63 74 6f 72 2d 73 70 65 63 0a 20 20 structor-spec. 35c0: 20 20 20 20 20 70 72 65 64 69 63 61 74 65 2d 73 predicate-s 35d0: 70 65 63 0a 20 20 20 20 20 20 20 66 69 65 6c 64 pec. field 35e0: 2d 73 70 65 63 20 2e 2e 2e 29 0a 20 20 20 20 20 -spec ...). 35f0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 28 64 (begin. (d 3600: 65 66 69 6e 65 20 72 74 64 0a 09 20 28 6d 61 6b efine rtd.. (mak 3610: 65 2d 72 74 64 0a 09 20 20 27 72 74 64 0a 09 20 e-rtd.. 'rtd.. 3620: 20 28 6c 65 74 2d 73 79 6e 74 61 78 20 28 28 25 (let-syntax ((% 3630: 72 65 63 6f 72 64 2d 66 69 65 6c 64 2d 73 70 65 record-field-spe 3640: 63 0a 09 09 09 28 73 79 6e 74 61 78 2d 72 75 6c c....(syntax-rul 3650: 65 73 20 28 29 0a 09 09 09 20 20 28 28 72 65 63 es ().... ((rec 3660: 6f 72 64 2d 66 69 65 6c 64 2d 73 70 65 63 20 28 ord-field-spec ( 3670: 6e 61 6d 65 20 61 63 63 65 73 73 6f 72 20 6d 75 name accessor mu 3680: 74 61 74 6f 72 29 29 0a 09 09 09 20 20 20 27 28 tator)).... '( 3690: 6d 75 74 61 62 6c 65 20 6e 61 6d 65 29 29 0a 09 mutable name)).. 36a0: 09 09 20 20 28 28 72 65 63 6f 72 64 2d 66 69 65 .. ((record-fie 36b0: 6c 64 2d 73 70 65 63 20 28 6e 61 6d 65 20 61 63 ld-spec (name ac 36c0: 63 65 73 73 6f 72 29 29 0a 09 09 09 20 20 20 27 cessor)).... ' 36d0: 28 69 6d 6d 75 74 61 62 6c 65 20 6e 61 6d 65 29 (immutable name) 36e0: 29 0a 09 09 09 20 20 28 28 72 65 63 6f 72 64 2d ).... ((record- 36f0: 66 69 65 6c 64 2d 73 70 65 63 20 28 6e 61 6d 65 field-spec (name 3700: 29 29 0a 09 09 09 20 20 20 27 28 6d 75 74 61 62 )).... '(mutab 3710: 6c 65 20 6e 61 6d 65 29 29 0a 09 09 09 20 20 28 le name)).... ( 3720: 28 72 65 63 6f 72 64 2d 66 69 65 6c 64 2d 73 70 (record-field-sp 3730: 65 63 20 6e 61 6d 65 29 0a 09 09 09 20 20 20 27 ec name).... ' 3740: 28 69 6d 6d 75 74 61 62 6c 65 20 6e 61 6d 65 29 (immutable name) 3750: 29 29 29 29 0a 09 20 20 20 20 28 76 65 63 74 6f )))).. (vecto 3760: 72 20 28 25 72 65 63 6f 72 64 2d 66 69 65 6c 64 r (%record-field 3770: 2d 73 70 65 63 20 66 69 65 6c 64 2d 73 70 65 63 -spec field-spec 3780: 29 20 2e 2e 2e 29 29 0a 09 20 20 6f 70 74 69 6f ) ...)).. optio 3790: 6e 20 2e 2e 2e 29 29 0a 20 20 20 20 20 20 20 28 n ...)). ( 37a0: 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 63 6f define-record-co 37b0: 6e 73 74 72 75 63 74 6f 72 20 72 74 64 20 63 6f nstructor rtd co 37c0: 6e 73 74 72 75 63 74 6f 72 2d 73 70 65 63 29 0a nstructor-spec). 37d0: 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 2d 72 (define-r 37e0: 65 63 6f 72 64 2d 70 72 65 64 69 63 61 74 65 20 ecord-predicate 37f0: 72 74 64 20 70 72 65 64 69 63 61 74 65 2d 73 70 rtd predicate-sp 3800: 65 63 29 0a 20 20 20 20 20 20 20 28 64 65 66 69 ec). (defi 3810: 6e 65 2d 72 65 63 6f 72 64 2d 66 69 65 6c 64 20 ne-record-field 3820: 72 74 64 20 66 69 65 6c 64 2d 73 70 65 63 29 20 rtd field-spec) 3830: 2e 2e 2e 29 29 0a 20 20 20 20 28 28 64 65 66 69 ...)). ((defi 3840: 6e 65 2d 72 65 63 6f 72 64 2d 74 79 70 65 20 72 ne-record-type r 3850: 74 64 0a 20 20 20 20 20 20 20 63 6f 6e 73 74 72 td. constr 3860: 75 63 74 6f 72 2d 73 70 65 63 0a 20 20 20 20 20 uctor-spec. 3870: 20 20 70 72 65 64 69 63 61 74 65 2d 73 70 65 63 predicate-spec 3880: 0a 20 20 20 20 20 20 20 66 69 65 6c 64 2d 73 70 . field-sp 3890: 65 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 64 65 ec ...). (de 38a0: 66 69 6e 65 2d 72 65 63 6f 72 64 2d 74 79 70 65 fine-record-type 38b0: 20 28 72 74 64 20 23 66 29 0a 20 20 20 20 20 20 (rtd #f). 38c0: 20 63 6f 6e 73 74 72 75 63 74 6f 72 2d 73 70 65 constructor-spe 38d0: 63 0a 20 20 20 20 20 20 20 70 72 65 64 69 63 61 c. predica 38e0: 74 65 2d 73 70 65 63 0a 20 20 20 20 20 20 20 66 te-spec. f 38f0: 69 65 6c 64 2d 73 70 65 63 20 2e 2e 2e 29 29 29 ield-spec ...))) 3900: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta 3910: 78 20 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d x define-record- 3920: 70 72 6f 70 65 72 74 79 0a 20 20 28 73 79 6e 74 property. (synt 3930: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules (). 3940: 28 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d ((define-record- 3950: 70 72 6f 70 65 72 74 79 20 72 74 70 20 6f 70 74 property rtp opt 3960: 69 6f 6e 20 2e 2e 2e 29 0a 20 20 20 20 20 28 64 ion ...). (d 3970: 65 66 69 6e 65 20 72 74 70 0a 20 20 20 20 20 20 efine rtp. 3980: 20 28 6d 61 6b 65 2d 72 74 70 20 6f 70 74 69 6f (make-rtp optio 3990: 6e 20 2e 2e 2e 29 29 29 29 29 0a 0a 28 64 65 66 n ...)))))..(def 39a0: 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 66 69 6e ine-syntax defin 39b0: 65 2d 72 65 63 6f 72 64 2d 70 72 69 6e 74 65 72 e-record-printer 39c0: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules 39d0: 20 28 29 0a 20 20 20 20 28 28 64 65 66 69 6e 65 (). ((define 39e0: 2d 72 65 63 6f 72 64 2d 70 72 69 6e 74 65 72 20 -record-printer 39f0: 28 72 74 64 20 2e 20 61 72 67 73 29 20 2e 20 62 (rtd . args) . b 3a00: 6f 64 79 29 0a 20 20 20 20 20 28 64 65 66 69 6e ody). (defin 3a10: 65 2d 72 65 63 6f 72 64 2d 70 72 69 6e 74 65 72 e-record-printer 3a20: 20 72 74 64 20 28 6c 61 6d 62 64 61 20 61 72 67 rtd (lambda arg 3a30: 73 20 2e 20 62 6f 64 79 29 29 29 0a 20 20 20 20 s . body))). 3a40: 28 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d ((define-record- 3a50: 70 72 69 6e 74 65 72 20 72 74 64 20 65 78 70 72 printer rtd expr 3a60: 29 0a 20 20 20 20 20 28 23 23 73 79 73 23 72 65 ). (##sys#re 3a70: 67 69 73 74 65 72 2d 72 65 63 6f 72 64 2d 70 72 gister-record-pr 3a80: 69 6e 74 65 72 20 28 72 74 64 2d 75 69 64 20 72 inter (rtd-uid r 3a90: 74 64 29 20 65 78 70 72 29 29 29 29 0a 0a 29 0a td) expr))))..). 3aa0: 0a 28 6d 6f 64 75 6c 65 20 73 72 66 69 2d 39 39 .(module srfi-99 3ab0: 2d 72 65 63 6f 72 64 73 0a 20 20 28 29 0a 20 20 -records. (). 3ac0: 28 69 6d 70 6f 72 74 0a 20 20 20 73 63 68 65 6d (import. schem 3ad0: 65 20 28 63 68 69 63 6b 65 6e 20 62 61 73 65 29 e (chicken base) 3ae0: 20 28 63 68 69 63 6b 65 6e 20 6d 6f 64 75 6c 65 (chicken module 3af0: 29 29 0a 20 20 28 72 65 65 78 70 6f 72 74 0a 20 )). (reexport. 3b00: 20 20 73 72 66 69 2d 39 39 2d 72 65 63 6f 72 64 srfi-99-record 3b10: 73 2d 70 72 6f 63 65 64 75 72 61 6c 20 73 72 66 s-procedural srf 3b20: 69 2d 39 39 2d 72 65 63 6f 72 64 73 2d 69 6e 73 i-99-records-ins 3b30: 70 65 63 74 69 6f 6e 0a 20 20 20 73 72 66 69 2d pection. srfi- 3b40: 39 39 2d 72 65 63 6f 72 64 73 2d 73 79 6e 74 61 99-records-synta 3b50: 63 74 69 63 29 0a 0a 29 0a 0a 28 6d 6f 64 75 6c ctic)..)..(modul 3b60: 65 20 73 72 66 69 2d 39 39 2d 76 61 72 69 61 6e e srfi-99-varian 3b70: 74 73 0a 20 20 28 64 65 66 69 6e 65 2d 76 61 72 ts. (define-var 3b80: 69 61 6e 74 2d 74 79 70 65 0a 20 20 20 64 65 66 iant-type. def 3b90: 69 6e 65 2d 76 61 72 69 61 6e 74 2d 63 6f 6e 73 ine-variant-cons 3ba0: 74 72 75 63 74 6f 72 0a 20 20 20 76 61 72 69 61 tructor. varia 3bb0: 6e 74 2d 63 61 73 65 29 0a 20 20 28 69 6d 70 6f nt-case). (impo 3bc0: 72 74 0a 20 20 20 73 63 68 65 6d 65 0a 20 20 20 rt. scheme. 3bd0: 28 63 68 69 63 6b 65 6e 20 6d 6f 64 75 6c 65 29 (chicken module) 3be0: 0a 20 20 20 28 65 78 63 65 70 74 20 28 63 68 69 . (except (chi 3bf0: 63 6b 65 6e 20 62 61 73 65 29 20 64 65 66 69 6e cken base) defin 3c00: 65 2d 72 65 63 6f 72 64 2d 74 79 70 65 29 0a 20 e-record-type). 3c10: 20 20 28 6f 6e 6c 79 20 28 63 68 69 63 6b 65 6e (only (chicken 3c20: 20 6d 65 6d 6f 72 79 20 72 65 70 72 65 73 65 6e memory represen 3c30: 74 61 74 69 6f 6e 29 20 65 78 74 65 6e 64 2d 70 tation) extend-p 3c40: 72 6f 63 65 64 75 72 65 20 70 72 6f 63 65 64 75 rocedure procedu 3c50: 72 65 2d 64 61 74 61 29 0a 20 20 20 6d 69 73 63 re-data). misc 3c60: 6d 61 63 72 6f 73 20 73 72 66 69 2d 39 39 2d 72 macros srfi-99-r 3c70: 65 63 6f 72 64 73 29 0a 0a 28 64 65 66 69 6e 65 ecords)..(define 3c80: 2d 73 79 6e 74 61 78 20 64 65 66 69 6e 65 2d 76 -syntax define-v 3c90: 61 72 69 61 6e 74 2d 74 79 70 65 0a 20 20 28 73 ariant-type. (s 3ca0: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules (). 3cb0: 20 20 20 28 28 64 65 66 69 6e 65 2d 76 61 72 69 ((define-vari 3cc0: 61 6e 74 2d 74 79 70 65 20 28 72 74 64 20 6f 70 ant-type (rtd op 3cd0: 74 69 6f 6e 20 2e 2e 2e 29 20 70 72 65 64 69 63 tion ...) predic 3ce0: 61 74 65 0a 20 20 20 20 20 20 20 28 76 61 72 69 ate. (vari 3cf0: 61 6e 74 20 66 69 65 6c 64 20 2e 2e 2e 29 0a 20 ant field ...). 3d00: 20 20 20 20 20 20 2e 2e 2e 29 0a 20 20 20 20 20 ...). 3d10: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 28 64 (begin. (d 3d20: 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 74 79 70 efine-record-typ 3d30: 65 20 28 72 74 64 20 6f 70 74 69 6f 6e 20 2e 2e e (rtd option .. 3d40: 2e 29 0a 09 20 23 66 20 70 72 65 64 69 63 61 74 .).. #f predicat 3d50: 65 29 0a 20 20 20 20 20 20 20 28 64 65 66 69 6e e). (defin 3d60: 65 2d 76 61 72 69 61 6e 74 2d 63 6f 6e 73 74 72 e-variant-constr 3d70: 75 63 74 6f 72 20 72 74 64 20 28 76 61 72 69 61 uctor rtd (varia 3d80: 6e 74 20 66 69 65 6c 64 20 2e 2e 2e 29 29 0a 20 nt field ...)). 3d90: 20 20 20 20 20 20 2e 2e 2e 29 29 0a 20 20 20 20 ...)). 3da0: 28 28 64 65 66 69 6e 65 2d 76 61 72 69 61 6e 74 ((define-variant 3db0: 2d 74 79 70 65 20 72 74 64 20 70 72 65 64 69 63 -type rtd predic 3dc0: 61 74 65 0a 20 20 20 20 20 20 20 28 76 61 72 69 ate. (vari 3dd0: 61 6e 74 20 66 69 65 6c 64 20 2e 2e 2e 29 0a 20 ant field ...). 3de0: 20 20 20 20 20 20 2e 2e 2e 29 0a 20 20 20 20 20 ...). 3df0: 28 64 65 66 69 6e 65 2d 76 61 72 69 61 6e 74 2d (define-variant- 3e00: 74 79 70 65 20 28 72 74 64 20 23 66 29 20 70 72 type (rtd #f) pr 3e10: 65 64 69 63 61 74 65 0a 20 20 20 20 20 20 20 28 edicate. ( 3e20: 76 61 72 69 61 6e 74 20 66 69 65 6c 64 20 2e 2e variant field .. 3e30: 2e 29 0a 20 20 20 20 20 20 20 2e 2e 2e 29 29 29 .). ...))) 3e40: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta 3e50: 78 20 64 65 66 69 6e 65 2d 76 61 72 69 61 6e 74 x define-variant 3e60: 2d 63 6f 6e 73 74 72 75 63 74 6f 72 0a 20 20 28 -constructor. ( 3e70: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a syntax-rules (). 3e80: 20 20 20 20 28 28 64 65 66 69 6e 65 2d 76 61 72 ((define-var 3e90: 69 61 6e 74 2d 63 6f 6e 73 74 72 75 63 74 6f 72 iant-constructor 3ea0: 20 72 74 64 20 28 76 61 72 69 61 6e 74 20 66 69 rtd (variant fi 3eb0: 65 6c 64 20 2e 2e 2e 29 29 0a 20 20 20 20 20 28 eld ...)). ( 3ec0: 64 65 66 69 6e 65 20 76 61 72 69 61 6e 74 0a 20 define variant. 3ed0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 76 61 (let* ((va 3ee0: 72 69 61 6e 74 2d 72 74 64 20 28 6d 61 6b 65 2d riant-rtd (make- 3ef0: 72 74 64 0a 09 09 09 20 20 20 20 27 76 61 72 69 rtd.... 'vari 3f00: 61 6e 74 0a 09 09 09 20 20 20 20 28 76 65 63 74 ant.... (vect 3f10: 6f 72 20 27 28 69 6d 6d 75 74 61 62 6c 65 20 66 or '(immutable f 3f20: 69 65 6c 64 29 20 2e 2e 2e 29 20 72 74 64 0a 09 ield) ...) rtd.. 3f30: 09 09 20 20 20 20 23 3a 75 69 64 20 28 73 79 6d .. #:uid (sym 3f40: 62 6f 6c 2d 61 70 70 65 6e 64 20 28 72 74 64 2d bol-append (rtd- 3f50: 75 69 64 20 72 74 64 29 20 27 2d 20 27 76 61 72 uid rtd) '- 'var 3f60: 69 61 6e 74 29 0a 09 09 09 20 20 20 20 23 3a 6f iant).... #:o 3f70: 70 61 71 75 65 20 28 72 74 64 2d 6f 70 61 71 75 paque (rtd-opaqu 3f80: 65 3f 20 72 74 64 29 0a 09 09 09 20 20 20 20 23 e? rtd).... # 3f90: 3a 73 65 61 6c 65 64 20 23 74 29 29 0a 09 20 20 :sealed #t)).. 3fa0: 20 20 20 20 28 6d 61 6b 65 2d 76 61 72 69 61 6e (make-varian 3fb0: 74 20 28 72 74 64 2d 63 6f 6e 73 74 72 75 63 74 t (rtd-construct 3fc0: 6f 72 20 76 61 72 69 61 6e 74 2d 72 74 64 29 29 or variant-rtd)) 3fd0: 29 0a 09 20 28 65 78 74 65 6e 64 2d 70 72 6f 63 ).. (extend-proc 3fe0: 65 64 75 72 65 0a 09 20 20 28 69 66 20 28 7a 65 edure.. (if (ze 3ff0: 72 6f 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 ro? (vector-leng 4000: 74 68 20 28 72 74 64 2d 61 6c 6c 2d 66 69 65 6c th (rtd-all-fiel 4010: 64 2d 6e 61 6d 65 73 20 76 61 72 69 61 6e 74 2d d-names variant- 4020: 72 74 64 29 29 29 0a 09 20 20 20 20 20 20 28 63 rtd))).. (c 4030: 6f 6e 73 74 61 6e 74 6c 79 20 28 6d 61 6b 65 2d onstantly (make- 4040: 76 61 72 69 61 6e 74 29 29 0a 09 20 20 20 20 20 variant)).. 4050: 20 6d 61 6b 65 2d 76 61 72 69 61 6e 74 29 0a 09 make-variant).. 4060: 20 20 76 61 72 69 61 6e 74 2d 72 74 64 29 29 29 variant-rtd))) 4070: 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e )))..(define-syn 4080: 74 61 78 20 76 61 72 69 61 6e 74 2d 63 61 73 65 tax variant-case 4090: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules 40a0: 20 28 65 6c 73 65 29 0a 20 20 20 20 28 28 76 61 (else). ((va 40b0: 72 69 61 6e 74 2d 63 61 73 65 20 72 74 64 20 65 riant-case rtd e 40c0: 78 70 72 0a 20 20 20 20 20 20 20 28 28 76 61 72 xpr. ((var 40d0: 69 61 6e 74 20 66 69 65 6c 64 20 2e 2e 2e 29 0a iant field ...). 40e0: 09 76 61 72 69 61 6e 74 2d 62 6f 64 79 20 2e 2e .variant-body .. 40f0: 2e 29 0a 20 20 20 20 20 20 20 2e 2e 2e 0a 20 20 .). .... 4100: 20 20 20 20 20 28 65 6c 73 65 0a 09 65 6c 73 65 (else..else 4110: 2d 62 6f 64 79 20 2e 2e 2e 29 29 0a 20 20 20 20 -body ...)). 4120: 20 28 6c 65 74 20 28 28 76 20 65 78 70 72 29 29 (let ((v expr)) 4130: 0a 20 20 20 20 20 20 20 28 65 6e 73 75 72 65 20 . (ensure 4140: 28 72 74 64 2d 70 72 65 64 69 63 61 74 65 20 72 (rtd-predicate r 4150: 74 64 29 20 76 29 0a 20 20 20 20 20 20 20 28 73 td) v). (s 4160: 65 6c 65 63 74 20 28 23 23 73 79 73 23 73 6c 6f elect (##sys#slo 4170: 74 20 76 20 30 29 0a 09 20 28 28 28 72 74 64 2d t v 0).. (((rtd- 4180: 75 69 64 20 28 70 72 6f 63 65 64 75 72 65 2d 64 uid (procedure-d 4190: 61 74 61 20 76 61 72 69 61 6e 74 29 29 29 0a 09 ata variant))).. 41a0: 20 20 28 6c 65 74 20 28 28 66 69 65 6c 64 20 28 (let ((field ( 41b0: 28 72 74 64 2d 61 63 63 65 73 73 6f 72 20 28 70 (rtd-accessor (p 41c0: 72 6f 63 65 64 75 72 65 2d 64 61 74 61 20 76 61 rocedure-data va 41d0: 72 69 61 6e 74 29 20 27 66 69 65 6c 64 29 20 76 riant) 'field) v 41e0: 29 29 0a 09 09 2e 2e 2e 29 0a 09 20 20 20 20 76 ))......).. v 41f0: 61 72 69 61 6e 74 2d 62 6f 64 79 20 2e 2e 2e 29 ariant-body ...) 4200: 29 0a 09 20 2e 2e 2e 0a 09 20 28 65 6c 73 65 0a ).. ..... (else. 4210: 09 20 20 65 6c 73 65 2d 62 6f 64 79 20 2e 2e 2e . else-body ... 4220: 29 29 29 29 0a 20 20 20 20 28 28 76 61 72 69 61 )))). ((varia 4230: 6e 74 2d 63 61 73 65 20 72 74 64 20 65 78 70 72 nt-case rtd expr 4240: 0a 20 20 20 20 20 20 20 28 28 76 61 72 69 61 6e . ((varian 4250: 74 20 66 69 65 6c 64 20 2e 2e 2e 29 0a 09 76 61 t field ...)..va 4260: 72 69 61 6e 74 2d 62 6f 64 79 20 2e 2e 2e 29 0a riant-body ...). 4270: 20 20 20 20 20 20 20 2e 2e 2e 29 0a 20 20 20 20 ...). 4280: 20 28 76 61 72 69 61 6e 74 2d 63 61 73 65 20 72 (variant-case r 4290: 74 64 20 65 78 70 72 0a 20 20 20 20 20 20 20 28 td expr. ( 42a0: 28 76 61 72 69 61 6e 74 20 66 69 65 6c 64 20 2e (variant field . 42b0: 2e 2e 29 0a 09 76 61 72 69 61 6e 74 2d 62 6f 64 ..)..variant-bod 42c0: 79 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 2e 2e y ...). .. 42d0: 2e 0a 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 .. (else.. 42e0: 28 65 72 72 6f 72 20 22 6e 6f 20 6d 61 74 63 68 (error "no match 42f0: 69 6e 67 20 76 61 72 69 61 6e 74 22 29 29 29 29 ing variant")))) 4300: 29 29 0a 0a 29 0a 0a 28 6d 6f 64 75 6c 65 20 73 ))..)..(module s 4310: 72 66 69 2d 39 39 0a 20 20 28 29 0a 20 20 28 69 rfi-99. (). (i 4320: 6d 70 6f 72 74 0a 20 20 20 73 63 68 65 6d 65 20 mport. scheme 4330: 28 63 68 69 63 6b 65 6e 20 62 61 73 65 29 20 28 (chicken base) ( 4340: 63 68 69 63 6b 65 6e 20 6d 6f 64 75 6c 65 29 29 chicken module)) 4350: 0a 20 20 28 72 65 65 78 70 6f 72 74 0a 20 20 20 . (reexport. 4360: 73 72 66 69 2d 39 39 2d 72 65 63 6f 72 64 73 20 srfi-99-records 4370: 73 72 66 69 2d 39 39 2d 76 61 72 69 61 6e 74 73 srfi-99-variants 4380: 29 0a 0a 29 0a )..).