Artifact 134f2d16d7df1c6b752f9525b143a6bdc9f7b61d:
- File srfi/s23/error/tricks.sls — part of check-in [80c8c83034] at 2016-07-07 18:11:39 on branch trunk — initial import (user: ovenpasta@pizzahack.eu size: 1599)
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 73 32 33 20 65 72 72 6f y (srfi s23 erro 0150: 72 20 74 72 69 63 6b 73 29 0a 20 20 28 65 78 70 r tricks). (exp 0160: 6f 72 74 0a 20 20 20 20 53 52 46 49 2d 32 33 2d ort. SRFI-23- 0170: 65 72 72 6f 72 2d 3e 52 36 52 53 29 0a 20 20 28 error->R6RS). ( 0180: 69 6d 70 6f 72 74 0a 20 20 20 20 28 72 6e 72 73 import. (rnrs 0190: 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 2d 73 79 )).. (define-sy 01a0: 6e 74 61 78 20 65 72 72 6f 72 2d 77 72 61 70 0a ntax error-wrap. 01b0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 78 (lambda (stx 01c0: 29 0a 20 20 20 20 20 20 28 73 79 6e 74 61 78 2d ). (syntax- 01d0: 63 61 73 65 20 73 74 78 20 28 29 0a 20 20 20 20 case stx (). 01e0: 20 20 20 20 28 28 5f 20 63 74 78 74 20 73 69 67 ((_ ctxt sig 01f0: 6e 61 6c 20 65 78 70 72 20 2e 2e 2e 29 0a 20 20 nal expr ...). 0200: 20 20 20 20 20 20 20 28 77 69 74 68 2d 73 79 6e (with-syn 0210: 74 61 78 20 28 28 65 20 28 64 61 74 75 6d 2d 3e tax ((e (datum-> 0220: 73 79 6e 74 61 78 20 23 27 63 74 78 74 20 27 65 syntax #'ctxt 'e 0230: 72 72 6f 72 29 29 29 0a 20 20 20 20 20 20 20 20 rror))). 0240: 20 20 20 23 27 28 6c 65 74 2d 73 79 6e 74 61 78 #'(let-syntax 0250: 20 28 28 65 20 28 69 64 65 6e 74 69 66 69 65 72 ((e (identifier 0260: 2d 73 79 6e 74 61 78 20 73 69 67 6e 61 6c 29 29 -syntax signal)) 0270: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 0280: 20 65 78 70 72 20 2e 2e 2e 29 29 29 29 29 29 0a expr ...)))))). 0290: 0a 20 20 28 64 65 66 69 6e 65 20 28 41 56 20 77 . (define (AV w 02a0: 68 6f 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 ho). (lambda 02b0: 61 72 67 73 20 28 61 70 70 6c 79 20 61 73 73 65 args (apply asse 02c0: 72 74 69 6f 6e 2d 76 69 6f 6c 61 74 69 6f 6e 20 rtion-violation 02d0: 77 68 6f 20 61 72 67 73 29 29 29 0a 0a 20 20 28 who args))).. ( 02e0: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 53 52 define-syntax SR 02f0: 46 49 2d 32 33 2d 65 72 72 6f 72 2d 3e 52 36 52 FI-23-error->R6R 0300: 53 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 S. (lambda (s 0310: 74 78 29 0a 20 20 20 20 20 20 28 73 79 6e 74 61 tx). (synta 0320: 78 2d 63 61 73 65 20 73 74 78 20 28 29 0a 20 20 x-case stx (). 0330: 20 20 20 20 20 20 28 28 63 74 78 74 20 65 77 68 ((ctxt ewh 0340: 6f 20 65 78 70 72 20 2e 2e 2e 29 0a 20 20 20 20 o expr ...). 0350: 20 20 20 20 20 28 77 69 74 68 2d 73 79 6e 74 61 (with-synta 0360: 78 20 28 28 65 20 28 64 61 74 75 6d 2d 3e 73 79 x ((e (datum->sy 0370: 6e 74 61 78 20 23 27 63 74 78 74 20 27 65 72 72 ntax #'ctxt 'err 0380: 6f 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 or)). 0390: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 20 28 (d ( 03a0: 64 61 74 75 6d 2d 3e 73 79 6e 74 61 78 20 23 27 datum->syntax #' 03b0: 63 74 78 74 20 27 64 65 66 69 6e 65 29 29 29 0a ctxt 'define))). 03c0: 20 20 20 20 20 20 20 20 20 20 20 23 27 28 6c 65 #'(le 03d0: 74 2d 73 79 6e 74 61 78 20 28 28 65 20 28 69 64 t-syntax ((e (id 03e0: 65 6e 74 69 66 69 65 72 2d 73 79 6e 74 61 78 20 entifier-syntax 03f0: 28 41 56 20 27 65 77 68 6f 29 29 29 0a 20 20 20 (AV 'ewho))). 0400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0410: 20 20 20 20 20 20 20 28 64 20 28 6c 61 6d 62 64 (d (lambd 0420: 61 20 28 73 74 78 29 0a 20 20 20 20 20 20 20 20 a (stx). 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 28 73 79 6e 74 61 78 2d 63 (syntax-c 0450: 61 73 65 20 73 74 78 20 28 29 0a 20 20 20 20 20 ase stx (). 0460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0470: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6b 77 ((kw 0480: 20 28 69 64 20 2e 20 66 6f 72 6d 61 6c 73 29 20 (id . formals) 0490: 2e 20 62 6f 64 79 29 0a 20 20 20 20 20 20 20 20 . body). 04a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 04b0: 20 20 20 20 20 20 20 20 20 20 28 69 64 65 6e 74 (ident 04c0: 69 66 69 65 72 3f 20 23 27 69 64 29 0a 20 20 20 ifier? #'id). 04d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 04e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 # 04f0: 27 28 65 72 72 6f 72 2d 77 72 61 70 20 6b 77 20 '(error-wrap kw 0500: 28 41 56 20 27 69 64 29 0a 20 20 20 20 20 20 20 (AV 'id). 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 20 20 20 20 20 20 28 64 (d 0530: 20 28 69 64 20 2e 20 66 6f 72 6d 61 6c 73 29 20 (id . formals) 0540: 2e 20 62 6f 64 79 29 29 29 0a 20 20 20 20 20 20 . body))). 0550: 20 20 20 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 28 28 6b 77 20 ((kw 0570: 69 64 20 2e 20 72 29 0a 20 20 20 20 20 20 20 20 id . r). 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 20 28 69 64 65 6e 74 (ident 05a0: 69 66 69 65 72 3f 20 23 27 69 64 29 0a 20 20 20 ifier? #'id). 05b0: 20 20 20 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 23 # 05d0: 27 28 65 72 72 6f 72 2d 77 72 61 70 20 6b 77 20 '(error-wrap kw 05e0: 28 41 56 20 27 69 64 29 0a 20 20 20 20 20 20 20 (AV 'id). 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 20 20 20 20 28 64 (d 0610: 20 69 64 20 2e 20 72 29 29 29 29 29 29 29 0a 20 id . r))))))). 0620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65 78 ex 0630: 70 72 20 2e 2e 2e 29 29 29 29 29 29 0a 29 0a pr ...)))))).).