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

Last change on this file since 33417 was 33417, checked in by Kon Lovett, 3 years ago

use setup-helper-mode. remove % forms (segfault).

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