-
Notifications
You must be signed in to change notification settings - Fork 0
/
guards.scm
42 lines (39 loc) · 1.21 KB
/
guards.scm
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
(module guards (define-guarded)
(import
scheme
(chicken base)
(chicken syntax))
(define-for-syntax (filter fn lst)
(let loop ((lst lst) (result '()))
(if (null? lst)
(reverse result)
(let ((item (car lst)))
(loop (cdr lst)
(if (fn item) result (cons item result)))))))
(define-syntax define-guarded
(ir-macro-transformer
(lambda (exp inject compare)
(let* ((name (if (list? (caadr exp))
(car (caadr exp))
(caadr exp)))
(param-handler (lambda (x)
(if (list? x)
(car x)
x)))
(params (map param-handler (cdadr exp)))
(guard-handler (lambda (x)
(if (list? x)
(map (lambda (y) `(,(car y) ,(car x) ,@(cdr y))) (cdr x))
'())))
(guards (map (lambda (guard) `(assert (and ,@guard)))
(filter null? (map guard-handler (cdadr exp)))))
(body (cddr exp))
(r (gensym))
(return-guard (if (list? (caadr exp))
`(and ,@(map (lambda (y) `(,(car y) ,r ,@(cdr y))) (cdr (caadr exp))))
#f)))
`(define (,name ,@params) ,@guards ,@(if return-guard
`((let ((,r (begin ,@body)))
(assert ,return-guard)
,r))
body)))))))