-
Notifications
You must be signed in to change notification settings - Fork 3
/
tricks.sls
43 lines (39 loc) · 1.56 KB
/
tricks.sls
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#!r6rs
;; Copyright (c) 2009 Derick Eddington. All rights reserved.
;; Licensed under an MIT-style license. My license is in the file
;; named LICENSE from the original collection this file is distributed
;; with. If this file is redistributed with some other collection, my
;; license must also be included.
(library (surfage s23 error tricks)
(export
SRFI-23-error->R6RS)
(import
(rnrs))
(define-syntax error-wrap
(lambda (stx)
(syntax-case stx ()
((_ ctxt signal expr ...)
(with-syntax ((e (datum->syntax #'ctxt 'error)))
#'(let-syntax ((e (identifier-syntax signal)))
expr ...))))))
(define (AV who)
(lambda args (apply assertion-violation who args)))
(define-syntax SRFI-23-error->R6RS
(lambda (stx)
(syntax-case stx ()
((ctxt ewho expr ...)
(with-syntax ((e (datum->syntax #'ctxt 'error))
(d (datum->syntax #'ctxt 'define)))
#'(let-syntax ((e (identifier-syntax (AV 'ewho)))
(d (lambda (stx)
(syntax-case stx ()
((kw (id . formals) . body)
(identifier? #'id)
#'(error-wrap kw (AV 'id)
(d (id . formals) . body)))
((kw id . r)
(identifier? #'id)
#'(error-wrap kw (AV 'id)
(d id . r)))))))
expr ...))))))
)