source: project/release/4/F-operator/trunk/reflect-reify.scm @ 16205

Last change on this file since 16205 was 16205, checked in by Kon Lovett, 10 years ago

Has lambda-info

File size: 3.0 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.