Initial import of Treacle version 1.0 revision 2010.0427 sources.
catseye
10 years ago
0 | <?xml version="1.0"?> | |
1 | <!-- encoding: UTF-8 --> | |
2 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> | |
3 | <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> | |
4 | <head> | |
5 | <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" /> | |
6 | <title>The Treacle Programming Language</title> | |
7 | <!-- begin html doc dynamic markup --> | |
8 | <script type="text/javascript" src="/contrib/jquery-1.6.4.min.js"></script> | |
9 | <script type="text/javascript" src="/scripts/documentation.js"></script> | |
10 | <!-- end html doc dynamic markup --> | |
11 | </head> | |
12 | <body> | |
13 | ||
14 | <h1>The Treacle Programming Language</h1> | |
15 | ||
16 | <p>Language version 1.0.<br/> | |
17 | Chris Pressey, Cat's Eye Technologies</p> | |
18 | ||
19 | <h2>Introduction</h2> | |
20 | ||
21 | <p><dfn>Treacle</dfn> is a programming language based on an extended form of term-rewriting | |
22 | which we shall call, somewhat innacurately (or at least arbitrarily,) <em>context rewriting</em>.</p> | |
23 | ||
24 | <p>Like Arboretuum, its successor built around <em>forest-rewriting</em>, Treacle was intended as | |
25 | a language for specifying compilers. Treacle is somewhat more successful at pulling it off, however; | |
26 | context rewriting encompasses, and is more expressive than, forest-rewriting.</p> | |
27 | ||
28 | <p><dfn>Context rewriting</dfn> is meant to refer to the fact that Treacle's rewriting patterns | |
29 | may contain <dfn>holes</dfn> – designated "containers" for subpatterns which may match not just | |
30 | the <em>immediate</em> child of the term which the parent pattern matched (as in conventional term-rewriting) | |
31 | but also <em>any one of that child's descendents</em>, no matter how deeply nested.</p> | |
32 | ||
33 | <p>When a hole is matched to some term, that term is searched for the | |
34 | subpattern given inside the hole. The search may be performed in either | |
35 | leftmost-innermost or leftmost-outermost order; this is specified | |
36 | by a qualifier associated with the hole. Because of this, Treacle need not | |
37 | specify a language-wide reduction order; the hole construct acts as a kind of | |
38 | search operator which explicitly encodes search order into each pattern.</p> | |
39 | ||
40 | <p>Context rewriting also deconstructs the conventional concept of the variable, | |
41 | splitting it into a <dfn>name</dfn> and a <dfn>wildcard</dfn>. Any pattern or | |
42 | subpattern may be named, not just wildcards. Even holes may be named. At the same time, | |
43 | wildcards, which match arbitrary terms, may occur unnamed. Upon a successful match, | |
44 | only those terms which matched named patterns are recorded in the unifier.</p> | |
45 | ||
46 | <p>Further, each rule in Treacle may contain multiple terms (<dfn>replacements</dfn>) on the right-hand side | |
47 | of a rewriting rule, and each of these may have its own name. When the term undergoing rewriting | |
48 | (called the <dfn>subject</dfn>) is rewritten, each named replacement is substituted into the subject at the position | |
49 | matched by the part of the pattern that is labelled by that same name.</p> | |
50 | ||
51 | <p>Lastly, replacements may contain special atomic terms called <dfn>newrefs</dfn>. When a | |
52 | newref is written into the subject, it takes the form of a new, unique symbol, guaranteed (or at least | |
53 | reasonably assumed) to be different from all other symbols that are in, or could be in, the subject. | |
54 | When multiple newrefs (possibly in multiple replacements) in the same rule are written into the subject | |
55 | at the same time (i.e., on the same rewriting step,) | |
56 | they all take the same form (and so are equal to each other, and only to each other – nothing else.) In Treacle's | |
57 | capacity as a compiler-definition language, newrefs are useful for generating internal labels for, | |
58 | e.g., translating control structures to machine code jumps.</p> | |
59 | ||
60 | <p>It is important to remember that, while subpatterns may be nested in holes, and these | |
61 | may in turn contain more holes, there is no corresponding hierarchical nature to the <em>bindings</em> | |
62 | which occur in Treacle patterns: all variables of the same name must unify to equivalent terms, regardless of where they | |
63 | occur in the pattern (inside or outside a hole.)</p> | |
64 | ||
65 | <h2>Syntax</h2> | |
66 | ||
67 | <p>We're almost ready to give some examples to elucidate all this, but first we need a | |
68 | syntax to give them in. Here it is:</p> | |
69 | ||
70 | <ul> | |
71 | <li>atoms are denoted by strings of lower-case letters;</li> | |
72 | <li>terms are denoted by lists of subterms inside parentheses;</li> | |
73 | <li>named terms are denoted by <code>(? <var>name</var> <var>subterm</var>)</code>;</li> | |
74 | <li>holes are denoted by <code>(:i <var>subterm</var>)</code> or <code>(:o <var>subterm</var>)</code>, | |
75 | corresponding to innermost and outermost search order, respectively;</li> | |
76 | <li>wildcards are denoted by <code>*</code>;</li> | |
77 | <li>newrefs are denoted by <code>@</code>; and</li> | |
78 | <li>named replacements are denoted <code>X : <var>term</var></code>.</li> | |
79 | </ul> | |
80 | ||
81 | <h2>Examples</h2> | |
82 | ||
83 | <p>Now we are ready to give some examples.</p> | |
84 | ||
85 | <h3>Patterns</h3> | |
86 | ||
87 | <ul> | |
88 | <li>The pattern <code>(a b (? X *))</code> matches <code>(a b (c (d b)))</code>, with the unifier | |
89 | <code>X=(c (d b))</code>. Also, <code>(a (? Y *) (c (d (? Y *))))</code> matches the same subject | |
90 | with <code>Y=b</code>. This is all quite conventional.</li> | |
91 | ||
92 | <li>We can also match <code>(a (? X b) *)</code> to this subject. The unifier will <em>always</em> be | |
93 | <code>X=b</code> when this pattern matches, regardless of the subject. This tells us nothing we | |
94 | did not already know. But it demonstrates the decoupling of names and wildcards in Treacle. (It will also become useful when we get to replacements, since that atomic <code>b</code> term named by <code>X</code> | |
95 | can be supplanted by something: we have named not just a subterm, but a location in the subject.)</li> | |
96 | ||
97 | <li>The pattern <code>(a b (:i (d b)))</code> matches the subject as well. | |
98 | Observe how the hole allowed <code>(d b)</code> to be sought | |
99 | inside the subterm at the location where the hole matched. | |
100 | Note also that the pattern would just as easily match the subject | |
101 | <code>(a b (w x (w y (w z (d b)))))</code>, because it doesn't matter how | |
102 | deep <code>(d b)</code> is embedded in the subterm.</li> | |
103 | ||
104 | <li>If the pattern included a name, like <code>(a b (? X (:i (d b))))</code>, | |
105 | the match with the subject would result in the unifier <code>X=(c (d b))</code>. | |
106 | Likewise, the pattern <code>(a b (:i (? X (d b))))</code> would match the subject | |
107 | with the unifier <code>X=(d b)</code>.</li> | |
108 | ||
109 | <li>The pattern <code>(a (? X *) (:i (d (? X *))))</code> also matches the | |
110 | subject, with the unifier <code>X=b</code>. This is a good example of the | |
111 | expressive power of pattern-matching in Treacle: we are basically asking | |
112 | to search the contents of the 3rd subterm, for whatever the 2nd subterm is.</li> | |
113 | ||
114 | </ul> | |
115 | ||
116 | <h3>Rules</h3> | |
117 | ||
118 | <ul> | |
119 | ||
120 | <li>Say we have a rule where the pattern is <code>(a b (:i (? X (d b))))</code>, | |
121 | and the lone replacement is <code>X : a</code>. This rule would match the | |
122 | original subject <code>(a b (c (d b)))</code>, unifying with <code>X=(d b)</code>, | |
123 | and would rewrite the subject to <code>(a b (c a))</code>.</li> | |
124 | ||
125 | <li>Or, say our rule's pattern is <code>(a (? Y *) (:i (? X (d *))))</code>, | |
126 | and the set of replacements is {<code>X : (? Y)</code>, <code>Y : (? X)</code>}. | |
127 | This rule would also match the subject, with a unifier of {<code>X=(d b)</code>, | |
128 | <code>Y=b</code>}, and would rewrite the subject to <code>(a (d b) (c b))</code>. | |
129 | Again, notice the expressivity of this rule: we're basically asking Treacle to swap whatever | |
130 | occurs next to the <code>a</code>, with whatever occurs alongside a <code>d</code> | |
131 | somewhere inside the term that occurs next to that.</li> | |
132 | ||
133 | </ul> | |
134 | ||
135 | <h2>Mechanism</h2> | |
136 | ||
137 | <p>We can think of the mechanism by which context rewriting is undertaken, as follows.</p> | |
138 | ||
139 | <p>We pattern-match "as usual": recursively traverse the pattern and the subject. Where there are | |
140 | literals in the pattern, we make sure those same values appear in the subject, in the same place. | |
141 | Where there are named subpatterns in the pattern, we bind the name to the position in the subject, and | |
142 | insert that binding into a unifier, before trying to match the subpattern to that position. | |
143 | (We do an occurs check first, to make sure that the name isn't already bound to something else.)</p> | |
144 | ||
145 | <p>Note that we bind the name, not to a subterm in the subject, but to a <em>position</em> in the subject. | |
146 | If you like, you can think of context rewriting building a "unifier by reference" rather than the rather | |
147 | more conventional "unifier by value". This is useful, because the presence of holes means that we will | |
148 | have more of a need to know where we want to install a replacement.</p> | |
149 | ||
150 | <p>When we encounter a hole in the pattern, we take the subpattern that appears in the hole | |
151 | and begin searching for that subpattern in the subterm of the subject whose position corresponds | |
152 | to the hole. We pass this subsearch our unifier (so that it can use the variable bindings already | |
153 | established for occurs checks.) If the subsearch fails to match, then we also fail to match. | |
154 | If the subsearch succeeds, we continue the pattern-matching process with the unifier it produced.</p> | |
155 | ||
156 | <p>If everything succeeds, we have a unifier. We go through the replacements, look up the name | |
157 | of each replacement in the unifier to find the location in the subject where it matched, expand all the | |
158 | variable names in the replacement with the contents of the unifier, and "poke" the expanded replacement | |
159 | into the subject at the location.</p> | |
160 | ||
161 | <h2>Implementation</h2> | |
162 | ||
163 | <p>Like Arboretuum, there is a reference implementation of Treacle in relatively pure Scheme, meant to | |
164 | normatively fill in any gaps in the description of the language given in this document.</p> | |
165 | ||
166 | <h2>Discussion</h2> | |
167 | ||
168 | <p>You may wonder, why forest-rewriting, or context rewriting? To be sure, it does not add any | |
169 | computational power to term-rewriting, which is already Turing-complete. But it does add a significant | |
170 | amount of expressiveness. While this expressiveness seems to come at a signficant cost (at least, | |
171 | as imagined in a naïve implementation,) there are two advantages it might provide, one practical | |
172 | and one theoretical, which I'll get to in a second.</p> | |
173 | ||
174 | <p>The idea latent in forest-rewriting, which I didn't explain too well in the Arboretuum documentation, | |
175 | is to <em>partition the subject</em>. Context rewriting continues and generalizes this idea; | |
176 | while in forest-rewriting it is obvious what the partitions are (named trees in a forest,) in | |
177 | context-rewriting, the partitions would be subterms of some given term (for example, the top-level | |
178 | term.) An engine implementing context-rewriting might need some supplementary information | |
179 | or deductive ability in order to "see" and exploit the partitions, but they could nonetheless be | |
180 | identified.</p> | |
181 | ||
182 | <p>One major effect of partitioning is to ease the locality constraint. If you've ever tried programming | |
183 | in pure term-rewriting, you notice that you have to "keep all your state together": if there are | |
184 | multiple pieces of information in the tree of terms that relate to the reduction you want to accomplish, | |
185 | they have to be in a bounded distance from, and in a fixed relationship with, each other. | |
186 | If some piece is far away, it will have to be brought – <em>literally</em> brought! – | |
187 | to bear on the situation, by moving it through the tree through successive "bubbling" rewrites.</p> | |
188 | ||
189 | <p>Forest-rewriting eases this by having multiple independent trees: some piece of information | |
190 | can be anywhere in some other tree. Context rewriting eases it by having holes in which the | |
191 | piece of information can be found anywhere.</p> | |
192 | ||
193 | <p>Partitioning the subject could have the practical benefit of improving locality of reference | |
194 | in the rewriting engine. Each partition can reside in its own memory buffer which is fixed in | |
195 | some way, for example in one or more cache lines. Since we don't need to "bubble" information | |
196 | through the term, each partition can stay in its own cached area, and we should see fewer | |
197 | cache misses.</p> | |
198 | ||
199 | <p>Partitioning the subject could also have the theoretical benefit of making it easier | |
200 | to prove that the rewriting terminates, If you look through some of the unit tests | |
201 | in <code>tests.scm</code>, you might notice that some of them go to some lengths to avoid | |
202 | rewriting certain trees to anything larger than they were. | |
203 | The size of each partition is then monotonically decreasing, and so it will eventually "run out", | |
204 | at which point the rewriting process must of course terminate. We might not be able to | |
205 | achieve the ideal case where, on each rewrite, at least one of the partitions shrinks and the | |
206 | rest stay the same size. The closer we can come to it, however, the less burdensome should be | |
207 | the task of proving that the entire system terminates, because many of the cases should | |
208 | be trivial.</p> | |
209 | ||
210 | <p>Happy whacky rewriting all sorts of fun ways! | |
211 | <br/>Chris Pressey | |
212 | <br/>Chicago, Illinois | |
213 | <br/>April 12, 2008</p> | |
214 | ||
215 | </body> | |
216 | </html> |
0 | ; | |
1 | ; Support for term indices (pointers to subterms of terms) | |
2 | ; Chris Pressey, March 2008 | |
3 | ; | |
4 | ||
5 | ; Copyright (c)2008 Cat's Eye Technologies. All rights reserved. | |
6 | ; | |
7 | ; Redistribution and use in source and binary forms, with or without | |
8 | ; modification, are permitted provided that the following conditions | |
9 | ; are met: | |
10 | ; | |
11 | ; 1. Redistributions of source code must retain the above copyright | |
12 | ; notices, this list of conditions and the following disclaimer. | |
13 | ; 2. Redistributions in binary form must reproduce the above copyright | |
14 | ; notices, this list of conditions, and the following disclaimer in | |
15 | ; the documentation and/or other materials provided with the | |
16 | ; distribution. | |
17 | ; 3. Neither the names of the copyright holders nor the names of their | |
18 | ; contributors may be used to endorse or promote products derived | |
19 | ; from this software without specific prior written permission. | |
20 | ; | |
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
22 | ; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
26 | ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
27 | ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
28 | ; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
29 | ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
30 | ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
31 | ; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
32 | ; POSSIBILITY OF SUCH DAMAGE. | |
33 | ||
34 | ; | |
35 | ; A term index is represented by a list of integers. It uniquely | |
36 | ; identifies a subterm position of a term. | |
37 | ; | |
38 | ||
39 | ; | |
40 | ; Create a basic term index that refers to the entire term. | |
41 | ; | |
42 | (define mk-base-index | |
43 | (lambda () | |
44 | '())) | |
45 | ||
46 | ; | |
47 | ; Return a term index which points to the leftmost subterm of the | |
48 | ; term pointed to by the given term index. | |
49 | ; | |
50 | (define descend-index | |
51 | (lambda (index) | |
52 | (cons 0 index))) | |
53 | ||
54 | ; | |
55 | ; Return a term index which points to the closest sibling term to | |
56 | ; the right of term pointed to by the given term index. | |
57 | ; | |
58 | (define next-index | |
59 | (lambda (index) | |
60 | (cons (+ (car index) 1) (cdr index)))) | |
61 | ||
62 | ; | |
63 | ; Retrieve the subterm of the given term at the given term index. | |
64 | ; | |
65 | (define term-index-fetch | |
66 | (lambda (term index) | |
67 | (cond ((null? index) | |
68 | term) | |
69 | (else | |
70 | (term-index-fetch (list-ref term (car index)) (cdr index)))))) | |
71 | ||
72 | ; | |
73 | ; Return a new term where the subterm at the given term index is replaced | |
74 | ; by the given replacement subterm. | |
75 | ; | |
76 | (define term-index-store | |
77 | (lambda (term index replacement) | |
78 | (cond ((null? index) | |
79 | replacement) | |
80 | (else | |
81 | (let* ((nth-subterm (list-ref term (car index))) | |
82 | (new-index (cdr index)) | |
83 | (new-subterm (term-index-store nth-subterm new-index replacement))) | |
84 | (list-replace term (car index) new-subterm)))))) | |
85 | ||
86 | ; | |
87 | ; Helper function for term-index-store. | |
88 | ; | |
89 | (define list-replace | |
90 | (lambda (elems pos elem) | |
91 | (cond ((eq? pos 0) | |
92 | (cons elem (cdr elems))) | |
93 | (else | |
94 | (cons (car elems) (list-replace (cdr elems) (- pos 1) elem)))))) |
0 | ; | |
1 | ; Support for matching context-rewriting patterns (names, wildcards, holes) | |
2 | ; Chris Pressey, March 2008 | |
3 | ; | |
4 | ||
5 | ; Copyright (c)2008 Cat's Eye Technologies. All rights reserved. | |
6 | ; | |
7 | ; Redistribution and use in source and binary forms, with or without | |
8 | ; modification, are permitted provided that the following conditions | |
9 | ; are met: | |
10 | ; | |
11 | ; 1. Redistributions of source code must retain the above copyright | |
12 | ; notices, this list of conditions and the following disclaimer. | |
13 | ; 2. Redistributions in binary form must reproduce the above copyright | |
14 | ; notices, this list of conditions, and the following disclaimer in | |
15 | ; the documentation and/or other materials provided with the | |
16 | ; distribution. | |
17 | ; 3. Neither the names of the copyright holders nor the names of their | |
18 | ; contributors may be used to endorse or promote products derived | |
19 | ; from this software without specific prior written permission. | |
20 | ; | |
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
22 | ; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
26 | ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
27 | ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
28 | ; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
29 | ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
30 | ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
31 | ; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
32 | ; POSSIBILITY OF SUCH DAMAGE. | |
33 | ||
34 | ; | |
35 | ; Shorthand for common usage of match. | |
36 | ; | |
37 | (define toplevel-match | |
38 | (lambda (subject pattern) | |
39 | (match subject subject pattern (mk-empty-unifier) (mk-base-index)))) | |
40 | ||
41 | ; | |
42 | ; Attempt to find a unifier (list of substitutions) which makes | |
43 | ; the given pattern equal to the given term, and return it. | |
44 | ; Return #f if the pattern does not match. | |
45 | ; | |
46 | ; Note that match, upon matching a hole, calls search-match. | |
47 | ; This is mutually recursive, since search-match also calls match. | |
48 | ; | |
49 | (define match | |
50 | (lambda (subject term pattern unifier index) | |
51 | (cond ((is-wildcard? pattern) | |
52 | unifier) | |
53 | ((is-named? pattern) | |
54 | (let* ((name (get-name pattern)) | |
55 | (subpat (get-named-subpat pattern)) | |
56 | (submatch (match subject term subpat unifier index))) | |
57 | (cond (submatch | |
58 | ; note that we pass the whole subject here | |
59 | (bind-name subject (reverse index) name submatch)) | |
60 | (else | |
61 | #f)))) | |
62 | ((is-hole? pattern) | |
63 | (let* ((order (get-hole-order pattern)) | |
64 | (subpat (get-hole-subpat pattern))) | |
65 | (cond ((eq? order 'innermost) | |
66 | (search-match-innermost subject term subpat unifier index)) | |
67 | ((eq? order 'outermost) | |
68 | (search-match-outermost subject term subpat unifier index)) | |
69 | (else | |
70 | #f)))) | |
71 | ((and (list? term) (list? pattern)) | |
72 | (match-lists subject term pattern unifier (descend-index index))) | |
73 | ((eqv? term pattern) | |
74 | unifier) | |
75 | (else | |
76 | #f)))) | |
77 | ||
78 | ; | |
79 | ; Helper function for match. | |
80 | ; Given a term and a pattern, where we know both are lists, | |
81 | ; fold over both of them, matching all the corresponding elements. | |
82 | ; | |
83 | (define match-lists | |
84 | (lambda (subject term pattern unifier index) | |
85 | (cond ((and (null? term) (null? pattern)) ; end of both | |
86 | unifier) | |
87 | ((or (null? term) (null? pattern)) ; end of one but not the other | |
88 | #f) | |
89 | (else | |
90 | (let ((new-unifier (match subject (car term) (car pattern) unifier index)) | |
91 | (new-index (next-index index))) | |
92 | (if new-unifier | |
93 | (match-lists subject (cdr term) (cdr pattern) new-unifier new-index) | |
94 | #f)))))) | |
95 | ||
96 | ; | |
97 | ; Match the given pattern to any subterm of the given term, if possible. | |
98 | ; Give priority to the leftmost outermost subterm that matches. | |
99 | ; Returns a new unifier, or #f. | |
100 | ; | |
101 | ; While searching, this tracks a term index which points to the subterm | |
102 | ; that matches. We pass this back in the returned unifier. | |
103 | ; | |
104 | (define search-match-outermost | |
105 | (lambda (subject term pattern unifier index) | |
106 | (let* ((new-unifier (match subject term pattern unifier index))) | |
107 | (cond (new-unifier | |
108 | new-unifier) | |
109 | ((list? term) | |
110 | (search-match-list-outermost subject term pattern unifier (descend-index index))) | |
111 | (else | |
112 | #f))))) | |
113 | ||
114 | ; | |
115 | ; Helper function. Try to match the given pattern to each term in the | |
116 | ; given list, left to right. Return new unifier on first successful | |
117 | ; match, or #f is there is none. | |
118 | ; | |
119 | (define search-match-list-outermost | |
120 | (lambda (subject terms pattern unifier index) | |
121 | (cond ((null? terms) | |
122 | #f) | |
123 | (else | |
124 | (let* ((new-unifier (search-match-outermost subject (car terms) pattern unifier index)) | |
125 | (new-index (next-index index))) | |
126 | (if new-unifier | |
127 | new-unifier | |
128 | (search-match-list-outermost subject (cdr terms) pattern unifier new-index))))))) | |
129 | ||
130 | ; | |
131 | ; Match the given pattern to any subterm of the given term, if possible. | |
132 | ; Give priority to the leftmost innermost subterm that matches. | |
133 | ; Returns a new unifier, or #f. | |
134 | ; | |
135 | ; While searching, this tracks a term index which points to the subterm | |
136 | ; that matches. We return this in the returned unifier. | |
137 | ; | |
138 | (define search-match-innermost | |
139 | (lambda (subject term pattern unifier index) | |
140 | (cond ((list? term) | |
141 | (let* ((new-unifier (search-match-list-innermost subject term pattern unifier (descend-index index)))) | |
142 | (if new-unifier | |
143 | new-unifier | |
144 | (match subject term pattern unifier index)))) | |
145 | (else | |
146 | (match subject term pattern unifier index))))) | |
147 | ||
148 | ; | |
149 | ; Helper function. Try to match the given pattern to each term in the | |
150 | ; given list, left to right. Return new unifier on first successful | |
151 | ; match, or #f is there is none. | |
152 | ; | |
153 | (define search-match-list-innermost | |
154 | (lambda (subject terms pattern unifier index) | |
155 | (cond ((null? terms) | |
156 | #f) | |
157 | (else | |
158 | (let* ((new-unifier (search-match-innermost subject (car terms) pattern unifier index)) | |
159 | (new-index (next-index index))) | |
160 | (if new-unifier | |
161 | new-unifier | |
162 | (search-match-list-innermost subject (cdr terms) pattern unifier new-index))))))) |
0 | ; | |
1 | ; Basic data structures for context-rewriting patterns (names, holes, wildcards) | |
2 | ; Chris Pressey, March 2008 | |
3 | ; | |
4 | ||
5 | ; Copyright (c)2008 Cat's Eye Technologies. All rights reserved. | |
6 | ; | |
7 | ; Redistribution and use in source and binary forms, with or without | |
8 | ; modification, are permitted provided that the following conditions | |
9 | ; are met: | |
10 | ; | |
11 | ; 1. Redistributions of source code must retain the above copyright | |
12 | ; notices, this list of conditions and the following disclaimer. | |
13 | ; 2. Redistributions in binary form must reproduce the above copyright | |
14 | ; notices, this list of conditions, and the following disclaimer in | |
15 | ; the documentation and/or other materials provided with the | |
16 | ; distribution. | |
17 | ; 3. Neither the names of the copyright holders nor the names of their | |
18 | ; contributors may be used to endorse or promote products derived | |
19 | ; from this software without specific prior written permission. | |
20 | ; | |
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
22 | ; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
26 | ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
27 | ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
28 | ; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
29 | ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
30 | ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
31 | ; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
32 | ; POSSIBILITY OF SUCH DAMAGE. | |
33 | ||
34 | ; | |
35 | ; Patterns are structured as follows. | |
36 | ; | |
37 | ; Atoms, numbers, and lists are literals, to be matched. | |
38 | ; | |
39 | ; A vector of length 1 where the first and only element is the | |
40 | ; atom 'wildcard' is a wildcard. | |
41 | ; | |
42 | ; A vector of length 3 where the first element is the atom 'named' | |
43 | ; is a named term. The second element is an atom giving the name | |
44 | ; of the term, and the third element gives the subpattern so named. | |
45 | ; | |
46 | ; A vector of length 3 where the first element is the atom 'hole' | |
47 | ; is a hole. The second element indicates the match search order | |
48 | ; to apply inside this hole, either 'innermost' or 'outermost'. The | |
49 | ; third element is the subpattern to be matched inside this hole. | |
50 | ; | |
51 | ||
52 | (define mk-wildcard | |
53 | (lambda () | |
54 | (vector 'wildcard))) | |
55 | ||
56 | (define mk-named | |
57 | (lambda (name subpat) | |
58 | (vector 'named name subpat))) | |
59 | ||
60 | (define mk-hole | |
61 | (lambda (order subpat) | |
62 | (vector 'hole order subpat))) | |
63 | ||
64 | (define mk-newref | |
65 | (lambda () | |
66 | (vector 'newref))) | |
67 | ||
68 | ; | |
69 | ; Helper predicate for following predicates. | |
70 | ; | |
71 | (define is-type? | |
72 | (lambda (label pattern) | |
73 | (and (vector? pattern) | |
74 | (eq? (vector-ref pattern 0) label)))) | |
75 | ||
76 | ; | |
77 | ; Return #t if the given pattern is a named pattern, #f otherwise. | |
78 | ; | |
79 | (define is-named? | |
80 | (lambda (pattern) | |
81 | (is-type? 'named pattern))) | |
82 | ||
83 | ; | |
84 | ; Return the name of the given pattern variable. | |
85 | ; Assumes that its input is in fact a pattern variable. | |
86 | ; | |
87 | (define get-name | |
88 | (lambda (named-pattern) | |
89 | (vector-ref named-pattern 1))) ; just return the 2nd element of the vector | |
90 | ||
91 | ; | |
92 | ; Return the name of the given pattern variable. | |
93 | ; Assumes that its input is in fact a pattern variable. | |
94 | ; | |
95 | (define get-named-subpat | |
96 | (lambda (named-pattern) | |
97 | (vector-ref named-pattern 2))) ; just return the 3nd element of the vector | |
98 | ||
99 | ; | |
100 | ; Return #t if the given pattern is a hole, #f otherwise. | |
101 | ; | |
102 | (define is-hole? | |
103 | (lambda (pattern) | |
104 | (is-type? 'hole pattern))) | |
105 | ||
106 | ; | |
107 | ; Return the search order of the given hole. | |
108 | ; Assumes that its input is in fact a hole. | |
109 | ; | |
110 | (define get-hole-order | |
111 | (lambda (hole) | |
112 | (vector-ref hole 1))) ; just return the 2nd element of the vector | |
113 | ||
114 | ; | |
115 | ; Return the subpattern to search for in the given hole. | |
116 | ; Assumes that its input is in fact a hole. | |
117 | ; | |
118 | (define get-hole-subpat | |
119 | (lambda (hole) | |
120 | (vector-ref hole 2))) ; just return the 3rd element of the vector | |
121 | ||
122 | ; | |
123 | ; Return #t if the given pattern is a wildcard, #f otherwise. | |
124 | ; | |
125 | (define is-wildcard? | |
126 | (lambda (pattern) | |
127 | (is-type? 'wildcard pattern))) | |
128 | ||
129 | ; | |
130 | ; Return #t if the given pattern is a newref, #f otherwise. | |
131 | ; | |
132 | (define is-newref? | |
133 | (lambda (pattern) | |
134 | (is-type? 'newref pattern))) | |
135 | ||
136 | ; | |
137 | ; Ground terms are a subset of patterns which may not contain | |
138 | ; wildcards, holes, or named terms. | |
139 | ; | |
140 | (define is-ground? | |
141 | (lambda (term) | |
142 | (cond | |
143 | ((is-wildcard? term) | |
144 | #f) | |
145 | ((is-hole? term) | |
146 | #f) | |
147 | ((is-named? term) | |
148 | #f) | |
149 | ((is-newref? term) | |
150 | #f) | |
151 | ((null? term) | |
152 | #t) | |
153 | ((list? term) | |
154 | (and (is-ground? (car term)) | |
155 | (is-ground? (cdr term)))) | |
156 | ((number? term) | |
157 | #t) | |
158 | ((symbol? term) | |
159 | #t) | |
160 | (else | |
161 | #f)))) | |
162 | ||
163 | ; | |
164 | ; Replacements are a subset of patterns which may contain named | |
165 | ; terms, but may not contain wildcards or holes. | |
166 | ; | |
167 | ; In addition, replacements may contain newrefs, which are replaced | |
168 | ; with unique symbols upon expansion. | |
169 | ; | |
170 | (define is-replacement? | |
171 | (lambda (term) | |
172 | (cond | |
173 | ((is-wildcard? term) | |
174 | #f) | |
175 | ((is-hole? term) | |
176 | #f) | |
177 | ((is-named? term) | |
178 | (is-replacement? (get-named-subpat term))) | |
179 | ((is-newref? term) | |
180 | #t) | |
181 | ((null? term) | |
182 | #t) | |
183 | ((list? term) | |
184 | (and (is-replacement? (car term)) | |
185 | (is-replacement? (cdr term)))) | |
186 | ((number? term) | |
187 | #t) | |
188 | ((symbol? term) | |
189 | #t) | |
190 | (else | |
191 | #f)))) |
0 | ; | |
1 | ; Support for reducing terms via context-rewriting | |
2 | ; Chris Pressey, March 2008 | |
3 | ; | |
4 | ||
5 | ; Copyright (c)2008 Cat's Eye Technologies. All rights reserved. | |
6 | ; | |
7 | ; Redistribution and use in source and binary forms, with or without | |
8 | ; modification, are permitted provided that the following conditions | |
9 | ; are met: | |
10 | ; | |
11 | ; 1. Redistributions of source code must retain the above copyright | |
12 | ; notices, this list of conditions and the following disclaimer. | |
13 | ; 2. Redistributions in binary form must reproduce the above copyright | |
14 | ; notices, this list of conditions, and the following disclaimer in | |
15 | ; the documentation and/or other materials provided with the | |
16 | ; distribution. | |
17 | ; 3. Neither the names of the copyright holders nor the names of their | |
18 | ; contributors may be used to endorse or promote products derived | |
19 | ; from this software without specific prior written permission. | |
20 | ; | |
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
22 | ; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
26 | ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
27 | ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
28 | ; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
29 | ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
30 | ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
31 | ; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
32 | ; POSSIBILITY OF SUCH DAMAGE. | |
33 | ||
34 | ; | |
35 | ; Given a rule (a pair of a pattern and a map of replacements,) | |
36 | ; apply the rule to the given subject. If the pattern part of | |
37 | ; the rule matches the subject, replace the subterms that matched | |
38 | ; named subpatterns with the expanded replacement whose key in | |
39 | ; the map is that name. | |
40 | ; | |
41 | (define apply-rule | |
42 | (lambda (subject pattern replacements generation-id) | |
43 | (let* ((unifier (match subject subject pattern (mk-empty-unifier) (mk-base-index)))) | |
44 | (if unifier | |
45 | (apply-unifier subject subject unifier unifier replacements generation-id) | |
46 | #f)))) | |
47 | ||
48 | ; | |
49 | ; Helper function for apply-rule. For each substitution in the unifier whose | |
50 | ; name is present in some replacement, expand that replacement with values from | |
51 | ; the unifier, and graft it into the subject at the position given in the unifier. | |
52 | ; | |
53 | (define apply-unifier | |
54 | (lambda (complete-subject subject complete-unifier unifier replacements generation-id) | |
55 | (if (null? unifier) | |
56 | subject | |
57 | (let* ((unif-pair (car unifier)) | |
58 | (rest-of-unif (cdr unifier)) | |
59 | (name (car unif-pair)) | |
60 | (index (cdr unif-pair)) | |
61 | (repl-pair (assq name replacements))) | |
62 | (if repl-pair | |
63 | (let* ((replacement (cdr repl-pair)) | |
64 | (expanded-repl (expand-vars complete-subject replacement complete-unifier generation-id)) | |
65 | (new-subject (term-index-store subject index expanded-repl))) | |
66 | (apply-unifier complete-subject new-subject complete-unifier rest-of-unif replacements generation-id)) | |
67 | (apply-unifier complete-subject subject complete-unifier rest-of-unif replacements generation-id)))))) | |
68 | ||
69 | ; | |
70 | ; Given a set of rules, apply repeatedly to subject until none apply. | |
71 | ; | |
72 | (define reduce | |
73 | (lambda (subject complete-rules rules generation-id) | |
74 | (if (null? rules) | |
75 | subject | |
76 | (let* ((rule-pair (car rules)) | |
77 | (rest-of-rules (cdr rules)) | |
78 | (pattern (car rule-pair)) | |
79 | (replacements (cdr rule-pair)) | |
80 | (new-gen-id (+ generation-id 1)) | |
81 | (new-subject (apply-rule subject pattern replacements generation-id))) | |
82 | (if new-subject | |
83 | (reduce new-subject complete-rules complete-rules new-gen-id) | |
84 | (reduce subject complete-rules rest-of-rules new-gen-id)))))) | |
85 | ||
86 | ; | |
87 | ; Useful shortcut for calling reduce. | |
88 | ; | |
89 | (define toplevel-reduce | |
90 | (lambda (subject complete-rules) | |
91 | (reduce subject complete-rules complete-rules 0))) |
0 | ; | |
1 | ; Provisional Syntax for Treacle Forms | |
2 | ; Chris Pressey, April 2008 | |
3 | ; | |
4 | ||
5 | ; Copyright (c)2008 Cat's Eye Technologies. All rights reserved. | |
6 | ; | |
7 | ; Redistribution and use in source and binary forms, with or without | |
8 | ; modification, are permitted provided that the following conditions | |
9 | ; are met: | |
10 | ; | |
11 | ; 1. Redistributions of source code must retain the above copyright | |
12 | ; notices, this list of conditions and the following disclaimer. | |
13 | ; 2. Redistributions in binary form must reproduce the above copyright | |
14 | ; notices, this list of conditions, and the following disclaimer in | |
15 | ; the documentation and/or other materials provided with the | |
16 | ; distribution. | |
17 | ; 3. Neither the names of the copyright holders nor the names of their | |
18 | ; contributors may be used to endorse or promote products derived | |
19 | ; from this software without specific prior written permission. | |
20 | ; | |
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
22 | ; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
26 | ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
27 | ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
28 | ; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
29 | ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
30 | ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
31 | ; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
32 | ; POSSIBILITY OF SUCH DAMAGE. | |
33 | ||
34 | (load "pattern.scm") | |
35 | ||
36 | ; | |
37 | ; Syntax for atomic terms, including patterns and replacements. | |
38 | ; | |
39 | (define-syntax term-atom | |
40 | (syntax-rules (* ? :i :o @) | |
41 | ((term-atom *) | |
42 | (mk-wildcard)) | |
43 | ((term-atom @) | |
44 | (mk-newref)) | |
45 | ((term-atom (? name subterm)) | |
46 | (mk-named 'name (term-atom subterm))) | |
47 | ((term-atom (:i subterm)) | |
48 | (mk-hole 'innermost (term-atom subterm))) | |
49 | ((term-atom (:o subterm)) | |
50 | (mk-hole 'outermost (term-atom subterm))) | |
51 | ((term-atom (inner ...)) | |
52 | (term-list inner ...)) | |
53 | ((term-atom other) | |
54 | 'other))) | |
55 | ||
56 | ; | |
57 | ; Syntax for list terms. | |
58 | ; | |
59 | (define-syntax term-list | |
60 | (syntax-rules () | |
61 | ((term-list) | |
62 | '()) | |
63 | ((term-list atom rest ...) | |
64 | (cons (term-atom atom) (term-list rest ...))))) | |
65 | ||
66 | ; | |
67 | ; Syntax for replacements. | |
68 | ; | |
69 | (define-syntax replacements | |
70 | (syntax-rules (:) | |
71 | ((replacements) | |
72 | '()) | |
73 | ((replacements name : replacement rest ...) | |
74 | (cons (cons 'name (term-atom replacement)) (replacements rest ...))) | |
75 | )) | |
76 | ||
77 | ; | |
78 | ; Syntax for rules. | |
79 | ; | |
80 | (define-syntax rules | |
81 | (syntax-rules (->) | |
82 | ((rules) | |
83 | '()) | |
84 | ((rules pattern -> (repls ...) rest ...) | |
85 | (cons (cons (term-atom pattern) (replacements repls ...)) (rules rest ...))) | |
86 | )) |
0 | ; | |
1 | ; Test suite for Treacle | |
2 | ; Chris Pressey, March 2008 | |
3 | ; | |
4 | ||
5 | ; Copyright (c)2008 Cat's Eye Technologies. All rights reserved. | |
6 | ; | |
7 | ; Redistribution and use in source and binary forms, with or without | |
8 | ; modification, are permitted provided that the following conditions | |
9 | ; are met: | |
10 | ; | |
11 | ; 1. Redistributions of source code must retain the above copyright | |
12 | ; notices, this list of conditions and the following disclaimer. | |
13 | ; 2. Redistributions in binary form must reproduce the above copyright | |
14 | ; notices, this list of conditions, and the following disclaimer in | |
15 | ; the documentation and/or other materials provided with the | |
16 | ; distribution. | |
17 | ; 3. Neither the names of the copyright holders nor the names of their | |
18 | ; contributors may be used to endorse or promote products derived | |
19 | ; from this software without specific prior written permission. | |
20 | ; | |
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
22 | ; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
26 | ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
27 | ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
28 | ; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
29 | ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
30 | ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
31 | ; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
32 | ; POSSIBILITY OF SUCH DAMAGE. | |
33 | ||
34 | (load "utils.scm") | |
35 | (load "pattern.scm");------------------------------------------------------ | |
36 | ||
37 | (test pattern-1 | |
38 | (mk-named 'jim (mk-wildcard)) | |
39 | #(named jim #(wildcard)) | |
40 | ) | |
41 | ||
42 | (test pattern-2 | |
43 | (is-ground? (mk-named 'jim (mk-wildcard))) | |
44 | #f | |
45 | ) | |
46 | ||
47 | (test pattern-3 | |
48 | (is-ground? '(cat dog (rabbit) (oyster pigeon))) | |
49 | #t | |
50 | ) | |
51 | ||
52 | (test pattern-4 | |
53 | (is-replacement? (mk-named 'jim (mk-wildcard))) | |
54 | #f | |
55 | ) | |
56 | ||
57 | (test pattern-5 | |
58 | (is-replacement? (mk-named 'jim 0)) | |
59 | #t | |
60 | ) | |
61 | ||
62 | (load "index.scm");-------------------------------------------------------- | |
63 | ||
64 | (test index-fetch-1 | |
65 | (term-index-fetch '(1 2 3) '()) | |
66 | '(1 2 3) | |
67 | ) | |
68 | ||
69 | (test index-fetch-2 | |
70 | (term-index-fetch '(1 2 3) '(0)) | |
71 | 1 | |
72 | ) | |
73 | ||
74 | (test index-fetch-3 | |
75 | (term-index-fetch '(1 2 (1 (1 2 99) (1 2 3))) '(2 1 2)) | |
76 | 99 | |
77 | ) | |
78 | ||
79 | (test index-store-1 | |
80 | (term-index-store '(1 2 3) '(0) 99) | |
81 | '(99 2 3) | |
82 | ) | |
83 | ||
84 | (load "unifier.scm");-------------------------------------------------------- | |
85 | ||
86 | (test bind-name-1 | |
87 | (bind-name | |
88 | '(a b c (d e f)) | |
89 | '(3) | |
90 | 'ralph | |
91 | '() | |
92 | ) | |
93 | '((ralph 3)) | |
94 | ) | |
95 | ||
96 | (test bind-name-2 | |
97 | (bind-name | |
98 | '(a b c (d e f)) | |
99 | '(3) | |
100 | 'ralph | |
101 | '((ralph 0)) | |
102 | ) | |
103 | #f | |
104 | ) | |
105 | ||
106 | (test bind-name-3 | |
107 | (bind-name | |
108 | '(a b c a) | |
109 | '(3) | |
110 | 'ralph | |
111 | '((ralph 0)) | |
112 | ) | |
113 | '((ralph 3) (ralph 0)) | |
114 | ) | |
115 | ||
116 | (test expand-vars-1 | |
117 | (expand-vars | |
118 | '(a b c (d e f)) | |
119 | '(i j #(named ralph k)) | |
120 | '((ralph 3)) | |
121 | 0 | |
122 | ) | |
123 | '(i j (d e f)) | |
124 | ) | |
125 | ||
126 | (test expand-vars-2 | |
127 | (expand-vars | |
128 | '(a b c (d e f)) | |
129 | '(#(named ralph 0) #(named ed 0)) | |
130 | '((ralph 3 1)) | |
131 | 0 | |
132 | ) | |
133 | '(e #(named ed 0)) | |
134 | ) | |
135 | ||
136 | (test expand-vars-3 | |
137 | (expand-vars | |
138 | '(a b c (d e f)) | |
139 | '(#(newref)) | |
140 | '((ralph 3 1)) | |
141 | 33 | |
142 | ) | |
143 | '(unique-ref-33) | |
144 | ) | |
145 | ||
146 | (load "match.scm");----------------------------------------------------------- | |
147 | ||
148 | (test match-1 | |
149 | (toplevel-match | |
150 | '(a (b c)) | |
151 | '(a (b c)) | |
152 | ) | |
153 | '() | |
154 | ) | |
155 | ||
156 | (test match-2 | |
157 | (toplevel-match | |
158 | '(a (b c)) | |
159 | '(b c) | |
160 | ) | |
161 | #f | |
162 | ) | |
163 | ||
164 | (test match-3 | |
165 | (toplevel-match | |
166 | '(a (b c)) | |
167 | '(a #(named ralph #(wildcard))) | |
168 | ) | |
169 | '((ralph 1)) | |
170 | ) | |
171 | ||
172 | (test match-4 | |
173 | (toplevel-match | |
174 | '(x right (y 1 2)) | |
175 | '#(named t (x #(named i #(wildcard)) #(named j #(wildcard)))) | |
176 | ) | |
177 | '((t) (j 2) (i 1)) | |
178 | ) | |
179 | ||
180 | (test match-hole-1 | |
181 | (toplevel-match | |
182 | '(a (b b b (c c c (d e)) b b b)) | |
183 | '(a #(hole innermost e)) | |
184 | ) | |
185 | '() | |
186 | ) | |
187 | ||
188 | (test match-hole-2 | |
189 | (toplevel-match | |
190 | '(a (b b b (c c c (d e)) b b b)) | |
191 | '(a #(hole innermost f)) | |
192 | ) | |
193 | #f | |
194 | ) | |
195 | ||
196 | (test match-hole-3 | |
197 | (toplevel-match | |
198 | '(a (b b (flag k) (c c c (d (flag a))) b b b)) | |
199 | '(a #(hole innermost (flag #(named jim #(wildcard))))) | |
200 | ) | |
201 | '((jim 1 2 1)) | |
202 | ) | |
203 | ||
204 | (test match-hole-4 | |
205 | (toplevel-match | |
206 | '(a (b b (flag k) (c c c (d (flag a))) b b b)) | |
207 | '(a #(hole innermost #(named jim (flag #(wildcard))))) | |
208 | ) | |
209 | '((jim 1 2)) | |
210 | ) | |
211 | ||
212 | (test match-hole-5 | |
213 | (toplevel-match | |
214 | '(a (b b (flag k) (c c c (d (flag a))) b b b)) | |
215 | '(a #(named jim #(hole innermost (flag #(wildcard))))) | |
216 | ) | |
217 | '((jim 1)) | |
218 | ) | |
219 | ||
220 | (test match-hole-6 | |
221 | (toplevel-match | |
222 | '(pair a (b b (flag k) (c c c (d (flag a))) b b b)) | |
223 | '(pair #(named jim #(wildcard)) #(hole innermost (flag #(named bones #(named jim #(wildcard)))))) | |
224 | ) | |
225 | '((bones 2 3 3 1 1) (jim 2 3 3 1 1) (jim 1)) | |
226 | ) | |
227 | ||
228 | (test match-order-1 | |
229 | (toplevel-match | |
230 | '(thing (flag (world (a b c) (a b (flag k)))) thang) | |
231 | #(hole innermost #(named jim (flag #(wildcard)))) | |
232 | ) | |
233 | '((jim 1 1 2 2)) | |
234 | ) | |
235 | ||
236 | (test match-order-2 | |
237 | (toplevel-match | |
238 | '(thing (flag (world (a b c) (a b (flag k)))) thang) | |
239 | #(hole outermost #(named jim (flag #(wildcard)))) | |
240 | ) | |
241 | '((jim 1)) | |
242 | ) | |
243 | ||
244 | (test match-order-3 | |
245 | (toplevel-match | |
246 | '(ast (+ _ (* (lit 2) (lit 3)))) | |
247 | '(ast #(hole innermost #(named src (lit #(wildcard))))) | |
248 | ) | |
249 | '((src 1 2 1)) | |
250 | ) | |
251 | ||
252 | (load "reduce.scm");---------------------------------------------------------- | |
253 | ||
254 | (test apply-rule-1 | |
255 | (apply-rule | |
256 | '(a b c) | |
257 | #(named jim (a b c)) | |
258 | '((jim . k) (bones 1 2 3)) | |
259 | 0 | |
260 | ) | |
261 | 'k | |
262 | ) | |
263 | ||
264 | (test apply-rule-2 | |
265 | (apply-rule | |
266 | '(x this (x descends (x to (x the (x right (y 1 2)))))) | |
267 | '#(hole innermost #(named t (x #(named i #(wildcard)) #(named j #(wildcard))))) | |
268 | '((t . (xx #(named j 0) #(named i 0)))) | |
269 | 0 | |
270 | ) | |
271 | '(x this (x descends (x to (x the (xx (y 1 2) right))))) | |
272 | ) | |
273 | ||
274 | (test reduce-1 | |
275 | (toplevel-reduce | |
276 | '(a b c) | |
277 | '( | |
278 | ( #(named jim (a b c)) . ((jim . k) (bones 1 2 3)) ) | |
279 | ) | |
280 | ) | |
281 | 'k | |
282 | ) | |
283 | ||
284 | (test reduce-2 | |
285 | (toplevel-reduce | |
286 | '(x this (x descends (x to (x the (x right (y 1 2)))))) | |
287 | '( | |
288 | ( ; rule 1 | |
289 | #(hole innermost #(named t (x #(named i #(wildcard)) #(named j #(wildcard))))) . | |
290 | ((t . (xx #(named j 0) #(named i 0)))) | |
291 | ) | |
292 | ) | |
293 | ) | |
294 | '(xx (xx (xx (xx (xx (y 1 2) right) the) to) descends) this) | |
295 | ) | |
296 | ||
297 | (test reduce-3 | |
298 | (toplevel-reduce | |
299 | '(x this (x descends (x to (x the (x right (y 1 2)))))) | |
300 | '( | |
301 | ( ; rule 1 | |
302 | #(hole innermost #(named t (x #(named i #(wildcard)) #(named j #(wildcard))))) . | |
303 | ((t . (xx #(named j 0) #(named i 0)))) | |
304 | ) | |
305 | ( ; rule 2 | |
306 | #(hole innermost #(named p right)) . | |
307 | ((p . left)) | |
308 | ) | |
309 | ) | |
310 | ) | |
311 | '(xx (xx (xx (xx (xx (y 1 2) left) the) to) descends) this) | |
312 | ) | |
313 | ||
314 | (load "syntax.scm");----------------------------------------------------------- | |
315 | ||
316 | (test syntax-term-1 | |
317 | (term-atom (a b c)) | |
318 | '(a b c) | |
319 | ) | |
320 | ||
321 | (test syntax-term-2 | |
322 | (term-list a b c) | |
323 | '(a b c) | |
324 | ) | |
325 | ||
326 | (test syntax-term-3 | |
327 | (term-atom (a * c)) | |
328 | '(a #(wildcard) c) | |
329 | ) | |
330 | ||
331 | (test syntax-term-4 | |
332 | (term-atom *) | |
333 | #(wildcard) | |
334 | ) | |
335 | ||
336 | (test syntax-term-5 | |
337 | (term-atom (a (? bob *) (c d @) f g)) | |
338 | '(a #(named bob #(wildcard)) (c d #(newref)) f g) | |
339 | ) | |
340 | ||
341 | (test syntax-replacements-1 | |
342 | (replacements a : (a b @) b : (? eb *)) | |
343 | '( | |
344 | (a . (a b #(newref))) | |
345 | (b . #(named eb #(wildcard))) | |
346 | ) | |
347 | ) | |
348 | ||
349 | (test syntax-rules-1 | |
350 | (rules | |
351 | (:i (? t (x (? i *) (? j *)))) -> ( t : (xx (? j 0) (? i 0)) ) | |
352 | (:i (? p right)) -> ( p : left ) | |
353 | ) | |
354 | '( | |
355 | ( | |
356 | #(hole innermost #(named t (x #(named i #(wildcard)) #(named j #(wildcard))))) . | |
357 | ((t . (xx #(named j 0) #(named i 0)))) | |
358 | ) | |
359 | ( | |
360 | #(hole innermost #(named p right)) . | |
361 | ((p . left)) | |
362 | ) | |
363 | ) | |
364 | ) | |
365 | ||
366 | ;------------------------------------------------------------------- | |
367 | ; Forest-rewriting, a la Arboretuum. | |
368 | ;------------------------------------------------------------------- | |
369 | ||
370 | (test rewrite-forest-1 | |
371 | (toplevel-reduce | |
372 | '(forest (ast (+ (lit 3) (* (lit 2) (lit 3)))) | |
373 | (out halt)) | |
374 | '( | |
375 | ( ; rule 1 | |
376 | (forest (ast #(hole innermost #(named src (lit #(named val #(wildcard)))))) | |
377 | (out #(hole innermost #(named dest halt)))) . | |
378 | ((src . _) (dest . (push #(named val) halt))) | |
379 | ) | |
380 | ( ; rule 2 | |
381 | (forest (ast #(hole innermost #(named src (+ _ _)))) | |
382 | (out #(hole innermost #(named dest halt)))) . | |
383 | ((src . _) (dest . (add halt))) | |
384 | ) | |
385 | ( ; rule 3 | |
386 | (forest (ast #(hole innermost #(named src (* _ _)))) | |
387 | (out #(hole innermost #(named dest halt)))) . | |
388 | ((src . _) (dest . (mul halt))) | |
389 | ) | |
390 | ) | |
391 | ) | |
392 | '(forest (ast _) (out (push 3 (push 2 (push 3 (mul (add halt))))))) | |
393 | ) | |
394 | ||
395 | (test rewrite-forest-2 | |
396 | (toplevel-reduce | |
397 | '(forest (stab (a 4 eot)) | |
398 | (ast (+ 1 2 3 a 5 6 a 7 8 9))) | |
399 | '( | |
400 | ( ; rule 1 | |
401 | (forest (stab #(hole innermost (#(named n #(wildcard)) #(named v #(wildcard)) #(named tab #(wildcard))))) | |
402 | (ast #(hole innermost #(named dest #(named n #(wildcard)))))) . | |
403 | ((dest . #(named v))) | |
404 | ) | |
405 | ) | |
406 | ) | |
407 | '(forest (stab (a 4 eot)) (ast (+ 1 2 3 4 5 6 4 7 8 9))) | |
408 | ) | |
409 | ||
410 | (test rewrite-forest-3 | |
411 | (toplevel-reduce | |
412 | '(forest (ast (let a (lit 4) (+ (lit 3) (* (var a) (lit 3)))) ) | |
413 | (stab eot) | |
414 | (out halt)) | |
415 | '( | |
416 | ( ; rule 1 | |
417 | (forest (ast #(hole innermost #(named src | |
418 | (let #(named n #(wildcard)) #(named v #(wildcard)) #(named expr #(wildcard))) ))) | |
419 | (stab #(hole innermost #(named dest eot))) | |
420 | (out #(wildcard))) . | |
421 | ((src . #(named expr 0)) (dest . (#(named n 0) #(named v 0) eot))) | |
422 | ) | |
423 | ( ; rule 2 | |
424 | (forest (ast #(hole innermost #(named src (var #(named n #(wildcard)))))) | |
425 | (stab #(hole innermost (#(named n #(wildcard)) #(named v #(wildcard)) #(wildcard)))) | |
426 | (out #(wildcard))) . | |
427 | ((src . #(named v 0))) | |
428 | ) | |
429 | ( ; rule 3 | |
430 | (forest (ast #(hole innermost #(named src (lit #(named val #(wildcard)))))) | |
431 | (stab #(wildcard)) | |
432 | (out #(hole innermost #(named dest halt)))) . | |
433 | ((src . _) (dest . (push #(named val) halt))) | |
434 | ) | |
435 | ( ; rule 4 | |
436 | (forest (ast #(hole innermost #(named src (+ _ _)))) | |
437 | (stab #(wildcard)) | |
438 | (out #(hole innermost #(named dest halt)))) . | |
439 | ((src . _) (dest . (add halt))) | |
440 | ) | |
441 | ( ; rule 5 | |
442 | (forest (ast #(hole innermost #(named src (* _ _)))) | |
443 | (stab #(wildcard)) | |
444 | (out #(hole innermost #(named dest halt)))) . | |
445 | ((src . _) (dest . (mul halt))) | |
446 | ) | |
447 | ) | |
448 | ) | |
449 | '(forest (ast _) | |
450 | (stab (a (lit 4) eot)) | |
451 | (out (push 3 (push 4 (push 3 (mul (add halt))))))) | |
452 | ) | |
453 | ||
454 | ; | |
455 | ; This test is close to (although not exactly) what we'd like to see, for | |
456 | ; translating "if" statements to machine code. It uses newref to generate | |
457 | ; labels for the jumps. It rewrites the AST several times to ensure that | |
458 | ; the jumps and labels are generated in the right order. | |
459 | ; | |
460 | (test rewrite-forest-4 | |
461 | (toplevel-reduce | |
462 | '(forest (ast (if (> (lit 6) (lit 4)) (print (lit 1)) (print (lit 2))) ) | |
463 | (out halt)) | |
464 | '( | |
465 | ( ; rule -- get label for if | |
466 | (forest (ast #(hole innermost #(named src (if _ #(named then #(wildcard)) #(named else #(wildcard)) )))) | |
467 | (out #(wildcard))) . | |
468 | ((src . (iflab #(named then 0) #(named else 0) #(newref)))) | |
469 | ) | |
470 | ( ; rule -- reduce if to then | |
471 | (forest (ast #(hole innermost #(named src | |
472 | (iflab #(named then #(wildcard)) #(named else #(wildcard)) #(named elselab #(wildcard))) | |
473 | ))) | |
474 | (out #(hole innermost #(named dest halt)))) . | |
475 | ((src . (then #(named then 0) #(named else 0) #(named elselab 0))) | |
476 | (dest . (jmp-if-false #(named elselab 0) halt))) | |
477 | ) | |
478 | ( ; rule -- reduce then to else | |
479 | (forest (ast #(hole innermost #(named src (then _ #(named else #(wildcard)) #(named elselab #(wildcard)))))) | |
480 | (out #(hole innermost #(named dest halt)))) . | |
481 | ((src . #(named else 0)) (dest . (label #(named elselab 0) halt))) | |
482 | ) | |
483 | ( ; rule -- translate operator | |
484 | (forest (ast #(hole innermost #(named src (> _ _)))) | |
485 | (out #(hole innermost #(named dest halt)))) . | |
486 | ((src . _) (dest . (gt halt))) | |
487 | ) | |
488 | ( ; rule -- translate command | |
489 | (forest (ast #(hole innermost #(named src (print _)))) | |
490 | (out #(hole innermost #(named dest halt)))) . | |
491 | ((src . _) (dest . (print halt))) | |
492 | ) | |
493 | ( ; rule -- translate literal | |
494 | (forest (ast #(hole innermost #(named src (lit #(named val #(wildcard)))))) | |
495 | (out #(hole innermost #(named dest halt)))) . | |
496 | ((src . _) (dest . (push #(named val) halt))) | |
497 | ) | |
498 | ) | |
499 | ) | |
500 | '(forest (ast _) | |
501 | (out (push 6 (push 4 (gt (jmp-if-false unique-ref-16 | |
502 | (push 1 (print (label unique-ref-16 (push 2 (print halt))))))))))) | |
503 | ) | |
504 | ||
505 | ; | |
506 | ; This test is pretty much exactly what we'd like to see for translation of | |
507 | ; "if" statements to machine code. It relies on the fact that all newrefs | |
508 | ; in a replacement generate the same new reference. It also uses an auxilliary | |
509 | ; tree, the bpt (branch point table) instead of rewriting the main AST to | |
510 | ; clarify somewhat the dependencies. | |
511 | ; | |
512 | (test rewrite-forest-5 | |
513 | (toplevel-reduce | |
514 | '(forest (ast (if (> (lit 6) (lit 4)) (print (lit 1)) (print (lit 2))) ) | |
515 | (bpt eot) | |
516 | (out halt)) | |
517 | '( | |
518 | ( ; rule -- get label for if | |
519 | (forest (ast #(hole innermost #(named src (if _ #(named then #(wildcard)) #(named else #(wildcard)) )))) | |
520 | (bpt #(hole innermost #(named branch eot))) | |
521 | (out #(hole innermost #(named dest halt)))) . | |
522 | ((branch . (then #(newref))) (dest . (jmp-if-false #(newref) halt))) | |
523 | ) | |
524 | ( ; rule -- get label for if | |
525 | (forest (ast #(hole innermost #(named src (if _ _ #(named else #(wildcard)) )))) | |
526 | (bpt #(hole innermost #(named branch (then #(named ref #(wildcard))) eot))) ; XXX??? | |
527 | (out #(hole innermost #(named dest halt)))) . | |
528 | ((branch . (else #(newref))) (dest . (goto #(newref) (label #(named ref 0) halt)))) | |
529 | ) | |
530 | ( ; rule -- get label for if | |
531 | (forest (ast #(hole innermost #(named src (if _ _ _) ))) | |
532 | (bpt #(hole innermost #(named branch (else #(named ref #(wildcard))) eot))) | |
533 | (out #(hole innermost #(named dest halt)))) . | |
534 | ((src . _) (branch . eot) (dest . (label #(named ref 0) halt))) | |
535 | ) | |
536 | ( ; rule -- translate operator | |
537 | (forest (ast #(hole innermost #(named src (> _ _)))) | |
538 | (bpt #(wildcard)) | |
539 | (out #(hole innermost #(named dest halt)))) . | |
540 | ((src . _) (dest . (gt halt))) | |
541 | ) | |
542 | ( ; rule -- translate command | |
543 | (forest (ast #(hole innermost #(named src (print _)))) | |
544 | (bpt #(wildcard)) | |
545 | (out #(hole innermost #(named dest halt)))) . | |
546 | ((src . _) (dest . (print halt))) | |
547 | ) | |
548 | ( ; rule -- translate literal | |
549 | (forest (ast #(hole innermost #(named src (lit #(named val #(wildcard)))))) | |
550 | (bpt #(wildcard)) | |
551 | (out #(hole innermost #(named dest halt)))) . | |
552 | ((src . _) (dest . (push #(named val 0) halt))) | |
553 | ) | |
554 | )) | |
555 | '(forest (ast _) | |
556 | (bpt eot) | |
557 | (out (push 6 (push 4 (gt (jmp-if-false unique-ref-16 | |
558 | (push 1 (print (goto unique-ref-29 | |
559 | (label unique-ref-16 (push 2 (print | |
560 | (label unique-ref-29 halt))))))))))))) | |
561 | ) | |
562 | ||
563 | ; Treacle syntax for previous test. | |
564 | ||
565 | (test rewrite-forest-6 | |
566 | (toplevel-reduce | |
567 | '(forest (ast (if (> (lit 6) (lit 4)) (print (lit 1)) (print (lit 2))) ) | |
568 | (bpt eot) | |
569 | (out halt)) | |
570 | (rules | |
571 | (forest (ast (:i (? src (if _ (? then *) (? else *))))) | |
572 | (bpt (:i (? branch eot))) | |
573 | (out (:i (? dest halt)))) | |
574 | -> ( branch : (then @) dest : (jmp-if-false @ halt) ) | |
575 | ||
576 | (forest (ast (:i (? src (if _ _ (? else *))))) | |
577 | (bpt (:i (? branch (then (? ref *))))) | |
578 | (out (:i (? dest halt)))) | |
579 | -> ( branch : (else @) dest : (goto @ (label (? ref *) halt)) ) | |
580 | ||
581 | (forest (ast (:i (? src (if _ _ _)))) | |
582 | (bpt (:i (? branch (else (? ref *))))) | |
583 | (out (:i (? dest halt)))) | |
584 | -> ( src : _ branch : eot dest : (label (? ref *) halt) ) | |
585 | ||
586 | (forest (ast (:i (? src (> _ _ )))) | |
587 | (bpt *) | |
588 | (out (:i (? dest halt)))) | |
589 | -> ( src : _ dest : (gt halt) ) | |
590 | ||
591 | (forest (ast (:i (? src (print _)))) | |
592 | (bpt *) | |
593 | (out (:i (? dest halt)))) | |
594 | -> ( src : _ dest : (print halt) ) | |
595 | ||
596 | (forest (ast (:i (? src (lit (? val *))))) | |
597 | (bpt *) | |
598 | (out (:i (? dest halt)))) | |
599 | -> ( src : _ dest : (push (? val *) halt) ) | |
600 | ||
601 | )) | |
602 | '(forest (ast _) | |
603 | (bpt eot) | |
604 | (out (push 6 (push 4 (gt (jmp-if-false unique-ref-16 | |
605 | (push 1 (print (goto unique-ref-29 | |
606 | (label unique-ref-16 (push 2 (print | |
607 | (label unique-ref-29 halt))))))))))))) | |
608 | ) |
0 | ; | |
1 | ; Support for matching of patterns containing contexts (holes) | |
2 | ; Chris Pressey, March 2008 | |
3 | ; | |
4 | ||
5 | ; Copyright (c)2008 Cat's Eye Technologies. All rights reserved. | |
6 | ; | |
7 | ; Redistribution and use in source and binary forms, with or without | |
8 | ; modification, are permitted provided that the following conditions | |
9 | ; are met: | |
10 | ; | |
11 | ; 1. Redistributions of source code must retain the above copyright | |
12 | ; notices, this list of conditions and the following disclaimer. | |
13 | ; 2. Redistributions in binary form must reproduce the above copyright | |
14 | ; notices, this list of conditions, and the following disclaimer in | |
15 | ; the documentation and/or other materials provided with the | |
16 | ; distribution. | |
17 | ; 3. Neither the names of the copyright holders nor the names of their | |
18 | ; contributors may be used to endorse or promote products derived | |
19 | ; from this software without specific prior written permission. | |
20 | ; | |
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
22 | ; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
26 | ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
27 | ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
28 | ; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
29 | ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
30 | ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
31 | ; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
32 | ; POSSIBILITY OF SUCH DAMAGE. | |
33 | ||
34 | ; | |
35 | ; A traditional unifier is a set of (variable name, value) pairs indicating | |
36 | ; what value is bound to each variable name. In our case, unifiers contain | |
37 | ; (name, term index) pairs which bind named to indices into the subject term. | |
38 | ; In a sense, conventional unifiers are unifiers "by value" while Treacle's | |
39 | ; are unifiers "by reference". | |
40 | ; | |
41 | ; Note also that in these unifiers, the same name can be bound to *multiple* | |
42 | ; positions within the subject, since the name may occur in any number of | |
43 | ; positions in the pattern, and will match as long as those subterms are | |
44 | ; equivalent. | |
45 | ; | |
46 | ||
47 | ; | |
48 | ; Create and return a new, empty unifier. | |
49 | ; | |
50 | (define mk-empty-unifier | |
51 | (lambda () | |
52 | '())) | |
53 | ||
54 | ; | |
55 | ; Extend the given unifier to one where the given name is associated with | |
56 | ; the given term index in the given subject term. If such an extension is | |
57 | ; not possible (i.e. the name is already bound to an inequivalent term at | |
58 | ; a different index in the subject,) then #f is returned. | |
59 | ; | |
60 | (define bind-name | |
61 | (lambda (subject index name unifier) | |
62 | (if (scour-unifier? subject index name unifier) | |
63 | (cons (cons name index) unifier) | |
64 | #f))) | |
65 | ||
66 | ; | |
67 | ; Helper function for bind-name. Returns #t if it's OK to extend the | |
68 | ; unifier with the given name->index association, #f otherwise | |
69 | ; | |
70 | (define scour-unifier? | |
71 | (lambda (subject index name unifier) | |
72 | (cond | |
73 | ((null? unifier) | |
74 | #t) | |
75 | (else | |
76 | (let* ((pair (car unifier)) | |
77 | (bound-name (car pair)) | |
78 | (bound-index (cdr pair))) | |
79 | (cond | |
80 | ((not (eq? name bound-name)) | |
81 | (scour-unifier? subject index name (cdr unifier))) | |
82 | ((eqv? index bound-index) ; already bound to same place: ok | |
83 | (scour-unifier? subject index name (cdr unifier))) | |
84 | ((eqv? (term-index-fetch subject index) ; already bound to equiv | |
85 | (term-index-fetch subject (cdr pair))) ; term: alright | |
86 | (scour-unifier? subject index name (cdr unifier))) | |
87 | (else ; already bound to something else: not good | |
88 | #f))))))) | |
89 | ||
90 | ; | |
91 | ; Given a subject, a replacement, and a unifier, return a term which is like | |
92 | ; the replacement except where where each of the placeholders in the replacement | |
93 | ; has been replaced by the associated term referenced in the unifier. | |
94 | ; | |
95 | (define expand-vars | |
96 | (lambda (subject replacement unifier generation-id) | |
97 | (cond ((is-named? replacement) ; variable - replace if in unifier | |
98 | (let* ((pair (assq (get-name replacement) unifier))) | |
99 | (cond ((pair? pair) | |
100 | (term-index-fetch subject (cdr pair))) | |
101 | (else | |
102 | replacement)))) | |
103 | ((is-newref? replacement) | |
104 | (string->symbol (string-append "unique-ref-" (number->string generation-id)))) | |
105 | ((list? replacement) ; list - recurse | |
106 | (map (lambda (subpattern) | |
107 | (expand-vars subject subpattern unifier generation-id)) | |
108 | replacement)) | |
109 | (else ; ground term - leave it alone. | |
110 | replacement)))) |
0 | ; | |
1 | ; Utility functions used by Treacle | |
2 | ; Chris Pressey, March 2008 | |
3 | ; | |
4 | ||
5 | ; Copyright (c)2008 Cat's Eye Technologies. All rights reserved. | |
6 | ; | |
7 | ; Redistribution and use in source and binary forms, with or without | |
8 | ; modification, are permitted provided that the following conditions | |
9 | ; are met: | |
10 | ; | |
11 | ; 1. Redistributions of source code must retain the above copyright | |
12 | ; notices, this list of conditions and the following disclaimer. | |
13 | ; 2. Redistributions in binary form must reproduce the above copyright | |
14 | ; notices, this list of conditions, and the following disclaimer in | |
15 | ; the documentation and/or other materials provided with the | |
16 | ; distribution. | |
17 | ; 3. Neither the names of the copyright holders nor the names of their | |
18 | ; contributors may be used to endorse or promote products derived | |
19 | ; from this software without specific prior written permission. | |
20 | ; | |
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
22 | ; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
26 | ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
27 | ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
28 | ; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
29 | ; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
30 | ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
31 | ; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
32 | ; POSSIBILITY OF SUCH DAMAGE. | |
33 | ||
34 | ; | |
35 | ; Debugging output. | |
36 | ; | |
37 | (define-syntax print | |
38 | (syntax-rules () | |
39 | ((print e) | |
40 | (display e)) | |
41 | ((print e1 e2 ...) | |
42 | (begin (display e1) | |
43 | (print e2 ...))))) | |
44 | ||
45 | (define-syntax println | |
46 | (syntax-rules () | |
47 | ((println e) | |
48 | (begin (display e) | |
49 | (newline))) | |
50 | ((println e1 e2 ...) | |
51 | (begin (display e1) | |
52 | (println e2 ...))))) | |
53 | ||
54 | ; | |
55 | ; Testing framework. | |
56 | ; | |
57 | (define-syntax test | |
58 | (syntax-rules () | |
59 | ((test test-name expr expected) | |
60 | (begin | |
61 | (print "Running test: " (quote test-name) "... ") | |
62 | (let ((result expr)) | |
63 | (cond | |
64 | ((equal? result expected) | |
65 | (println "passed.")) | |
66 | (else | |
67 | (println "FAILED!") | |
68 | (println "Expected: " expected) | |
69 | (println "Actual: " result)))))))) |