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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
|
;; Implementation of parallel-execute using call/cc.
;;
;; By Ben Rudiak-Gould, 10/2002.
;;
;; Requires STk (for "procedure-body" and first-class environments).
(define call/cc call-with-current-continuation)
(define (parallel-execute . thunks)
(apply run-concurrently-with-env
random
(map (lambda (thunk)
(cons (list (uncode (procedure-body thunk)))
(make-virtual-env (procedure-environment thunk)) ))
thunks ))
'okay )
(define (run-concurrently select . exprs)
(apply run-concurrently-with-env
select
(map (lambda (x)
(cons x (make-virtual-env (global-environment))) )
exprs )))
(define (run-concurrently-with-env select . exprs-with-envs)
(let ((threads
(map (lambda (exp-env)
(list (call/cc
(lambda (cont)
(let ((scheduler (call/cc cont)))
(scheduler (myeval (car exp-env)
(cdr exp-env)
scheduler )))))))
exprs-with-envs )))
(let loop ()
(let ((active-threads
(filter (lambda (x) (continuation? (car x))) threads) ))
(if (null? active-threads)
(map car threads)
(let ((active (list-ref active-threads
(select (length active-threads)) )))
(set-car! active (call/cc (car active)))
(loop) ))))))
(define (make-virtual-env real-env)
(cons
`((quote **macro** ,macro-quote)
(lambda **macro** ,macro-lambda)
(let **macro** ,macro-let)
(set! **macro** ,macro-set!)
(define **macro** ,macro-define)
(if **macro** ,macro-if)
(cond **macro** ,macro-cond)
(and **macro** ,macro-and)
(or **macro** ,macro-or)
(set-car! **prim** ,prim-set-car!)
(set-cdr! **prim** ,prim-set-cdr!)
(begin **prim** ,prim-begin)
(test-and-set! **prim** ,prim-test-and-set!) )
real-env ))
(define (env-lookup-raw sym env scheduler)
(call/cc scheduler)
(let ((virtual (assq sym (car env))))
(if virtual
(cdr virtual)
(eval sym (cdr env)) )))
(define (env-lookup sym env scheduler)
(let* ((val (env-lookup-raw sym env scheduler))
(proc-body (procedure-body val)) )
(if (and proc-body (not (eq? (cadr proc-body) '**args**)))
(myeval (uncode proc-body)
(make-virtual-env (procedure-environment val))
scheduler )
val )))
(define (env-set! sym val env scheduler)
(call/cc scheduler)
(let ((virtual (assq sym (car env))))
(if virtual
(set-cdr! virtual val)
(eval `(set! ,sym ',val) (cdr env)) )))
(define (env-define! sym val env scheduler)
(call/cc scheduler)
(set-car! env (cons (cons sym val) (car env))) )
(define (get-special-form name env scheduler)
(if (symbol? name)
(let ((val (env-lookup-raw name env scheduler)))
(if (and (pair? val) (eq? (car val) '**macro**))
val
#f ))
#f ))
(define (myeval expr env scheduler)
(cond ((pair? expr)
(let ((special (get-special-form (car expr) env scheduler)))
(if special
((cadr special) (cdr expr) env scheduler)
(let ((evaluated (eval-seq expr env scheduler)))
(myapply (car evaluated) (cdr evaluated) scheduler) ))))
((symbol? expr)
(env-lookup expr env scheduler) )
(else (eval expr)) ))
(define (eval-seq exprs env scheduler)
(if (null? exprs)
'()
(let ((val (myeval (car exprs) env scheduler)))
(cons val (eval-seq (cdr exprs) env scheduler)) )))
(define (myapply func args scheduler)
(cond ((procedure? func)
(apply func args) )
((and (pair? func) (eq? (car func) '**prim**))
((cadr func) args scheduler) )
((and (pair? func) (eq? (car func) '**macro**))
((cadr func) (map (lambda (x) (list 'quote x)) args) scheduler) )
(else (error "apply of non-procedure" func args)) ))
(define (make-call-environment params args env)
(cons (let loop ((params params) (args args))
(cond ((pair? params)
(cons (cons (car params) (car args))
(loop (cdr params) (cdr args)) ))
((null? params)
(car env) )
(else (cons (cons params args) (car env))) ))
(cdr env) ))
(define (macro-lambda args env scheduler)
(let ((params (car args))
(body (cdr args)) )
(lambda **args**
(let ((new-env (make-call-environment params **args** env)))
(last (map (lambda (x) (myeval x new-env scheduler)) body)) ))))
(define (macro-let args env scheduler)
(let ((vars (map car (car args)))
(vals (map cadr (car args)))
(body (cdr args)) )
(myeval `((lambda ,vars ,@body) ,@vals) env scheduler) ))
(define (macro-define args env scheduler)
(if (pair? (car args))
(macro-define `(,(caar args) (lambda ,(cdar args) ,@(cdr args)))
env scheduler )
(let ((val (myeval (cadr args) env scheduler)))
(env-define! (car args) val env scheduler) )))
(define (macro-set! args env scheduler)
(let ((val (myeval (cadr args) env scheduler)))
(env-set! (car args) val env scheduler) ))
(define (macro-quote args env scheduler)
(car args) )
(define (macro-if args env scheduler)
(if (myeval (car args) env scheduler)
(myeval (cadr args) env scheduler)
(if (pair? (cddr args))
(myeval (caddr args) env scheduler)
'okay )))
(define (macro-cond args env scheduler)
(cond ((null? args) 'okay)
((or (eq? (caar args) 'else)
(myeval (caar args) env scheduler) )
(car (last-pair (eval-seq (cdar args) env scheduler))) )
(else (macro-cond (cdr args) env scheduler)) ))
(define (macro-and args env scheduler)
(if (null? args)
#t
(let ((val (myeval (car args) env scheduler)))
(if (null? (cdr args))
val
(and val (macro-and (cdr args) env scheduler)) ))))
(define (macro-or args env scheduler)
(if (null? args)
#f
(let ((val (myeval (car args) env scheduler)))
(if (null? (cdr args))
val
(or val (macro-or (cdr args) env scheduler)) ))))
(define (prim-set-car! args scheduler)
(call/cc scheduler)
(apply set-car! args) )
(define (prim-set-cdr! args scheduler)
(call/cc scheduler)
(apply set-cdr! args) )
(define (prim-begin args scheduler)
(car (last-pair args)) )
(define (prim-test-and-set! args scheduler)
(call/cc scheduler)
(test-and-set! (car args)) )
(define (test-and-set! x)
(let ((oldval (car x)))
(set-car! x #t)
oldval ))
(define (last-pair lst)
(if (null? (cdr lst))
lst
(last-pair (cdr lst)) ))
(load "~cs61a/lib/serial.scm")
|