Artifact afe71491f0166f795a01ce3996d2b7d5c6543202:
- File srfi/s9/records.sls — part of check-in [80c8c83034] at 2016-07-07 18:11:39 on branch trunk — initial import (user: ovenpasta@pizzahack.eu size: 2240)
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 29 ;; Copyright (c) 0010: 20 32 30 30 39 20 44 65 72 69 63 6b 20 45 64 64 2009 Derick Edd 0020: 69 6e 67 74 6f 6e 2e 20 20 41 6c 6c 20 72 69 67 ington. All rig 0030: 68 74 73 20 72 65 73 65 72 76 65 64 2e 0a 3b 3b hts reserved..;; 0040: 20 4c 69 63 65 6e 73 65 64 20 75 6e 64 65 72 20 Licensed under 0050: 61 6e 20 4d 49 54 2d 73 74 79 6c 65 20 6c 69 63 an MIT-style lic 0060: 65 6e 73 65 2e 20 20 4d 79 20 6c 69 63 65 6e 73 ense. My licens 0070: 65 20 69 73 20 69 6e 20 74 68 65 20 66 69 6c 65 e is in the file 0080: 0a 3b 3b 20 6e 61 6d 65 64 20 4c 49 43 45 4e 53 .;; named LICENS 0090: 45 20 66 72 6f 6d 20 74 68 65 20 6f 72 69 67 69 E from the origi 00a0: 6e 61 6c 20 63 6f 6c 6c 65 63 74 69 6f 6e 20 74 nal collection t 00b0: 68 69 73 20 66 69 6c 65 20 69 73 20 64 69 73 74 his file is dist 00c0: 72 69 62 75 74 65 64 0a 3b 3b 20 77 69 74 68 2e ributed.;; with. 00d0: 20 20 49 66 20 74 68 69 73 20 66 69 6c 65 20 69 If this file i 00e0: 73 20 72 65 64 69 73 74 72 69 62 75 74 65 64 20 s redistributed 00f0: 77 69 74 68 20 73 6f 6d 65 20 6f 74 68 65 72 20 with some other 0100: 63 6f 6c 6c 65 63 74 69 6f 6e 2c 20 6d 79 0a 3b collection, my.; 0110: 3b 20 6c 69 63 65 6e 73 65 20 6d 75 73 74 20 61 ; license must a 0120: 6c 73 6f 20 62 65 20 69 6e 63 6c 75 64 65 64 2e lso be included. 0130: 0a 0a 23 21 72 36 72 73 0a 28 6c 69 62 72 61 72 ..#!r6rs.(librar 0140: 79 20 28 73 72 66 69 20 73 39 20 72 65 63 6f 72 y (srfi s9 recor 0150: 64 73 29 0a 20 20 28 65 78 70 6f 72 74 20 0a 20 ds). (export . 0160: 20 20 20 28 72 65 6e 61 6d 65 20 28 73 72 66 69 (rename (srfi 0170: 3a 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 74 :define-record-t 0180: 79 70 65 20 64 65 66 69 6e 65 2d 72 65 63 6f 72 ype define-recor 0190: 64 2d 74 79 70 65 29 29 29 0a 20 20 28 69 6d 70 d-type))). (imp 01a0: 6f 72 74 20 0a 20 20 20 20 28 72 6e 72 73 29 29 ort . (rnrs)) 01b0: 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 2d 73 79 . . (define-sy 01c0: 6e 74 61 78 20 73 72 66 69 3a 64 65 66 69 6e 65 ntax srfi:define 01d0: 2d 72 65 63 6f 72 64 2d 74 79 70 65 0a 20 20 20 -record-type. 01e0: 20 28 6c 61 6d 62 64 61 20 28 73 74 78 29 0a 20 (lambda (stx). 01f0: 20 20 20 20 20 28 73 79 6e 74 61 78 2d 63 61 73 (syntax-cas 0200: 65 20 73 74 78 20 28 29 0a 20 20 20 20 20 20 20 e stx (). 0210: 20 5b 28 5f 20 74 79 70 65 20 28 63 6f 6e 73 74 [(_ type (const 0220: 72 75 63 74 6f 72 20 63 6f 6e 73 74 72 75 63 74 ructor construct 0230: 6f 72 2d 74 61 67 20 2e 2e 2e 29 0a 20 20 20 20 or-tag ...). 0240: 20 20 20 20 20 20 20 20 20 20 20 20 20 70 72 65 pre 0250: 64 69 63 61 74 65 0a 20 20 20 20 20 20 20 20 20 dicate. 0260: 20 20 20 20 20 20 20 20 28 66 69 65 6c 64 2d 74 (field-t 0270: 61 67 20 61 63 63 65 73 73 6f 72 20 73 65 74 74 ag accessor sett 0280: 65 72 20 2e 2e 2e 29 20 2e 2e 2e 29 20 20 20 20 er ...) ...) 0290: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 28 . ( 02a0: 61 6e 64 20 28 66 6f 72 2d 61 6c 6c 20 69 64 65 and (for-all ide 02b0: 6e 74 69 66 69 65 72 3f 20 0a 20 20 20 20 20 20 ntifier? . 02c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 02d0: 20 23 27 28 74 79 70 65 20 63 6f 6e 73 74 72 75 #'(type constru 02e0: 63 74 6f 72 20 70 72 65 64 69 63 61 74 65 20 63 ctor predicate c 02f0: 6f 6e 73 74 72 75 63 74 6f 72 2d 74 61 67 20 2e onstructor-tag . 0300: 2e 2e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .. . 0310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0320: 20 20 20 66 69 65 6c 64 2d 74 61 67 20 2e 2e 2e field-tag ... 0330: 20 61 63 63 65 73 73 6f 72 20 2e 2e 2e 29 29 0a accessor ...)). 0340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f 0350: 6f 72 2d 61 6c 6c 20 28 6c 61 6d 62 64 61 20 28 or-all (lambda ( 0360: 73 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 s) . 0370: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 (or 0380: 20 28 61 6e 64 20 28 3d 20 31 20 28 6c 65 6e 67 (and (= 1 (leng 0390: 74 68 20 73 29 29 20 28 69 64 65 6e 74 69 66 69 th s)) (identifi 03a0: 65 72 3f 20 28 63 61 72 20 73 29 29 29 0a 20 20 er? (car s))). 03b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 03c0: 20 20 20 20 20 20 20 20 20 20 20 28 3d 20 30 20 (= 0 03d0: 28 6c 65 6e 67 74 68 20 73 29 29 29 29 0a 20 20 (length s)))). 03e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 03f0: 20 20 20 20 20 23 27 28 28 73 65 74 74 65 72 20 #'((setter 0400: 2e 2e 2e 29 20 2e 2e 2e 29 29 0a 20 20 20 20 20 ...) ...)). 0410: 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 61 6c (for-al 0420: 6c 20 28 6c 61 6d 62 64 61 20 28 63 74 29 20 0a l (lambda (ct) . 0430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0440: 20 20 20 20 20 20 20 20 20 28 6d 65 6d 70 20 28 (memp ( 0450: 6c 61 6d 62 64 61 20 28 66 74 29 20 28 62 6f 75 lambda (ft) (bou 0460: 6e 64 2d 69 64 65 6e 74 69 66 69 65 72 3d 3f 20 nd-identifier=? 0470: 63 74 20 66 74 29 29 0a 20 20 20 20 20 20 20 20 ct ft)). 0480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0490: 20 20 20 20 20 20 20 23 27 28 66 69 65 6c 64 2d #'(field- 04a0: 74 61 67 20 2e 2e 2e 29 29 29 0a 20 20 20 20 20 tag ...))). 04b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 04c0: 20 20 23 27 28 63 6f 6e 73 74 72 75 63 74 6f 72 #'(constructor 04d0: 2d 74 61 67 20 2e 2e 2e 29 29 29 20 20 20 20 20 -tag ...))) 04e0: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 28 77 . (w 04f0: 69 74 68 2d 73 79 6e 74 61 78 20 28 5b 28 66 69 ith-syntax ([(fi 0500: 65 6c 64 2d 63 6c 61 75 73 65 20 2e 2e 2e 29 0a eld-clause ...). 0510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0520: 20 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 (map (la 0530: 6d 62 64 61 20 28 63 6c 61 75 73 65 29 0a 20 20 mbda (clause). 0540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0550: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if 0560: 20 28 3d 20 32 20 28 6c 65 6e 67 74 68 20 63 6c (= 2 (length cl 0570: 61 75 73 65 29 29 20 0a 20 20 20 20 20 20 20 20 ause)) . 0580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0590: 20 20 20 20 20 20 20 20 20 23 60 28 69 6d 6d 75 #`(immu 05a0: 74 61 62 6c 65 20 2e 20 23 2c 63 6c 61 75 73 65 table . #,clause 05b0: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) . 05c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 05d0: 20 20 20 20 23 60 28 6d 75 74 61 62 6c 65 20 2e #`(mutable . 05e0: 20 23 2c 63 6c 61 75 73 65 29 29 29 0a 20 20 20 #,clause))). 05f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0600: 20 20 20 20 20 20 20 20 20 20 23 27 28 28 66 69 #'((fi 0610: 65 6c 64 2d 74 61 67 20 61 63 63 65 73 73 6f 72 eld-tag accessor 0620: 20 73 65 74 74 65 72 20 2e 2e 2e 29 20 2e 2e 2e setter ...) ... 0630: 29 29 5d 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))]. 0640: 20 20 20 20 20 20 20 20 20 20 20 5b 28 75 6e 73 [(uns 0650: 70 65 63 2d 74 61 67 20 2e 2e 2e 29 0a 20 20 20 pec-tag ...). 0660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0670: 20 20 20 20 20 28 72 65 6d 70 20 28 6c 61 6d 62 (remp (lamb 0680: 64 61 20 28 66 74 29 20 0a 20 20 20 20 20 20 20 da (ft) . 0690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 06a0: 20 20 20 20 20 20 20 20 20 28 6d 65 6d 70 20 28 (memp ( 06b0: 6c 61 6d 62 64 61 20 28 63 74 29 20 28 62 6f 75 lambda (ct) (bou 06c0: 6e 64 2d 69 64 65 6e 74 69 66 69 65 72 3d 3f 20 nd-identifier=? 06d0: 66 74 20 63 74 29 29 0a 20 20 20 20 20 20 20 20 ft ct)). 06e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 06f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 27 #' 0700: 28 63 6f 6e 73 74 72 75 63 74 6f 72 2d 74 61 67 (constructor-tag 0710: 20 2e 2e 2e 29 29 29 0a 20 20 20 20 20 20 20 20 ...))). 0720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0730: 20 20 20 20 20 20 23 27 28 66 69 65 6c 64 2d 74 #'(field-t 0740: 61 67 20 2e 2e 2e 29 29 5d 29 0a 20 20 20 20 20 ag ...))]). 0750: 20 20 20 20 20 20 23 27 28 64 65 66 69 6e 65 2d #'(define- 0760: 72 65 63 6f 72 64 2d 74 79 70 65 20 28 74 79 70 record-type (typ 0770: 65 20 63 6f 6e 73 74 72 75 63 74 6f 72 20 70 72 e constructor pr 0780: 65 64 69 63 61 74 65 29 0a 20 20 20 20 20 20 20 edicate). 0790: 20 20 20 20 20 20 20 20 28 73 65 61 6c 65 64 20 (sealed 07a0: 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #t). 07b0: 20 20 20 28 70 72 6f 74 6f 63 6f 6c 20 28 6c 61 (protocol (la 07c0: 6d 62 64 61 20 28 63 74 6f 72 29 0a 20 20 20 20 mbda (ctor). 07d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 07e0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda ( 07f0: 63 6f 6e 73 74 72 75 63 74 6f 72 2d 74 61 67 20 constructor-tag 0800: 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20 20 20 20 ...). 0810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0820: 20 20 28 64 65 66 69 6e 65 20 75 6e 73 70 65 63 (define unspec 0830: 2d 74 61 67 29 0a 20 20 20 20 20 20 20 20 20 20 -tag). 0840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0850: 20 20 20 2e 2e 2e 0a 20 20 20 20 20 20 20 20 20 .... 0860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0870: 20 20 20 20 28 63 74 6f 72 20 66 69 65 6c 64 2d (ctor field- 0880: 74 61 67 20 2e 2e 2e 29 29 29 29 0a 20 20 20 20 tag ...)))). 0890: 20 20 20 20 20 20 20 20 20 20 20 28 66 69 65 6c (fiel 08a0: 64 73 20 66 69 65 6c 64 2d 63 6c 61 75 73 65 20 ds field-clause 08b0: 2e 2e 2e 29 29 29 5d 29 29 29 0a 20 20 0a 29 0a ...)))]))). .).