git @ Cat's Eye Technologies Treacle / c8b705a
Initial import of Treacle version 1.0 revision 2010.0427 sources. catseye 10 years ago
9 changed file(s) with 1636 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+217
-0
doc/treacle.html less more
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>
+95
-0
src/index.scm less more
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))))))
+163
-0
src/match.scm less more
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)))))))
+192
-0
src/pattern.scm less more
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))))
+92
-0
src/reduce.scm less more
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)))
+87
-0
src/syntax.scm less more
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 ))
+609
-0
src/tests.scm less more
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 )
+111
-0
src/unifier.scm less more
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))))
+70
-0
src/utils.scm less more
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))))))))