scheme-pearls/interp-shift.rkt at main · evalwhen/scheme-pearls · GitHub

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
#lang racket

(require racket/control)

(define empty-env '())

(define ext-env
  (lambda (name value old-env)
    (cons (cons name value) old-env)))

(define op-map
  `((+ . ,+)
    (- . ,-)
    (* . ,*)
    (/ . ,/)))

(define id (lambda (x) x))

(define interp1
  (lambda (exp env)
    (match exp
      [(? number? exp)
       exp]
      [(? symbol? exp)
       (let ([p (assq exp env)])
         (cond
           [(not p)
            (error "Unbound variable: " exp)]
           [else
            (cdr p)]))]
      [`(lambda (,param) ,body)
       `(closure ,exp ,env)]
      [`(,op ,e1 ,e2)
       (let ([p (assq op op-map)])
         (cond
           [(not p)
            (error "Unsupported op: " op)]
           [else
            (let ([op-fun (cdr p)])
              (op-fun (interp1 e1 env) (interp1 e2 env)))]))]
      [`(,op ,arg)
       (let ([op-value (interp1 op env)]
             [arg-value (interp1 arg env)])
         (match op-value
           [`(closure (lambda (,param) ,body) ,closure-env)
            (let ([new-env (ext-env param arg-value closure-env)])
              (interp1 body new-env))]
           [_
            (error "Calling non-function: " op)]))])))

(define interp
  (lambda (exp)
    (interp1 exp '())))


(define interp-cps1
  (lambda (exp env k)
    (match exp
      [(? number? exp)
       (k exp)]

      [(? symbol? exp)
       (let ([p (assq exp env)])
         (cond
           [(not p)
            (error "Unbound variable: " exp)]
           [else
            (k (cdr p))]))]
      [`(lambda (,param) ,body)
       (k `(closure ,exp ,env))]

      [`(call/cc (lambda (,param) ,body))
       (let ([new-env (ext-env param `(callcc-k ,k) env)])
         (interp-cps1 body new-env k))]

      [`(shift ,param ,body)
       (let ([new-env (ext-env param `(shift-k ,k) env)])
         (interp-cps1 body new-env id))]

      ;; eval the body of reset at a new evaluation context
      [`(reset ,e)
       (k (interp-cps1 e env id))]

      [`(,op ,e1 ,e2)
       (let ([p (assq op op-map)])
         (cond
           [(not p)
            (error "Unsupported op: " op)]
           [else
            (let ([op-fun (cdr p)])
              ; (op-fun (interp e1 env) (interp e2 env))
              (interp-cps1 e1 env
                      (lambda (v1)
                        (interp-cps1 e2 env
                                (lambda (v2)
                                  (k (op-fun v1 v2)))))))]))]

      [`(,op ,arg)
       (interp-cps1 op env
               (lambda (op-value)
                 (interp-cps1 arg env
                         (lambda (arg-value)
                           (match op-value
                             [`(closure (lambda (,param) ,body) ,closure-env)
                               (let ([new-env (ext-env param arg-value closure-env)])
                                 (interp-cps1 body new-env k))]
                             [`(callcc-k ,ck)
                              (ck arg-value)]
                             [`(shift-k ,sk)
                              (k (sk arg-value))]
                             [_
                              (error "Calling non-function: " op)])))))])))


(define interp-cps
  (lambda (exp)
    (interp-cps1 exp '() (lambda (x) x))))


(interp-cps '(+ 1 (* 2 3)))
;; => 7

(interp-cps '(((lambda (x) (lambda (y) (+ x y))) 2) 3))
;; => 5

(interp-cps '(+ 1 (call/cc (lambda (k) (+ 10 (k 5))))))
;; => 6

(interp-cps '(+ 1 (reset (+ 1 (+ 1 (shift k (k 10)))))))
;; => 13

(interp-cps '(+ 1 (reset (+ 1 (+ 1 (shift k (+ (k 0) (k 0))))))))
;; => 5

(interp-cps '(+ 1 (reset (+ 1 (+ 1 (shift k 10))))))
;; => 11


;; Scheme call/cc examples

(+ 1 (call/cc (lambda (k) (+ 10 (k 5)))))
;; => 6
(+ 1 (call/cc (lambda (k) (+ 10 5))))
;; => 16


(define cc1 (lambda (x) x))

(+ 1 (call/cc (lambda (k) (set! cc1 k) (+ 10 (k 5)))))
;; => 6

(cc1 6)
;; => 7


(define fact
  (lambda (n)
    (cond
      [(= n 0) 1]
      [else
       (* n (fact (- n 1)))])))


(define cc2 (lambda (x) x))

(let ([x (fact 5)]
      [y (call/cc (lambda (k) (set! cc2 k) (k (* 2 3))))])
  (+ x y))
;; => 126

(cc2 100)
;; => 220