Artifact
1a0c3d6d59ad52ff4627cb32c9e8da00043be33d:
0000: 23 21 72 36 72 73 0a 3b 3b 20 43 6f 70 79 72 69 #!r6rs.;; Copyri
0010: 67 68 74 20 28 63 29 20 32 30 30 39 20 44 65 72 ght (c) 2009 Der
0020: 69 63 6b 20 45 64 64 69 6e 67 74 6f 6e 2e 20 20 ick Eddington.
0030: 41 6c 6c 20 72 69 67 68 74 73 20 72 65 73 65 72 All rights reser
0040: 76 65 64 2e 0a 3b 3b 20 4c 69 63 65 6e 73 65 64 ved..;; Licensed
0050: 20 75 6e 64 65 72 20 61 6e 20 4d 49 54 2d 73 74 under an MIT-st
0060: 79 6c 65 20 6c 69 63 65 6e 73 65 2e 20 20 4d 79 yle license. My
0070: 20 6c 69 63 65 6e 73 65 20 69 73 20 69 6e 20 74 license is in t
0080: 68 65 20 66 69 6c 65 0a 3b 3b 20 6e 61 6d 65 64 he file.;; named
0090: 20 4c 49 43 45 4e 53 45 20 66 72 6f 6d 20 74 68 LICENSE from th
00a0: 65 20 6f 72 69 67 69 6e 61 6c 20 63 6f 6c 6c 65 e original colle
00b0: 63 74 69 6f 6e 20 74 68 69 73 20 66 69 6c 65 20 ction this file
00c0: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 0a 3b is distributed.;
00d0: 3b 20 77 69 74 68 2e 20 20 49 66 20 74 68 69 73 ; with. If this
00e0: 20 66 69 6c 65 20 69 73 20 72 65 64 69 73 74 72 file is redistr
00f0: 69 62 75 74 65 64 20 77 69 74 68 20 73 6f 6d 65 ibuted with some
0100: 20 6f 74 68 65 72 20 63 6f 6c 6c 65 63 74 69 6f other collectio
0110: 6e 2c 20 6d 79 0a 3b 3b 20 6c 69 63 65 6e 73 65 n, my.;; license
0120: 20 6d 75 73 74 20 61 6c 73 6f 20 62 65 20 69 6e must also be in
0130: 63 6c 75 64 65 64 2e 0a 0a 28 6c 69 62 72 61 72 cluded...(librar
0140: 79 20 28 73 72 66 69 20 70 72 69 76 61 74 65 20 y (srfi private
0150: 66 65 61 74 75 72 65 2d 63 6f 6e 64 29 0a 20 20 feature-cond).
0160: 28 65 78 70 6f 72 74 0a 20 20 20 20 66 65 61 74 (export. feat
0170: 75 72 65 2d 63 6f 6e 64 29 0a 20 20 28 69 6d 70 ure-cond). (imp
0180: 6f 72 74 0a 20 20 20 20 28 72 6e 72 73 29 0a 20 ort. (rnrs).
0190: 20 20 20 28 73 72 66 69 20 70 72 69 76 61 74 65 (srfi private
01a0: 20 72 65 67 69 73 74 72 79 29 29 0a 0a 20 20 28 registry)).. (
01b0: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 66 65 define-syntax fe
01c0: 61 74 75 72 65 2d 63 6f 6e 64 0a 20 20 20 20 28 ature-cond. (
01d0: 6c 61 6d 62 64 61 20 28 73 74 78 29 0a 20 20 20 lambda (stx).
01e0: 20 20 20 28 64 65 66 69 6e 65 20 28 69 64 65 6e (define (iden
01f0: 74 69 66 69 65 72 3f 2f 6e 61 6d 65 3d 3f 20 78 tifier?/name=? x
0200: 20 6e 29 0a 20 20 20 20 20 20 20 20 28 61 6e 64 n). (and
0210: 20 28 69 64 65 6e 74 69 66 69 65 72 3f 20 78 29 (identifier? x)
0220: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 . (s
0230: 79 6d 62 6f 6c 3d 3f 20 6e 20 28 73 79 6e 74 61 ymbol=? n (synta
0240: 78 2d 3e 64 61 74 75 6d 20 78 29 29 29 29 0a 20 x->datum x)))).
0250: 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 6d 61 (define (ma
0260: 6b 65 2d 74 65 73 74 20 74 29 0a 20 20 20 20 20 ke-test t).
0270: 20 20 20 28 64 65 66 69 6e 65 20 28 69 6e 76 61 (define (inva
0280: 6c 69 64 2d 74 65 73 74 29 0a 20 20 20 20 20 20 lid-test).
0290: 20 20 20 20 28 73 79 6e 74 61 78 2d 76 69 6f 6c (syntax-viol
02a0: 61 74 69 6f 6e 20 23 46 20 22 69 6e 76 61 6c 69 ation #F "invali
02b0: 64 20 74 65 73 74 20 73 79 6e 74 61 78 22 20 73 d test syntax" s
02c0: 74 78 20 74 29 29 0a 20 20 20 20 20 20 20 20 28 tx t)). (
02d0: 73 79 6e 74 61 78 2d 63 61 73 65 20 74 20 28 29 syntax-case t ()
02e0: 0a 20 20 20 20 20 20 20 20 20 20 28 28 63 20 78 . ((c x
02f0: 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20 20 20 ...).
0300: 20 28 69 64 65 6e 74 69 66 69 65 72 3f 2f 6e 61 (identifier?/na
0310: 6d 65 3d 3f 20 28 73 79 6e 74 61 78 20 63 29 20 me=? (syntax c)
0320: 28 71 75 6f 74 65 20 61 6e 64 29 29 0a 20 20 20 (quote and)).
0330: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 28 73 (cons (s
0340: 79 6e 74 61 78 20 61 6e 64 29 20 28 6d 61 70 20 yntax and) (map
0350: 6d 61 6b 65 2d 74 65 73 74 20 28 73 79 6e 74 61 make-test (synta
0360: 78 20 28 78 20 2e 2e 2e 29 29 29 29 29 0a 20 20 x (x ...))))).
0370: 20 20 20 20 20 20 20 20 28 28 63 20 78 20 2e 2e ((c x ..
0380: 2e 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 .). (i
0390: 64 65 6e 74 69 66 69 65 72 3f 2f 6e 61 6d 65 3d dentifier?/name=
03a0: 3f 20 28 73 79 6e 74 61 78 20 63 29 20 28 71 75 ? (syntax c) (qu
03b0: 6f 74 65 20 6f 72 29 29 0a 20 20 20 20 20 20 20 ote or)).
03c0: 20 20 20 20 28 63 6f 6e 73 20 28 73 79 6e 74 61 (cons (synta
03d0: 78 20 6f 72 29 20 28 6d 61 70 20 6d 61 6b 65 2d x or) (map make-
03e0: 74 65 73 74 20 28 73 79 6e 74 61 78 20 28 78 20 test (syntax (x
03f0: 2e 2e 2e 29 29 29 29 29 0a 20 20 20 20 20 20 20 ...))))).
0400: 20 20 20 28 28 63 20 78 20 2e 2e 2e 29 0a 20 20 ((c x ...).
0410: 20 20 20 20 20 20 20 20 20 28 69 64 65 6e 74 69 (identi
0420: 66 69 65 72 3f 2f 6e 61 6d 65 3d 3f 20 28 73 79 fier?/name=? (sy
0430: 6e 74 61 78 20 63 29 20 28 71 75 6f 74 65 20 6e ntax c) (quote n
0440: 6f 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ot)).
0450: 28 69 66 20 28 3d 20 31 20 28 6c 65 6e 67 74 68 (if (= 1 (length
0460: 20 28 73 79 6e 74 61 78 20 28 78 20 2e 2e 2e 29 (syntax (x ...)
0470: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
0480: 20 28 6c 69 73 74 20 28 73 79 6e 74 61 78 20 6e (list (syntax n
0490: 6f 74 29 20 28 6d 61 6b 65 2d 74 65 73 74 20 28 ot) (make-test (
04a0: 63 61 72 20 28 73 79 6e 74 61 78 20 28 78 20 2e car (syntax (x .
04b0: 2e 2e 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ..))))).
04c0: 20 20 20 20 20 28 69 6e 76 61 6c 69 64 2d 74 65 (invalid-te
04d0: 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 st))).
04e0: 28 64 61 74 75 6d 0a 20 20 20 20 20 20 20 20 20 (datum.
04f0: 20 20 28 6e 6f 74 20 28 61 6e 64 20 28 69 64 65 (not (and (ide
0500: 6e 74 69 66 69 65 72 3f 20 28 73 79 6e 74 61 78 ntifier? (syntax
0510: 20 64 61 74 75 6d 29 29 0a 20 20 20 20 20 20 20 datum)).
0520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
0530: 65 6d 71 20 28 73 79 6e 74 61 78 2d 3e 64 61 74 emq (syntax->dat
0540: 75 6d 20 28 73 79 6e 74 61 78 20 64 61 74 75 6d um (syntax datum
0550: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 71 (q
0570: 75 6f 74 65 20 28 61 6e 64 20 6f 72 20 6e 6f 74 uote (and or not
0580: 20 65 6c 73 65 29 29 29 29 29 0a 20 20 20 20 20 else))))).
0590: 20 20 20 20 20 20 28 73 79 6e 74 61 78 20 28 61 (syntax (a
05a0: 6e 64 20 28 6d 65 6d 62 65 72 20 28 71 75 6f 74 nd (member (quot
05b0: 65 20 64 61 74 75 6d 29 20 61 76 61 69 6c 61 62 e datum) availab
05c0: 6c 65 2d 66 65 61 74 75 72 65 73 29 20 23 54 29 le-features) #T)
05d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 5f 20 )). (_
05e0: 28 69 6e 76 61 6c 69 64 2d 74 65 73 74 29 29 29 (invalid-test)))
05f0: 29 0a 20 20 20 20 20 20 28 73 79 6e 74 61 78 2d ). (syntax-
0600: 63 61 73 65 20 73 74 78 20 28 29 0a 20 20 20 20 case stx ().
0610: 20 20 20 20 28 28 5f 20 28 74 65 73 74 20 2e 20 ((_ (test .
0620: 65 78 70 72 73 29 20 2e 2e 2e 20 28 65 20 2e 20 exprs) ... (e .
0630: 65 65 78 70 72 73 29 29 0a 20 20 20 20 20 20 20 eexprs)).
0640: 20 20 28 69 64 65 6e 74 69 66 69 65 72 3f 2f 6e (identifier?/n
0650: 61 6d 65 3d 3f 20 28 73 79 6e 74 61 78 20 65 29 ame=? (syntax e)
0660: 20 28 71 75 6f 74 65 20 65 6c 73 65 29 29 0a 20 (quote else)).
0670: 20 20 20 20 20 20 20 20 28 77 69 74 68 2d 73 79 (with-sy
0680: 6e 74 61 78 20 28 28 28 63 6c 61 75 73 65 20 2e ntax (((clause .
0690: 2e 2e 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ..).
06a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 (map
06b0: 20 63 6f 6e 73 20 28 6d 61 70 20 6d 61 6b 65 2d cons (map make-
06c0: 74 65 73 74 20 28 73 79 6e 74 61 78 20 28 74 65 test (syntax (te
06d0: 73 74 20 2e 2e 2e 29 29 29 0a 20 20 20 20 20 20 st ...))).
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 28 73 79 6e (syn
0700: 74 61 78 20 28 65 78 70 72 73 20 2e 2e 2e 29 29 tax (exprs ...))
0710: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ))). (
0720: 73 79 6e 74 61 78 20 28 63 6f 6e 64 20 63 6c 61 syntax (cond cla
0730: 75 73 65 20 2e 2e 2e 20 28 65 6c 73 65 20 2e 20 use ... (else .
0740: 65 65 78 70 72 73 29 29 29 29 29 0a 20 20 20 20 eexprs))))).
0750: 20 20 20 20 28 28 6b 77 20 28 74 65 73 74 20 2e ((kw (test .
0760: 20 65 78 70 72 73 29 20 2e 2e 2e 29 0a 20 20 20 exprs) ...).
0770: 20 20 20 20 20 20 28 73 79 6e 74 61 78 20 28 6b (syntax (k
0780: 77 20 28 74 65 73 74 20 2e 20 65 78 70 72 73 29 w (test . exprs)
0790: 20 2e 2e 2e 20 28 65 6c 73 65 20 28 6e 6f 2d 63 ... (else (no-c
07a0: 6c 61 75 73 65 2d 74 72 75 65 29 29 29 29 29 29 lause-true))))))
07b0: 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6e )).. (define (n
07c0: 6f 2d 63 6c 61 75 73 65 2d 74 72 75 65 29 0a 20 o-clause-true).
07d0: 20 20 20 28 61 73 73 65 72 74 69 6f 6e 2d 76 69 (assertion-vi
07e0: 6f 6c 61 74 69 6f 6e 20 28 71 75 6f 74 65 20 66 olation (quote f
07f0: 65 61 74 75 72 65 2d 63 6f 6e 64 29 20 22 6e 6f eature-cond) "no
0800: 20 63 6c 61 75 73 65 20 74 72 75 65 22 29 29 0a clause true")).
0810: 29 0a ).