Skip to content

Commit 353111b

Browse files
dvanhorndvanhorn
committed
Interp for letrec and desugar.
1 parent 5b84346 commit 353111b

4 files changed

Lines changed: 132 additions & 36 deletions

File tree

‎www/notes/loot/interp-defun.rkt‎

Lines changed: 18 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
#lang racket
22
(provide (all-defined-out))
3+
(require "syntax.rkt")
34

45
;; type Expr =
56
;; ...
@@ -11,10 +12,11 @@
1112

1213
;; type Function =
1314
;; | `(closure ,Formals ,Expr ,Env)
15+
;; | `(rec-closure ,Lambda ,(-> Env))
1416

1517
;; Expr -> Answer
1618
(define (interp e)
17-
(interp-env e '()))
19+
(interp-env (desugar e) '()))
1820

1921
;; Expr REnv -> Answer
2022
(define (interp-env e r)
@@ -39,6 +41,17 @@
3941
['err 'err]
4042
[v
4143
(interp-env e1 (ext r x v))])]
44+
[`(letrec ,bs ,e)
45+
(letrec ((r* (λ ()
46+
(append
47+
(zip (map first bs)
48+
;; η-expansion to delay evaluating r*
49+
;; relies on RHSs being functions
50+
(map (λ (l) `(rec-closure ,l ,r*))
51+
(map second bs)))
52+
r))))
53+
(interp-env e (r*)))]
54+
4255
[`(λ (,xs ...) ,e)
4356
`(closure ,xs ,e ,r)]
4457
[`(,e . ,es)
@@ -50,6 +63,7 @@
5063
(define (function? f)
5164
(match f
5265
[`(closure . ,_) #t]
66+
[`(rec-closure . ,_) #t]
5367
[_ #f]))
5468

5569
;; Function Value ... -> Answer
@@ -58,7 +72,9 @@
5872
[`(closure ,xs ,e ,r)
5973
(if (= (length xs) (length vs))
6074
(interp-env e (append (zip xs vs) r))
61-
'err)]))
75+
'err)]
76+
[`(rec-closure (λ (,xs ...) ,e) ,r*)
77+
(apply apply-function `(closure ,xs ,e ,(r*)) vs)]))
6278

6379

6480
;; (Listof Expr) REnv -> (Listof Value) | 'err

‎www/notes/loot/interp.rkt‎

Lines changed: 13 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
#lang racket
22
(provide (all-defined-out))
3+
(require "syntax.rkt")
34

45
;; type Expr =
56
;; ...
@@ -13,7 +14,7 @@
1314
;; | (Values ... -> Answer)
1415

1516
(define (interp e)
16-
(interp-env e '()))
17+
(interp-env (desugar e) '()))
1718

1819
;; Expr REnv -> Answer
1920
(define (interp-env e r)
@@ -37,7 +38,17 @@
3738
(match (interp-env e0 r)
3839
['err 'err]
3940
[v
40-
(interp-env e1 (ext r x v))])]
41+
(interp-env e1 (ext r x v))])]
42+
[`(letrec ,bs ,e)
43+
(letrec ((r* (λ ()
44+
(append
45+
(zip (map first bs)
46+
;; η-expansion to delay evaluating r*
47+
;; relies on RHSs being functions
48+
(map (λ (l) (λ vs (apply (interp-env l (r*)) vs)))
49+
(map second bs)))
50+
r))))
51+
(interp-env e (r*)))]
4152
[`(λ (,xs ...) ,e)
4253
(λ vs
4354
(if (= (length vs) (length xs))
@@ -51,7 +62,6 @@
5162
'err)]
5263
[_ 'err])]))
5364

54-
5565
;; (Listof Expr) REnv -> (Listof Value) | 'err
5666
(define (interp-env* es r)
5767
(match es

‎www/notes/loot/test/compile.rkt‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -71,6 +71,7 @@
7171
(f 5)))
7272
5)
7373

74+
;; Loot tests
7475
(check-equal? (run '((λ (x) x) 7)) 7)
7576
(check-equal? (run '(((λ (x) (λ (y) x)) 7) 8)) 7)
7677
(check-equal? (run '((λ (f) (f 0)) (λ (x) (add1 x)))) 1)
@@ -130,4 +131,3 @@
130131
(cons (λ (x) (sub1 x))
131132
'())))))
132133
'(1 -1))
133-

‎www/notes/loot/test/interp.rkt‎

Lines changed: 100 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -34,41 +34,40 @@
3434
(check-equal? (run '(unbox 8)) 'err)
3535

3636
;; Iniquity tests
37-
#|
3837
(check-equal? (run
39-
'(begin (define (f x) x)
40-
(f 5)))
41-
5)
38+
'(begin (define (f x) x)
39+
(f 5)))
40+
5)
4241

4342
(check-equal? (run
44-
'(begin (define (tri x)
45-
(if (zero? x)
46-
0
47-
(+ x (tri (sub1 x)))))
48-
(tri 9)))
43+
'(begin (define (tri x)
44+
(if (zero? x)
45+
0
46+
(+ x (tri (sub1 x)))))
47+
(tri 9)))
4948
45)
5049

5150
(check-equal? (run
52-
'(begin (define (even? x)
53-
(if (zero? x)
54-
#t
55-
(odd? (sub1 x))))
56-
(define (odd? x)
57-
(if (zero? x)
58-
#f
59-
(even? (sub1 x))))
60-
(even? 101)))
61-
#f)
51+
'(begin (define (even? x)
52+
(if (zero? x)
53+
#t
54+
(odd? (sub1 x))))
55+
(define (odd? x)
56+
(if (zero? x)
57+
#f
58+
(even? (sub1 x))))
59+
(even? 101)))
60+
#f)
6261

6362
(check-equal? (run
64-
'(begin (define (map-add1 xs)
65-
(if (empty? xs)
66-
'()
67-
(cons (add1 (car xs))
68-
(map-add1 (cdr xs)))))
69-
(map-add1 (cons 1 (cons 2 (cons 3 '()))))))
70-
'(2 3 4))
71-
|#
63+
'(begin (define (map-add1 xs)
64+
(if (empty? xs)
65+
'()
66+
(cons (add1 (car xs))
67+
(map-add1 (cdr xs)))))
68+
(map-add1 (cons 1 (cons 2 (cons 3 '()))))))
69+
'(2 3 4))
70+
7271

7372
;; Loot examples
7473

@@ -86,7 +85,78 @@
8685
1
8786
(+ n (tri (sub1 n)))))))
8887
10))
89-
56))
88+
56)
89+
90+
91+
(check-equal? (run
92+
'(begin (define (map-add1 xs)
93+
(if (empty? xs)
94+
'()
95+
(cons (add1 (car xs))
96+
(map-add1 (cdr xs)))))
97+
(map-add1 (cons 1 (cons 2 (cons 3 '()))))))
98+
'(2 3 4))
99+
(check-equal? (run '(begin (define (f x) x)
100+
f))
101+
'procedure)
102+
(check-equal? (run '(begin (define (f x) x)
103+
(f 5)))
104+
5)
105+
106+
(check-equal? (run '((λ (f) (f 0)) (λ (x) (add1 x)))) 1)
107+
(check-equal? (run '((λ (f) (f (f 0))) (λ (x) (add1 x)))) 2)
108+
(check-equal? (run '((let ((y 8)) (car (cons (λ (x) y) '()))) 2)) 8)
109+
(check-equal? (run '(let ((y 8)) ((car (cons (λ (x) y) '())) 2))) 8)
110+
111+
(check-equal?
112+
(run
113+
'(begin (define (map f ls)
114+
(if (empty? ls)
115+
'()
116+
(cons (f (car ls)) (map f (cdr ls)))))
117+
118+
(map (λ (f) (f 0))
119+
(cons (λ (x) (add1 x))
120+
(cons (λ (x) (sub1 x))
121+
'())))))
122+
'(1 -1))
123+
124+
(check-equal?
125+
(run
126+
'(begin (define (map f ls)
127+
(letrec ((mapper (λ (ls)
128+
(if (empty? ls)
129+
'()
130+
(cons (f (car ls)) (mapper (cdr ls)))))))
131+
(mapper ls)))
132+
(map (λ (f) (f 0))
133+
(cons (λ (x) (add1 x))
134+
(cons (λ (x) (sub1 x))
135+
'())))))
136+
'(1 -1))
137+
138+
(check-equal?
139+
(run
140+
'(begin (define (map f ls)
141+
(begin (define (mapper ls)
142+
(if (empty? ls)
143+
'()
144+
(cons (f (car ls)) (mapper (cdr ls)))))
145+
(mapper ls)))
146+
(map (λ (f) (f 0))
147+
(cons (λ (x) (add1 x))
148+
(cons (λ (x) (sub1 x))
149+
'())))))
150+
'(1 -1)))
151+
152+
(test-suite
153+
(λ (e)
154+
(match (interp e)
155+
[(? procedure?) 'procedure]
156+
[v v])))
90157

91-
(test-suite interp)
92-
(test-suite defun:interp)
158+
(test-suite
159+
(λ (e)
160+
(match (defun:interp e)
161+
[(? defun:function?) 'procedure]
162+
[v v])))

0 commit comments

Comments
 (0)