-
Notifications
You must be signed in to change notification settings - Fork 0
/
syntax-expand.ss
109 lines (108 loc) · 5.81 KB
/
syntax-expand.ss
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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
(define 1st car)
(define 2nd cadr)
(define 3rd caddr)
(define (syntax-expand parsed-exp)
(cases expression parsed-exp
[lit-exp (datum) (lit-exp datum)]
[var-exp (id) (var-exp id)]
[lambda-exp (re-params op-params bodies)
(lambda-exp re-params op-params (map syntax-expand bodies))]
[ref-lambda-exp (params bodies)
(ref-lambda-exp params (map syntax-expand bodies))]
[if-exp (condition true-body false-body)
(if-exp (syntax-expand condition)
(syntax-expand true-body)
(syntax-expand false-body))]
[define-exp (id val) (define-exp id (syntax-expand val))]
[set!-exp (id val) (set!-exp id (syntax-expand val))]
[let-exp (type vars values bodies)
(cond
[(eq? type 'let)
(app-exp (lambda-exp vars #f (map syntax-expand bodies))
(map syntax-expand values))]
[(eq? type 'let*)
(syntax-expand
(if (null? vars)
(begin-exp bodies)
(let-exp 'let
(list (1st vars))
(list (1st values))
(list (syntax-expand
(let-exp 'let* (cdr vars) (cdr values) bodies))))))]
[(eq? type 'letrec)
(syntax-expand
(let-exp 'let vars values
(append (map set!-exp vars values) bodies)))]
[else ;named let
(syntax-expand
(app-exp
(let-exp 'letrec (list type)
(list (lambda-exp vars #f bodies))
(list (var-exp type)))
values))])]
[app-exp (rator rands) (app-exp (syntax-expand rator) (map syntax-expand rands))]
[begin-exp (bodies) (app-exp (lambda-exp '() #f (map syntax-expand bodies)) '())]
[and-exp (conditions)
(cond
[(null? conditions)
(lit-exp #t)]
[(null? (cdr conditions))
(1st conditions)]
[else
(if-exp (1st conditions)
(syntax-expand (and-exp (cdr conditions)))
(lit-exp #f))])]
[or-exp (conditions)
;; value-name is a unique name to record the value of the current condition
(let ([value-name '_:_or-temp_:_])
(cond
[(null? conditions)
(lit-exp #f)]
[(null? (cdr conditions))
(1st conditions)]
[else
(syntax-expand (let-exp 'let
(list value-name)
(list (1st conditions))
(list (if-exp (var-exp value-name)
(var-exp value-name)
(or-exp (cdr conditions))))))]))]
[case-exp (key patterns bodiess)
(let ([value-name '_:_case-temp_:_])
(syntax-expand
(let-exp 'let
(list value-name)
(list key)
(list (cond-exp ; convert to cond
(map (lambda (pattern)
(if (equal? pattern '(else))
(var-exp 'else)
(app-exp
(var-exp 'memv)
(list (var-exp value-name)
(lit-exp pattern)))))
patterns)
bodiess)))))]
[cond-exp (conditions bodiess) ;list of bodies
(if (null? conditions)
(app-exp (var-exp 'void) '())
(if (equal? (var-exp 'else) (1st conditions))
(syntax-expand (begin-exp (1st bodiess)))
(if-exp (syntax-expand (1st conditions))
(syntax-expand (begin-exp (map syntax-expand (1st bodiess))))
(syntax-expand (cond-exp (cdr conditions) (cdr bodiess))))))]
[while-exp (condition bodies)
(let ((loop-name '_:_loop_:_))
(syntax-expand (let-exp
'let
(list loop-name)
(list (lambda-exp (list loop-name)
#f
(list (if-exp condition
(begin-exp (append bodies
(list (app-exp (var-exp loop-name)
(list (var-exp loop-name))))))
(app-exp (var-exp 'void) '())))))
(list (app-exp (var-exp loop-name) (list (var-exp loop-name)))))))]
[else
(eopl:error 'syntax-expand "Unhandled parsed-exp: ~s" parsed-exp)]))