1 | ;;;; reflect-reify.scm |
---|
2 | ;;;; Kon Lovett, Oct 10 '06 |
---|
3 | |
---|
4 | ;; Monads from shift and reset (from Filinski, POPL '94) |
---|
5 | |
---|
6 | (module reflect-reify (;export |
---|
7 | ;; |
---|
8 | define-bind define-unit |
---|
9 | reflect reflect-values %reflect |
---|
10 | reify reify-values %reify |
---|
11 | ;; |
---|
12 | shift reset) |
---|
13 | |
---|
14 | (import scheme chicken shift-reset) |
---|
15 | |
---|
16 | (require-library shift-reset) |
---|
17 | |
---|
18 | (define-for-syntax (suffix-identifier id sym) |
---|
19 | (string->symbol (conc (strip-syntax id) #\- (strip-syntax sym))) ) |
---|
20 | |
---|
21 | (define-for-syntax (bind-identifier id) (suffix-identifier id 'bind)) |
---|
22 | |
---|
23 | (define-for-syntax (unit-identifier id) (suffix-identifier id 'unit)) |
---|
24 | |
---|
25 | (define-syntax define-bind |
---|
26 | (er-macro-transformer |
---|
27 | (lambda (frm rnm cmp) |
---|
28 | (##sys#check-syntax 'define-bind frm '(_ symbol _ . _)) |
---|
29 | (let ((_define (rnm 'define))) |
---|
30 | (let ((kind (cadr frm)) |
---|
31 | (body (cddr frm)) ) |
---|
32 | `(,_define (,(bind-identifier kind) monad func) ,@body) ) ) ) ) ) |
---|
33 | |
---|
34 | (define-syntax define-unit |
---|
35 | (er-macro-transformer |
---|
36 | (lambda (frm rnm cmp) |
---|
37 | (##sys#check-syntax 'define-unit frm '(_ symbol _ . _)) |
---|
38 | (let ((_define (rnm 'define))) |
---|
39 | (let ((kind (cadr frm)) |
---|
40 | (body (cddr frm)) ) |
---|
41 | `(,_define (,(unit-identifier kind) obj) ,@body) ) ) ) ) ) |
---|
42 | |
---|
43 | (define-syntax reflect |
---|
44 | (er-macro-transformer |
---|
45 | (lambda (frm rnm cmp) |
---|
46 | (##sys#check-syntax 'reflect frm '(_ symbol _)) |
---|
47 | (let ((_shift (rnm 'shift))) |
---|
48 | (let ((kind (cadr frm)) |
---|
49 | (meaning (caddr frm)) ) |
---|
50 | `(,_shift k (,(bind-identifier kind) ,meaning k)) ) ) ) ) ) |
---|
51 | |
---|
52 | (define-syntax reflect-values |
---|
53 | (er-macro-transformer |
---|
54 | (lambda (frm rnm cmp) |
---|
55 | (##sys#check-syntax 'reflect-values frm '(_ symbol _)) |
---|
56 | (let ((_shift-values (rnm 'shift-values))) |
---|
57 | (let ((kind (cadr frm)) |
---|
58 | (meaning (caddr frm)) ) |
---|
59 | `(,_shift-values k (,(bind-identifier kind) ,meaning k)) ) ) ) ) ) |
---|
60 | |
---|
61 | (define-syntax %reflect |
---|
62 | (er-macro-transformer |
---|
63 | (lambda (frm rnm cmp) |
---|
64 | (##sys#check-syntax '%reflect frm '(_ symbol _)) |
---|
65 | (let ((_%shift (rnm '%shift))) |
---|
66 | (let ((kind (cadr frm)) |
---|
67 | (meaning (caddr frm)) ) |
---|
68 | `(,_%shift k (,(bind-identifier kind) ,meaning k)) ) ) ) ) ) |
---|
69 | |
---|
70 | (define-syntax reify |
---|
71 | (er-macro-transformer |
---|
72 | (lambda (frm rnm cmp) |
---|
73 | (##sys#check-syntax 'reify frm '(_ symbol _)) |
---|
74 | (let ((_reset (rnm 'reset))) |
---|
75 | (let ((kind (cadr frm)) |
---|
76 | (expr (caddr frm)) ) |
---|
77 | `(,_reset (,(unit-identifier kind) ,expr)) ) ) ) ) ) |
---|
78 | |
---|
79 | (define-syntax reify-values |
---|
80 | (er-macro-transformer |
---|
81 | (lambda (frm rnm cmp) |
---|
82 | (##sys#check-syntax 'reify-values frm '(_ symbol _)) |
---|
83 | (let ((_reset-values (rnm 'reset-values))) |
---|
84 | (let ((kind (cadr frm)) |
---|
85 | (expr (caddr frm)) ) |
---|
86 | `(,_reset-values (,(unit-identifier kind) ,expr)) ) ) ) ) ) |
---|
87 | |
---|
88 | (define-syntax %reify |
---|
89 | (er-macro-transformer |
---|
90 | (lambda (frm rnm cmp) |
---|
91 | (##sys#check-syntax '%reify frm '(_ symbol _)) |
---|
92 | (let ((_%reset (rnm '%reset))) |
---|
93 | (let ((kind (cadr frm)) |
---|
94 | (expr (caddr frm)) ) |
---|
95 | `(,_%reset (,(unit-identifier kind) ,expr)) ) ) ) ) ) |
---|
96 | |
---|
97 | ) ;module reflect-reify |
---|