forked from samirose/sicp-compiler-project
-
Notifications
You must be signed in to change notification settings - Fork 0
/
pattern-match.sls
43 lines (34 loc) · 1.06 KB
/
pattern-match.sls
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
#!r6rs
(library
(pattern-match)
(export pattern-match? ?? ??*)
(import (rnrs base)
(rnrs lists))
(define (pattern-match? pat exp)
(cond
((null? pat) (null? exp))
((pair? pat)
(let ((pat-head (car pat)))
(cond
((memq pat-head list-matchers)
(and (or (pair? exp) (null? exp))
(pat-head (cdr pat) exp)))
((pair? exp)
(and (pattern-match? (car pat) (car exp))
(pattern-match? (cdr pat) (cdr exp))))
(else #f))))
((memq pat list-matchers) #f)
((procedure? pat) (pat exp))
((boolean? pat) (eq? pat exp))
((symbol? pat) (eq? pat exp))
((number? pat) (and (number? exp) (= pat exp)))
((string? pat) (and (string? exp) (eqv? pat exp)))
(else (error "Pattern matching not supported for" exp))))
(define (?? exp) #t)
(define (scan-match pat exp)
(cond ((null? exp) (null? pat))
((pattern-match? pat exp) #t)
(else (scan-match pat (cdr exp)))))
(define ??* scan-match)
(define list-matchers (list ??*))
)