source: project/release/3/F-operator/reflect-reify.scm @ 8904

Last change on this file since 8904 was 8904, checked in by Kon Lovett, 12 years ago

Save.

File size: 4.6 KB
Line 
1;;;; reflect-reify.scm
2;;;; Kon Lovett, Oct 10 '06
3
4(use shift-reset)
5
6;; Monads from shift and reset (from Filinski, POPL '94)
7
8(cond-expand
9  [syntax-case
10
11    (define-syntax (define-bind exp)
12      (syntax-case exp ()
13        [(sk kind body ...)
14          (identifier? #'kind)
15          (with-syntax (
16              [monad (datum->syntax-object #'sk 'monad)]
17              [func (datum->syntax-object #'sk 'func)]
18              [bind
19                (datum->syntax-object #'sk
20                  (string->symbol
21                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
22            #'(define (bind monad func) body ...))] ) )
23
24    (define-syntax (define-unit exp)
25      (syntax-case exp ()
26        [(sk kind body ...)
27          (identifier? #'kind)
28          (with-syntax (
29              [obj (datum->syntax-object #'sk 'obj)]
30              [unit
31                (datum->syntax-object #'sk
32                  (string->symbol
33                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
34            #'(define (unit obj) body ...))] ) )
35
36    (define-syntax (reflect exp)
37      (syntax-case exp ()
38        [(sk kind meaning)
39          (identifier? #'kind)
40          (with-syntax (
41              [bind
42                (datum->syntax-object #'sk
43                  (string->symbol
44                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
45            #'(shift k (bind meaning k)))] ) )
46
47    (define-syntax (reflect-values exp)
48      (syntax-case exp ()
49        [(sk kind meaning)
50          (identifier? #'kind)
51          (with-syntax (
52              [bind
53                (datum->syntax-object #'sk
54                  (string->symbol
55                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
56            #'(shift-values k (bind meaning k)))] ) )
57
58    (define-syntax (%reflect exp)
59      (syntax-case exp ()
60        [(sk kind meaning)
61          (identifier? #'kind)
62          (with-syntax (
63              [bind
64                (datum->syntax-object #'sk
65                  (string->symbol
66                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
67            #'(%shift k (bind meaning k)))] ) )
68
69    (define-syntax (reify exp)
70      (syntax-case exp ()
71        [(sk kind exp)
72          (identifier? #'kind)
73          (with-syntax (
74              [unit
75                (datum->syntax-object #'sk
76                  (string->symbol
77                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
78            #'(reset (unit exp)))] ) )
79
80    (define-syntax (reify-values exp)
81      (syntax-case exp ()
82        [(sk kind exp)
83          (identifier? #'kind)
84          (with-syntax (
85              [unit
86                (datum->syntax-object #'sk
87                  (string->symbol
88                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
89            #'(reset-values (unit exp)))] ) )
90
91    (define-syntax (%reify exp)
92      (syntax-case exp ()
93        [(sk kind exp)
94          (identifier? #'kind)
95          (with-syntax (
96              [unit
97                (datum->syntax-object #'sk
98                  (string->symbol
99                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
100            #'(%reset (unit exp)))] ) ) ]
101
102  [else
103
104    (define-macro (define-bind KIND . BODY)
105      (let ([BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
106        `(define (,BIND monad func) ,@BODY) ) )
107
108    (define-macro (define-unit KIND . BODY)
109      (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
110        `(define (,UNIT obj) ,@BODY) ) )
111
112    (define-macro (reflect KIND MEANING)
113      (let ([K (gensym)]
114            [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
115        `(shift ,K (,BIND ,MEANING ,K)) ) )
116
117    (define-macro (reflect-values KIND MEANING)
118      (let ([K (gensym)]
119            [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
120        `(shift-values ,K (,BIND ,MEANING ,K)) ) )
121
122    (define-macro (%reflect KIND MEANING)
123      (let ([K (gensym)]
124            [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
125        `(%shift ,K (,BIND ,MEANING ,K)) ) )
126
127    (define-macro (reify KIND EXP)
128      (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
129        `(reset (,UNIT ,EXP)) ) )
130
131    (define-macro (reify-values KIND EXP)
132      (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
133        `(reset-values (,UNIT ,EXP)) ) )
134
135    (define-macro (%reify KIND EXP)
136      (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
137        `(%reset (,UNIT ,EXP)) ) ) ] )
Note: See TracBrowser for help on using the repository browser.