gdritter repos when-computer / 9e9eb80
added match-case just in, uh, case Getty Ritter 9 years ago
1 changed file(s) with 161 addition(s) and 0 deletion(s). Collapse all Expand all
+161
-0
generator/match-case-simple.scm less more
1 (declare (unit match-case-simple))
2 ; A simple linear pattern matcher
3 ; It is efficient (generates code at macro-expansion time) and simple:
4 ; it should work on any R5RS Scheme system.
5 ;
6 ; It was first developed for the leanTAP theorem prover in miniKanren.
7 ; It has been in the miniKanren repository
8 ; http://kanren.sf.net/viewvc/kanren/kanren/mini/leanTAP.scm?view=log
9 ; since August 2005.
10 ;
11 ; See the above code for the example of using match-case-simple:
12 ; transforming a first-order logic formula to the Negation Normal Form.
13
14
15 ; (match-case-simple exp <clause> ...[<else-clause>])
16 ; <clause> ::= (<pattern> <guard> exp ...)
17 ; <else-clause> ::= (else exp ...)
18 ; <guard> ::= boolean exp | ()
19 ; <pattern> :: =
20 ; ,var -- matches always and binds the var
21 ; pattern must be linear! No check is done
22 ; __ -- matches always
23 ; 'exp -- comparison with exp (using equal?)
24 ; exp -- comparison with exp (using equal?)
25 ; (<pattern1> <pattern2> ...) -- matches the list of patterns
26 ; (<pattern1> . <pattern2>) -- ditto
27 ; () -- matches the empty list
28
29 ; In the original version, the always-matching pattern was specified
30 ; as a simple underscore. That does not work in R6RS which reserves
31 ; the underscore. Therefore, the always-matching pattern is changed
32 ; to two underscores.
33
34 (define-syntax match-case-simple
35 (syntax-rules ()
36 ((_ exp clause ...)
37 (let ((val-to-match exp))
38 (match-case-simple* val-to-match clause ...)))))
39
40 (define (match-failure val)
41 (error "failed match" val))
42
43 (define-syntax match-case-simple*
44 (syntax-rules (else)
45 ((_ val (else exp ...))
46 (let () exp ...))
47 ((_ val)
48 (match-failure val))
49 ((_ val (pattern () exp ...) . clauses)
50 (let ((fail (lambda () (match-case-simple* val . clauses))))
51 ; note that match-pattern may do binding. Here,
52 ; other clauses are outside of these binding
53 (match-pattern val pattern (let () exp ...) (fail))))
54 ((_ val (pattern guard exp ...) . clauses)
55 (let ((fail (lambda () (match-case-simple* val . clauses))))
56 (match-pattern val pattern
57 (if guard (let () exp ...) (fail))
58 (fail))))
59 ))
60
61
62 ; (match-pattern val pattern kt kf)
63 (define-syntax match-pattern
64 (syntax-rules (__ quote unquote)
65 ((_ val __ kt kf) kt)
66 ((_ val () kt kf)
67 (if (null? val) kt kf))
68 ((_ val (quote lit) kt kf)
69 (if (equal? val (quote lit)) kt kf))
70 ((_ val (unquote var) kt kf)
71 (let ((var val)) kt))
72 ((_ val (x . y) kt kf)
73 (if (pair? val)
74 (let ((valx (car val))
75 (valy (cdr val)))
76 (match-pattern valx x
77 (match-pattern valy y kt kf)
78 kf))
79 kf))
80 ((_ val lit kt kf)
81 (if (equal? val (quote lit)) kt kf))))
82
83 number?
84
85 ; A simple example:
86 '(let ()
87 (define (test-match x)
88 (match-case-simple x
89 (,x (number? x) "number")
90 (() () "nil")
91 (#t () "bool")
92 (#f () "bool")
93 ((,x . ,y) ()
94 (string-append "pair of " (test-match x) " and " (test-match y)))
95 (__ () "something else")))
96 (for-each (lambda (x) (display (test-match x)) (newline))
97 '(1 #t "str" (1 2 3))))
98 ;; printed result:
99
100 ;; number
101 ;; bool
102 ;; something else
103 ;; pair of number and pair of number and pair of number and nil
104
105
106 ; more complex example: meta-circular interpreter
107
108 '(let ()
109 (define (int code env)
110 (match-case-simple code
111 (('quote ,x) () x)
112 ((let ((,x ,e)) ,body) (symbol? x)
113 (let ((xv (int e env)))
114 (int body (cons (cons x xv) env))))
115 ((lambda () ,body) () ; thunk
116 (lambda () (int body env))) ; closed over the env
117 ((lambda ,argl ,body) (symbol? argl) ; arglist
118 (lambda arglv
119 (int body (cons (cons argl arglv) env))))
120 ((lambda (,x) ,body) (symbol? x) ; 1-arg function
121 (lambda (xv)
122 (int body (cons (cons x xv) env))))
123 ; the general case of lambda is skipped to keep the example small
124 ((,op . ,args) ()
125 (let* ((opv (int op env))
126 (argvs (map (lambda (c) (int c env)) args)))
127 (apply opv argvs)))
128 (,x (symbol? x) (lookup x env))
129 (,x () x) ; probably number, string, etc.
130 ))
131
132 ; Lookup a symbol in the environment
133 (define (lookup x env)
134 (cond
135 ((assq x env) => cdr)
136 (else (error "Can't find " x))))
137
138 ; Initial environment
139 (define env0
140 (map (lambda (x) (cons x (eval x (interaction-environment))))
141 '(+ - display))) ; add more
142
143 ; tests
144
145 (int 1 env0) ; 1
146 (int '1 env0) ; '1 is the same as 1
147
148 (int '(quote x) env0) ; x
149
150 (int '(display 'x) env0) ; x
151
152 (int '(display x) env0) ; error: unbound x
153
154 (int '(let ((x (+ 1 2 3))) (display x)) env0) ; 6
155 ((int '(lambda () 1) env0)) ; 1
156 ((int '(lambda (x) x) env0) 1) ; 1
157 (((int '(lambda (x) (lambda (y) (+ x y))) env0) 2) 3) ; 5 (test closure)
158
159 ((int '(lambda l (display l)) env0) 1 2 3) ; (1 2 3)
160 )
161