Skip to content

Commit 98b90f4

Browse files
dvanhorndvanhorn
committed
Start of pattern matching (Mug).
1 parent 1569180 commit 98b90f4

File tree

3 files changed

+438
-0
lines changed

3 files changed

+438
-0
lines changed

‎www/notes/mug/interp.rkt‎

Lines changed: 124 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,124 @@
1+
#lang racket
2+
(provide (all-defined-out))
3+
(require "syntax.rkt")
4+
5+
;; type Expr =
6+
;; ...
7+
;; | `(λ ,(Listof Variable) ,Expr)
8+
9+
;; type Value =
10+
;; ...
11+
;; | Function
12+
13+
;; type Function =
14+
;; | (Values ... -> Answer)
15+
16+
;; TODO: add symbols
17+
18+
(define (interp e)
19+
(interp-env (desugar e) '()))
20+
21+
;; Expr REnv -> Answer
22+
(define (interp-env e r)
23+
(match e
24+
[''() '()]
25+
[(? syntactic-value? v) v]
26+
[(list (? prim? p) es ...)
27+
(match (interp-env* es r)
28+
[(list vs ...) (interp-prim p vs)]
29+
[_ 'err])]
30+
[`(if ,e0 ,e1 ,e2)
31+
(match (interp-env e0 r)
32+
['err 'err]
33+
[v
34+
(if v
35+
(interp-env e1 r)
36+
(interp-env e2 r))])]
37+
[(? symbol? x)
38+
(lookup r x)]
39+
[`(let ((,x ,e0)) ,e1)
40+
(match (interp-env e0 r)
41+
['err 'err]
42+
[v
43+
(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) (λ vs (apply (interp-env l (r*)) vs)))
51+
(map second bs)))
52+
r))))
53+
(interp-env e (r*)))]
54+
[`(λ (,xs ...) ,e)
55+
(λ vs
56+
(if (= (length vs) (length xs))
57+
(interp-env e (append (zip xs vs) r))
58+
'err))]
59+
[`(,e . ,es)
60+
(match (interp-env* (cons e es) r)
61+
[(list f vs ...)
62+
(if (procedure? f)
63+
(apply f vs)
64+
'err)]
65+
[_ 'err])]))
66+
67+
;; (Listof Expr) REnv -> (Listof Value) | 'err
68+
(define (interp-env* es r)
69+
(match es
70+
['() '()]
71+
[(cons e es)
72+
(match (interp-env e r)
73+
['err 'err]
74+
[v (cons v (interp-env* es r))])]))
75+
76+
;; Any -> Boolean
77+
(define (prim? x)
78+
(and (symbol? x)
79+
(memq x '(add1 sub1 + - zero?
80+
box unbox empty? cons car cdr))))
81+
82+
;; Any -> Boolean
83+
(define (syntactic-value? x)
84+
(or (integer? x)
85+
(boolean? x)
86+
(null? x)))
87+
88+
;; Prim (Listof Value) -> Answer
89+
(define (interp-prim p vs)
90+
(match (cons p vs)
91+
[(list 'add1 (? integer? i0)) (add1 i0)]
92+
[(list 'sub1 (? integer? i0)) (sub1 i0)]
93+
[(list 'zero? (? integer? i0)) (zero? i0)]
94+
[(list 'box v0) (box v0)]
95+
[(list 'unbox (? box? v0)) (unbox v0)]
96+
[(list 'empty? v0) (empty? v0)]
97+
[(list 'cons v0 v1) (cons v0 v1)]
98+
[(list 'car (cons v0 v1)) v0]
99+
[(list 'cdr (cons v0 v1)) v1]
100+
[(list '+ (? integer? i0) (? integer? i1))
101+
(+ i0 i1)]
102+
[(list '- (? integer? i0) (? integer? i1))
103+
(- i0 i1)]
104+
[_ 'err]))
105+
106+
;; Env Variable -> Answer
107+
(define (lookup env x)
108+
(match env
109+
['() 'err]
110+
[(cons (list y i) env)
111+
(match (symbol=? x y)
112+
[#t i]
113+
[#f (lookup env x)])]))
114+
115+
;; Env Variable Value -> Value
116+
(define (ext r x i)
117+
(cons (list x i) r))
118+
119+
(define (zip xs ys)
120+
(match* (xs ys)
121+
[('() '()) '()]
122+
[((cons x xs) (cons y ys))
123+
(cons (list x y)
124+
(zip xs ys))]))

‎www/notes/mug/pat.rkt‎

Lines changed: 198 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,198 @@
1+
#lang racket
2+
(provide match->cond)
3+
4+
;; type Expr+ =
5+
;; ....
6+
;; | Match
7+
8+
;; type Match = (match ,Expr+ ,(list Pat Expr+) ...)
9+
10+
;; type Pat =
11+
;; | #t
12+
;; | #f
13+
;; | Integer
14+
;; | String
15+
;; | '()
16+
;; | Variable
17+
;; | `(quote ,Symbol)
18+
;; | `(cons ,Pat ,Pat)
19+
;; | `(list ,Pat ...)
20+
;; | `(? ,Expr ,Pat ...)
21+
22+
;; Match -> Expr
23+
;; Rewrite match expression into an equivalent cond expression
24+
(define (match->cond m)
25+
(match m
26+
[`(match ,e . ,mcs)
27+
(let ((x (gensym)))
28+
`(let ((,x ,e))
29+
(cond ,@(map (λ (mc)
30+
(match mc
31+
[(list p e)
32+
(list (pat-match p x) (pat-bind p x e))]))
33+
mcs)
34+
;; fall through to error
35+
[else (car '())])))]))
36+
37+
;; Example
38+
#;
39+
(define (sum bt)
40+
(match bt
41+
['leaf 0]
42+
[(list 'node v l r)
43+
(+ v
44+
(+ (sum l)
45+
(sum r)))]))
46+
#;
47+
(define (sum^ bt)
48+
(cond
49+
[(eq? 'leaf bt) 0]
50+
[(and (list? bt)
51+
(= 4 (length bt))
52+
(eq? 'node (first bt)))
53+
(let ((v (second bt))
54+
(l (third bt))
55+
(r (fourth bt)))
56+
(+ v
57+
(+ (sum l)
58+
(sum r))))]))
59+
60+
#;
61+
`(define (sum bt)
62+
,(match->cond
63+
'(match bt
64+
['leaf 0]
65+
[(list 'node v l r)
66+
(+ v
67+
(+ (sum l)
68+
(sum r)))])))
69+
70+
;; Two tasks:
71+
;; 1. rewrite patterns into Boolean valued expressions that answer
72+
;; whether the pattern matches the scrutiny
73+
;; 2. rewrite pattern and RHS in to expressions in which the pattern variables
74+
;; of pattern are bound to the appropriately deconstructed parts of the scrutiny
75+
76+
;; Assume: the scrutiny is a variable.
77+
;; (It's easy to establish this assumption in general.)
78+
79+
;; Two functions:
80+
81+
#;
82+
;; Pat Variable -> Expr
83+
;; Produces an expression determining if p matches v
84+
(define (pat-match p v) ...)
85+
86+
#;
87+
;; Pat Variable Expr -> Expr
88+
;; Produce an expression that deconstructs v and binds pattern variables
89+
;; of p in scope of e.
90+
;; ASSUME: v matches p
91+
(define (pat-bind p v e) ...)
92+
93+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94+
;; Pattern matching
95+
96+
;; Pat Variable -> Expr
97+
;; Produces an expression determining if p matches v
98+
(define (pat-match p v)
99+
(match p
100+
[#t `(eq? #t ,v)]
101+
[#f `(eq? #f ,v)]
102+
[(? integer? i) `(eq? ,i ,v)]
103+
[(? string? s)
104+
`(and (string? ,v)
105+
(string=? ,s ,v))]
106+
[''() `(eq? '() ,v)]
107+
[(? symbol?) #t]
108+
[`',(? symbol? s) `(eq? ,v ',s)]
109+
[`(cons ,p1 ,p2)
110+
(let ((v1 (gensym))
111+
(v2 (gensym)))
112+
`(and (cons? ,v)
113+
(let ((,v1 (car ,v))
114+
(,v2 (cdr ,v)))
115+
(and ,(pat-match p1 v1)
116+
,(pat-match p2 v2)))))]
117+
[`(list . ,ps)
118+
`(and (list? ,v)
119+
(= (length ,v) ,(length ps))
120+
,(pat-match-list ps v))]
121+
[`(? ,e . ,ps)
122+
`(and (,e ,v)
123+
,(pats-match ps v))]))
124+
125+
;; (Listof Pat) Variable -> Expr
126+
;; Produces an expression determining if every ps matches x
127+
(define (pats-match ps v)
128+
(match ps
129+
['() #t]
130+
[(cons p ps)
131+
`(and ,(pat-match p v)
132+
,(pats-match ps v))]))
133+
134+
;; (Listof Pat) Variable -> Expr
135+
;; Produces an expression determining if each ps matches each element of list v
136+
(define (pat-match-list ps v)
137+
(match ps
138+
['() #t]
139+
[(cons p ps)
140+
(let ((v1 (gensym))
141+
(v2 (gensym)))
142+
`(let ((,v1 (car ,v))
143+
(,v2 (cdr ,v)))
144+
(and ,(pat-match p v1)
145+
,(pat-match-list ps v2))))]))
146+
147+
148+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
149+
;; Pattern binding
150+
151+
;; Pat Variable Expr -> Expr
152+
;; Produce an expression that deconstructs v and binds pattern variables
153+
;; of p in scope of e.
154+
;; ASSUME: v matches p
155+
(define (pat-bind p v e)
156+
(match p
157+
[#t e]
158+
[#f e]
159+
[(? integer?) e]
160+
[(? string?) e]
161+
[''() e]
162+
[(? symbol? x) `(let ((,x ,v)) ,e)]
163+
[`',(? symbol?) e]
164+
[`(cons ,p1 ,p2)
165+
(let ((v1 (gensym))
166+
(v2 (gensym)))
167+
`(let ((,v1 (car ,v))
168+
(,v2 (cdr ,v)))
169+
,(pat-bind p1 v1
170+
(pat-bind p2 v2 e))))]
171+
[`(list . ,ps)
172+
(pat-bind-list ps v e)]
173+
[`(? ,_ . ,ps)
174+
(pats-bind ps v e)]))
175+
176+
;; (Listof Pat) Variable Expr -> Expr
177+
;; Produce an expression that doconstructs v and binds pattern variables
178+
;; of ps (each matched against v) in scope of e.
179+
;; ASSUME: v matches every element of ps
180+
(define (pats-bind ps v e)
181+
(match ps
182+
['() e]
183+
[(cons p ps)
184+
(pat-bind p v (pats-bind ps v e))]))
185+
186+
;; (Listof Pat) Variable Expr -> Expr
187+
;; Produce an expression that deconstructs list v and binds pattern variables
188+
;; of ps (matched element-wise against v) in scope of e.
189+
;; ASSUME: elemens of v matches elements of ps
190+
(define (pat-bind-list ps v e)
191+
(match ps
192+
['() e]
193+
[(cons p ps)
194+
(let ((v1 (gensym))
195+
(v2 (gensym)))
196+
`(let ((,v1 (car ,v))
197+
(,v2 (cdr ,v)))
198+
,(pat-bind p v1 (pat-bind-list ps v2 e))))]))

0 commit comments

Comments
 (0)