-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathcek.rkt
135 lines (100 loc) · 4.09 KB
/
cek.rkt
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
#lang racket
(provide cek-interp)
(require (rename-in racket/base (eval racket-eval)))
(define default-prims '(* + - / expt = car cdr cons equal? null?))
(define prims
(foldl (lambda (op env)
(hash-set env op `(clo (λ args (apply-prim ,op args)) #hash())))
'#hash((list . (clo (λ x x) #hash())))
default-prims))
(define (racket-apply proc lst)
(apply proc lst))
(define (cek-interp prog)
; Helper function to check if symbol λ or tag lambda
(define (λ-or-lambda? str)
(match str
[(or (== 'lambda) (== 'λ)) #t]
[else #f]))
(define (eval exp env kont)
;(displayln (~a "\n>>>eval : " (list '--exp: exp '--env: env '--kont: kont)))
(match exp
[(or (? number?) (? boolean?))
(ret exp kont)]
[`(,(? λ-or-lambda?) ,args ,body)
(ret `(clo ,exp ,env) kont)]
[(? symbol? x)
(ret (hash-ref env x
(λ () (raise `(error ,(format "Undefined variable: ~a" x)))))
kont)]
[`(if ,grd, texp, fexp)
(eval grd env `(ifk ,texp ,fexp ,env ,kont))]
[`(and ,e0, e1)
(eval e0 env `(andk ,e1 ,env ,kont))]
[`(or ,e0 ,e1)
(eval e0 env `(ork ,e1 ,env ,kont))]
[`(not ,exp)
(eval exp env `(notk ,env ,kont))]
[`(let ([,xs ,rhs] ...) ,body)
(eval `((λ ,xs ,body) ,@rhs) env kont)]
[`(let* () ,ebody) (eval ebody env kont)]
[`(let* ([,lhs ,rhs] ,e-pairs ...) ,ebody)
(eval `(let ([,lhs ,rhs]) (let* ,e-pairs ,ebody)) env kont)]
[`(call/cc ,e0)
(eval e0 env `(callcc-k ,kont))]
[`(apply ,e0 ,e1)
(eval e0 env `(apply-ark ,e1 ,env ,kont))]
[`(apply-prim ,opr ,x)
(ret (racket-apply (racket-eval opr (make-base-namespace)) (hash-ref env x)) kont)]
[`(,ef ,ea-list ...)
(eval ef env `(app-k () ,ea-list ,env ,kont))]
;[else (raise (format "error occured in eval function! exp: ~a env: ~a kont: ~a " exp env kont))]
[else (raise `(Error occured in eval function!...State: ,exp ,env ,kont))]))
(define (ret val kont)
;(displayln (~a ">>>ret : " (list '--val: val '--kont: kont)))
(match kont
['mt val]
[`(ifk ,texp ,fexp ,this_env ,this_kont)
(if val
(eval texp this_env this_kont)
(eval fexp this_env this_kont))]
[`(andk ,ea ,this_env, this_kont)
(if val
(eval ea this_env this_kont)
(ret val this_kont))]
[`(ork ,ea ,this_env, this_kont)
(if val
(ret val this_kont)
(eval ea this_env this_kont))]
[`(notk ,this_env, this_kont)
(if val
(ret #f this_kont)
(ret #t this_kont))]
[`(callcc-k ,this_kont)
(apply val `((kont ,this_kont)) this_kont)]
[`(apply-ark ,ea ,env ,kont)
(eval ea env `(apply-fnk ,val ,kont))]
[`(apply-fnk ,fv ,kont)
(apply fv val kont)]
[`(app-k ,v-list () ,env ,sub_kont)
(define vals (append v-list `(,val)))
(apply (car vals) (cdr vals) sub_kont)]
[`(app-k ,v-list (,e0 ,e-list ...) ,env ,sub_kont)
(eval e0 env `(app-k ,(append v-list `(,val)) ,e-list ,env ,sub_kont))]
[else (raise `(Error occured in ret function!...State: ,val ,kont))]))
(define (apply vf va-list kont)
;(displayln (~a ">>>apply: " (list '--vf: vf '--va-list: va-list '--kont: kont)))
(match vf
[`(clo (,(? λ-or-lambda?) ,params ,eb) ,env)
(if (symbol? params)
(eval eb (hash-set env params va-list) kont)
(if (= (length params) (length va-list))
(eval eb
(foldl (lambda (x va env) (hash-set env x va)) env params va-list)
kont)
(raise `(Error number of arguments do not match))))]
[`(kont ,this_kont)
(if (= 1 (length va-list))
(ret (first va-list) this_kont)
(raise `(Error occured applying continuation on ,(length va-list) arguments)))]
[else (raise `(Error occured in apply function!...State: ,vf ,va-list ,kont))]))
(eval prog prims 'mt))