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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
#lang plai-typed
;;Inner Expression
(define-type Expr
[Nmb (n : number)]
[Add (l : Expr) (r : Expr)]
[Lambda (para : symbol) (body : Expr)]
[Apply (fun : Expr) (argu : Expr)]
;;var
[Var (e : symbol)]
[Set! (var : symbol) (new : Expr)]
;;ref
[MkRef (sth : Expr)]
[UnRef (ref : Expr)]
[SetRef! (ref : Expr) (new : Expr)]
;;cons
[Cons (first : Expr) (rest : Expr)]
[Car (pair : Expr)]
[Cdr (pair : Expr)]
[Nil])
(define-type Value
[NmbV (n : number)]
[Closure (para : symbol) (body : Expr) (env : Env)]
[Ref (loc : Location)]
[Pair (first : Value) (rest : Value)]
[None])
(define-type Result
[V&R (value : Value) (store : Store)])
(define (add [value-l : Value] [value-r : Value]) : Value
(NmbV (+ (NmbV-n value-l) (NmbV-n value-r))))
;;;Map
(define-type-alias Location number)
(define new-loc
(let ([iter 0])
(lambda ()
(begin
(set! iter (+ 1 iter))
iter))))
;;Environment
(define-type Binding
[Bind (var : symbol) (loc : Location)])
(define-type-alias Env [listof Binding])
(define globle-env empty)
(define extend-env cons)
(define (var->loc [var : symbol] [env : Env]) : Location
(cond
[(empty? env) (error 'var->loc "No such binding")]
[(equal? var (Bind-var (first env))) (Bind-loc (first env))]
[else (var->loc var (rest env))]))
;;Storage
(define-type Storage
[Point (loc : Location) (value : Value)])
(define-type-alias Store [listof Storage])
(define init-store empty)
(define extend-store cons)
(define (loc->value [loc : Location] [store : Store]) : Value
(cond
[(empty? store) (error 'loc->vlaue "No such storage")]
[(equal? loc (Point-loc (first store))) (Point-value (first store))]
[else (loc->value loc (rest store))]))
(define (fresh-store [loc : Location] [value : Value] [store : Store]) : Store
(cond
[(equal? loc (Point-loc (first store)))
(cons (Point loc value)
(rest store))]
[else (cons (first store)
(fresh-store loc value (rest store)))]))
;;;interp
(define (interp [expr : Expr] [env : Env] [store : Store]) : Result
(type-case Expr expr
[Nmb (n) (V&R (NmbV n) store)]
[Var (var) (V&R (loc->value (var->loc var env) store) store)]
[Set! (var new) (type-case Result (interp new env store)
[V&R (value-new store-new)
(let ([where (var->loc var env)])
(V&R value-new
(fresh-store where value-new store-new)))])]
[Lambda (para body) (V&R (Closure para body env) store)]
[Apply (fun argu) (type-case Result (interp fun env store)
[V&R (value-fun store-fun)
(type-case Result (interp argu env store-fun)
[V&R (value-argu store-argu)
(let ([loc* (new-loc)])
(interp (Closure-body value-fun)
(extend-env (Bind (Closure-para value-fun)
loc*)
(Closure-env value-fun))
(extend-store (Point loc*
value-argu)
store-argu)))])])]
[MkRef (expr) (type-case Result (interp expr env store)
[V&R (value-expr store-expr)
(let ([where (new-loc)])
(V&R (Ref where)
(extend-store (Point where value-expr)
store-expr)))])]
[UnRef (ref) (type-case Result (interp ref env store)
[V&R (value-ref store-ref)
(V&R (loc->value (Ref-loc value-ref) store)
store-ref)])]
[SetRef! (ref new) (type-case Result (interp ref env store)
[V&R (value-ref store-ref)
(type-case Result (interp new env store-ref)
[V&R (value-new store-new)
(let ([where (new-loc)])
(V&R value-new
(extend-store (Point where value-new)
(fresh-store where value-new store-new))))])])]
[Add (l r) (type-case Result (interp l env store)
[V&R (value-l store-l)
(type-case Result (interp r env store-l)
[V&R (value-r store-r)
(V&R (add value-l value-r)
store-r)])])]
[Cons (l r) (type-case Result (interp l env store)
[V&R (value-l store-l)
(type-case Result (interp r env store-l)
[V&R (value-r store-r)
(V&R (Pair value-l value-r)
store-r)])])]
[Car (pair) (type-case Result (interp pair env store)
[V&R (value-pair store-pair)
(V&R (Pair-first value-pair)
store-pair)])]
[Cdr (pair) (type-case Result (interp pair env store)
[V&R (value-pair store-pair)
(V&R (Pair-rest value-pair)
store-pair)])]
[Nil () (V&R (None)
store)]))
(define (prase [expr : s-expression]) : Expr
(cond
[(s-exp-number? expr) (Nmb (s-exp->number expr))]
[(s-exp-symbol? expr) (Var (s-exp->symbol expr))]
[(s-exp-list? expr)
(let ([expr-list (s-exp->list expr)])
(cond
[(s-exp-list? (first expr-list))
(Apply (prase (first expr-list))
(prase (second expr-list)))]
[else (case (s-exp->symbol (first expr-list))
[(lambda) (Lambda (s-exp->symbol (second expr-list))
(prase (third expr-list)))]
[(+) (Add (prase (second expr-list))
(prase (third expr-list)))]
;;desugre-while-prase
[(let) (let ([bind (s-exp->list (second expr-list))]
[in (prase (third expr-list))])
(let ([var (s-exp->symbol (first bind))]
[expr (prase (second bind))])
(Apply (Lambda var in)
expr)))]
[(begin) (let ([first (prase (second expr-list))]
[then (prase (third expr-list))])
(Apply (Lambda 'Nil then)
first))]
[(list) (letrec ([cons-list (rest expr-list)]
[prase* (lambda (l) (cond
[(empty? l) (Nil)]
[else (Cons (prase (first cons-list))
(prase* (rest cons-list)))]))])
(prase* cons-list))]
;;list
[(cons) (Cons (prase (second expr-list))
(prase (third expr-list)))]
[(car) (Car (prase (second expr-list)))]
[(cdr) (Cdr (prase (second expr-list)))]
[(nil) (Nil)]
;;ref&set
[(ref) (MkRef (prase (second expr-list)))]
[(unref) (UnRef (prase (second expr-list)))]
[(setref!) (SetRef! (prase (second expr-list))
(prase (third expr-list)))]
[(set!) (Set! (s-exp->symbol (second expr-list))
(prase (third expr-list)))])]))]))
(define (eval [expr : s-expression])
(type-case Result (interp (prase expr) globle-env init-store)
[V&R (value store)
value]))
|
近期评论