git @ Cat's Eye Technologies Arboretuum / d0fcfbf
Initial import of Arboretuum version 1.0 revision 2008.0304 sources. Cat's Eye Technologies 12 years ago
7 changed file(s) with 1124 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+104
-0
doc/arboretuum.html less more
0 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/2002/REC-xhtml1-20020801/DTD/xhtml1-strict.dtd">
1 <html xmlns="http://www.w3.org/1999/xhtml" lang="en">
2 <head>
3 <title>The Arboretuum Programming Language</title>
4 </head>
5 <body>
6
7 <h1>The Arboretuum Programming Language</h1>
8
9 <p>March 2008, Chris Pressey, Cat's Eye Technologies.</p>
10
11 <h2>Description</h2>
12
13 <p><dfn>Arboretuum</dfn> is a language based on an experimental variant of
14 tree-rewriting which we call <dfn>forest-rewriting</dfn>. Appropriate to its name, during
15 forest-rewriting, multiple trees (specifically, a finite set) are rewritten.
16 Each tree is labelled with a name; a rewriting pattern can refer to multiple trees,
17 and must match all of them simultaneously in order for a replacement to occur.</p>
18
19 <p>As an experiment, Arboretuum was not entirely a success. Forest-rewriting unfortunately turned out to
20 be insufficient for what I wanted to apply it to, namely compiler specification. The idea
21 was to have each tree associated with some data structure used in the compilation process
22 (AST, symbol table, output buffer, etc.) However, it became apparent that, by itself,
23 forest-rewriting could not synchronize the data across the trees the way it would need
24 to be synchronized in a real compiler. I plan to tackle the problem again, with a different variation
25 on rewriting, in a future project.</p>
26
27 <p>Regardless, Arboretuum is Turing-complete, as tree-rewriting is simply a special
28 case of forest-rewriting: just have one tree in the forest.</p>
29
30 <h2>Implementation</h2>
31
32 <p>I will refer you to the reference implementation of Arboretuum
33 for details on the semantics of the language. Ordinarily I frown upon this
34 sort of practice -- normatively defining a language by an implementation
35 rather than by a specification -- but the interests of brevity, the experimental tack of the
36 project, the unsuccessful outcome of the experiment, and the relative
37 well-definedness of the implementation language (the purely functional subset of R<sup>5</sup>RS Scheme) conspire
38 to make the consequences of this choice less painful than usual.</p>
39
40 <p>The reference implementation comprises the following files:</p>
41
42 <ul>
43
44 <li><code>preprocess.scm</code>
45 <p>Pre-processes the input program into an internal format
46 suitable for forest-rewriting.
47 </p></li>
48
49 <li><code>unify.scm</code>
50 <p>Implementation of the unification algorithm which is used to match
51 the pattern part of rewriting rules to the forest.
52 </p></li>
53
54 <li><code>forest-rewrite.scm</code>
55 <p>Implements the forest-rewriting process proper.
56 </p></li>
57
58 <li><code>utils.scm</code>
59 <p>Miscellanous support procedures, including <code>mergesort</code>,
60 <code>vector-store</code> (a side-effect-free alternative to <code>vector-set!</code>),
61 <code>print</code> and <code>test</code>.
62 </p></li>
63
64 </ul>
65
66 <p>In addition, the following supplementary files which are not definitive
67 w.r.t. the Arboretuum language are included in the project:</p>
68
69 <ul>
70
71 <li><code>tests.scm</code>
72 <p>Gives a set of unit tests to confirm the absence of certain erroneous behaviours.
73 (Obviously, no number of unit tests could confirm the absence of <em>errors</em>...)
74 </p></li>
75
76 <li><code>tree-rewrite.scm</code>
77 <p>Some basic tree-rewriting code, to provide contrast between it's complexity
78 and that of forest rewriting.</p>
79
80 </p></li>
81
82 </ul>
83
84 <p>Note that the Scheme implementation of algorithms in the above files are
85 to be taken as <em>pedantic</em> rather than <em>efficient</em>.
86 They are meant to be read (perhaps even enjoyed?) and only incidentally
87 to be executed.</p>
88
89 <h2>History</h2>
90
91 <p>This project was begun in January 2006. I'd been meaning to release
92 it for a while before actually doing so in March of 2008.</p>
93
94 <p>Happy forest-rewriting!</p>
95
96 <p>-Chris Pressey
97 <br>Cat's Eye Technologies
98 <br>March 4, 2008
99 <br>Chicago, Illinois, USA</p>
100
101
102 </body>
103 </html>
+159
-0
src/forest-rewrite.scm less more
0 ;
1 ; Forest Rewriting
2 ; Chris Pressey, late January 2006
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 term, a pattern to look for in that term, a replacement pattern,
36 ; and a unifier (set of substitutions,) determine if the term could be
37 ; rewritten, and if so, return a vector consisting of:
38 ;
39 ; - a partially rewritten term. The replacement pattern is substituted into
40 ; the term but WITHOUT the variables expanded into ground terms.
41 ; - a (possibly new) unifier
42 ;
43 ; The rewrite process first recurses into the term's children (bottom-up
44 ; rewriting.) If the given pattern fails to unify anywhere in the term,
45 ; #f is returned.
46 ;
47 (define partial-rewrite
48 (lambda (term pattern replacement unifier)
49 (cond ((list? term)
50 (let loop ((subterms term) ; first try to unify with each child
51 (acc '())) ; keep track of subterms we've seen
52 (cond ((null? subterms) ; no more children. lament failure.
53 (direct-partial-rewrite term pattern replacement unifier))
54 (else
55 (let* ((subterm (car subterms))
56 (rest (cdr subterms))
57 (result (partial-rewrite subterm pattern replacement unifier)))
58 (cond (result ; this child succeeded. pass along its result
59 (let* ((result-term (vector-ref result 0))
60 (result-unifier (vector-ref result 1))
61 (front (reverse acc))
62 (back (cons result-term rest))
63 (spliced-term (append front back)))
64 (vector spliced-term result-unifier)))
65 (else ; this child failed,
66 (loop rest (cons subterm acc))))))))) ; try the next one.
67 (else
68 (direct-partial-rewrite term pattern replacement unifier)))))
69
70 ;
71 ; Essentially a helper function for partial-rewrite; if the given
72 ; pattern unifies with the given term, just return a vector containing
73 ; the replacement and the (updated) unifier, else return #f.
74 ;
75 (define direct-partial-rewrite
76 (lambda (term pattern replacement unifier)
77 (let* ((new-unifier (unify term pattern unifier))) ; try to unify
78 (cond (new-unifier ; successfully unified, so rewrite
79 (vector replacement new-unifier))
80 (else
81 #f)))))
82
83 ;
84 ; Given a vector of terms with variable placeholders in them, and
85 ; a unifier, modify the vector so that the variables are replaced
86 ; by their respective replacements (substitutions) in the unifier,
87 ; and return the modified vector.
88 ;
89 (define expand-forest
90 (lambda (terms unifier)
91 (let loop ((terms terms)
92 (term-num (- (vector-length terms) 1)))
93 (cond ((< term-num 0)
94 terms)
95 (else
96 (let* ((term (vector-ref terms term-num))
97 (new-term (expand-vars term unifier))
98 (new-terms (vector-store terms term-num new-term))
99 (next-term-num (- term-num 1)))
100 (loop new-terms next-term-num)))))))
101
102 ;
103 ; Rewrite a vector of terms in tandem using a list of rules, with a
104 ; shared unifier (so that variable matches are common to all terms.)
105 ; Return a vector of rewritten terms, if the rule list matched, otherwise #f.
106 ;
107 (define rewrite-terms-with-compound-rule
108 (lambda (original-terms original-compound-rule)
109 (let loop ((terms original-terms)
110 (compound-rule original-compound-rule)
111 (unifier '()))
112 (cond ((null? compound-rule) ; when we reach the end of the list,
113 (expand-forest terms unifier)) ; expand variables in all the new terms
114 (else
115 (let* ((rule (car compound-rule))
116 (rest-rules (cdr compound-rule))
117 (targ-term-no (vector-ref rule 0))
118 (pattern (vector-ref rule 1))
119 (replacement (vector-ref rule 2))
120 (term (vector-ref terms targ-term-no))
121 (result (partial-rewrite term pattern replacement unifier)))
122 (cond (result ; we matched. update term, and try the next rule
123 (let* ((new-term (vector-ref result 0))
124 (new-unifier (vector-ref result 1))
125 (new-terms (vector-store terms targ-term-no new-term)))
126 (loop new-terms rest-rules new-unifier)))
127 (else ; no match. abort the entire thing.
128 #f))))))))
129
130 ;
131 ; Given a vector(#2) of:
132 ; a vector of terms, and
133 ; a list of compound rules,
134 ; rewrite all terms simultaneously with each of the compound rules.
135 ; Rewriting a set of terms simultaneously means that the variables in the
136 ; compound rule are shared across the terms, and will only unify with subterms
137 ; that are common to all of the terms.
138 ;
139 ; Keep applying compound rules until there are none that apply any longer.
140 ;
141 ; Return a vector of terms so rewritten.
142 ;
143 (define rewrite-forest
144 (lambda (everything)
145 (let* ((original-terms (vector-ref everything 0))
146 (all-compound-rules (vector-ref everything 1)))
147 (let loop ((terms original-terms)
148 (compound-rules all-compound-rules))
149 (cond ((null? compound-rules)
150 terms) ; terminate and return new termlist
151 (else
152 (let* ((compound-rule (car compound-rules))
153 (new-terms (rewrite-terms-with-compound-rule
154 terms compound-rule)))
155 (cond (new-terms ; successfully rewrote.
156 (loop new-terms all-compound-rules)) ; try again, using all compound-rules
157 (else
158 (loop terms (cdr compound-rules))))))))))) ; try again, using rest of compound-rules
+165
-0
src/preprocess.scm less more
0 ;
1 ; Preprocessor for Forest Rewriter
2 ; Chris Pressey, sometime late January 2006
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 ; The goal here is to allow the compound-rules to be specified in a nicer,
36 ; more flexible syntax, and preprocess them so that they are in a form that
37 ; this engine can handle (eventually they should be compiled to super-efficient
38 ; sequential code that "knows" which rewrites are likely immediately after
39 ; other rewrites occur; but, first things first.)
40 ;
41 ; The most important part of this is *sorting* the rules by *specificity*
42 ; so that the most specific rules are applied first.
43 ;
44 ; Ideally this would solve all our problems. But it might not, so we probably
45 ; want a stable sorting algorithm that preserves the relative order specified
46 ; by the programmer.
47 ;
48 ; Another reason to do this is to do type checking and other static analysis.
49 ; e.g. a variable which appears on some RHS of a compound-rule, must also
50 ; appear on some LHS of that compound-rule.
51 ;
52
53 ;
54 ; The terms and compound-rules, before preprocessing, look like this:
55 ;
56 ; (
57 ; ( ; list of named terms
58 ; (ast: ()) ; a named terms
59 ; (stab: ())
60 ; (out: ())
61 ; )
62 ; ( ; list of compound-rules
63 ; ((ast: foo => bar) (stab: bee => hive)) ; a compound-rule
64 ; )
65 ; )
66
67
68 ;
69 ; Let's borrow Aardappel's specificity ordering here: var < num < sym < list
70 ;
71 (define more-general-pattern-than?
72 (lambda (pattern-a pattern-b)
73 (cond ((null? pattern-a)
74 #t)
75 ((null? pattern-b)
76 #f)
77 ((and (list? pattern-a) (list? pattern-b))
78 (or (more-general-pattern-than? (car pattern-a) (car pattern-b))
79 (more-general-pattern-than? (cdr pattern-a) (cdr pattern-b))))
80 (else
81 (< (term-specificity pattern-a) (term-specificity pattern-b))))))
82
83 (define term-specificity
84 (lambda (term)
85 (cond ((pattern-var? term)
86 1)
87 ((number? term)
88 2)
89 ((symbol? term)
90 3)
91 (else ; list, most likely
92 4))))
93
94 (define more-general-rule-than?
95 (lambda (rule-a rule-b)
96 (let* ((pattern-a (vector-ref rule-a 1))
97 (pattern-b (vector-ref rule-b 1)))
98 (more-general-pattern-than? pattern-a pattern-b))))
99
100 (define sort-compound-rule
101 (lambda (compound-rule)
102 (mergesort compound-rule more-general-rule-than?)))
103
104 ;
105 ; Returns a list like: ((ast: . 1) (stab: . 2) (out: . 3))
106 ; so that we can access a term's position in the vector given its name
107 ;
108 (define form-term-map
109 (lambda (named-terms-depic n acc)
110 (cond ((null? named-terms-depic)
111 (reverse acc))
112 (else
113 (let* ((named-term-depic (car named-terms-depic))
114 (name (car named-term-depic))
115 (pair (cons name n))
116 (new-acc (cons pair acc)))
117 (form-term-map (cdr named-terms-depic) (+ n 1) new-acc))))))
118
119 (define preprocess-named-terms
120 (lambda (named-terms-depic acc)
121 (cond ((null? named-terms-depic)
122 (list->vector (reverse acc)))
123 (else
124 (let* ((named-term-depic (car named-terms-depic))
125 (term (cadr named-term-depic))
126 (new-acc (cons term acc)))
127 (preprocess-named-terms (cdr named-terms-depic) new-acc))))))
128
129 ;
130 ; ((ast: foo => bar) (stab: bee => hive))
131 ;
132 (define preprocess-compound-rule
133 (lambda (compound-rule-depic term-map acc)
134 (cond ((null? compound-rule-depic)
135 (reverse acc))
136 (else
137 (let* ((rule-depic (car compound-rule-depic))
138 (rule-term-name (car rule-depic))
139 (rule-term-index (cdr (assq rule-term-name term-map)))
140 (rule-pattern (cadr rule-depic))
141 (rule-replacement (cadddr rule-depic))
142 (rule (vector rule-term-index rule-pattern rule-replacement))
143 (new-acc (cons rule acc)))
144 (preprocess-compound-rule (cdr compound-rule-depic) term-map new-acc))))))
145
146 (define preprocess-compound-rules
147 (lambda (compound-rules-depic term-map acc)
148 (cond ((null? compound-rules-depic)
149 (reverse acc))
150 (else
151 (let* ((compound-rule-depic (car compound-rules-depic))
152 (compound-rule (preprocess-compound-rule compound-rule-depic term-map '()))
153 (sorted-compound-rule (sort-compound-rule compound-rule))
154 (new-acc (cons sorted-compound-rule acc)))
155 (preprocess-compound-rules (cdr compound-rules-depic) term-map new-acc))))))
156
157 (define preprocess
158 (lambda (depic)
159 (let* ((named-terms-depic (car depic))
160 (compound-rules-depic (cadr depic))
161 (term-map (form-term-map named-terms-depic 0 '()))
162 (term-vector (preprocess-named-terms named-terms-depic '()))
163 (compound-rules (preprocess-compound-rules compound-rules-depic term-map '())))
164 (vector term-vector compound-rules))))
+334
-0
src/tests.scm less more
0 ;
1 ; Test suite for forest-rewriting project
2 ; Chris Pressey, sometime late January 2006
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 (load "utils.scm");--------------------------------------------------------
36
37 (test 'split-1
38 (lambda ()
39 (split '(1 2 3 4 5 6 7 8) '() '()))
40 '((1 3 5 7) . (2 4 6 8))
41 )
42
43 (test 'split-2
44 (lambda ()
45 (split '(1 2 3 4 5 6 7) '() '()))
46 '((1 3 5 7) . (2 4 6))
47 )
48
49 (test 'merge-1
50 (lambda ()
51 (merge '(2 4 6 8) '(1 3 5 7) > '()))
52 '(1 2 3 4 5 6 7 8)
53 )
54
55 (test 'split-and-merge-1
56 (lambda ()
57 (let* ((pair (split '(1 2 3 4 5 6 7) '() '()))
58 (left (car pair))
59 (right (cdr pair)))
60 (merge left right > '())))
61 '(1 2 3 4 5 6 7)
62 )
63
64 (test 'mergesort-1
65 (lambda ()
66 (mergesort '(8 26 4 78 13 65 12 91 64 2) >))
67 '(2 4 8 12 13 26 64 65 78 91)
68 )
69
70 (load "unify.scm");--------------------------------------------------------
71
72 (test 'unify-1
73 (lambda ()
74 (unify
75 '(+ 1 2)
76 '(+ #(a) #(b))
77 '()
78 ))
79 '((b . 2) (a . 1))
80 )
81
82 (test 'unify-2
83 (lambda ()
84 (unify
85 '(+ 1 1)
86 '(+ #(a) #(a))
87 '()
88 ))
89 '((a . 1))
90 )
91
92 (test 'unify-3
93 (lambda ()
94 (unify
95 '(+ 1 2)
96 '(+ #(a) #(a))
97 '()
98 ))
99 #f
100 )
101
102 (test 'unify-4
103 (lambda ()
104 (unify
105 '(+ 1 1)
106 '(+ #(a) #(a))
107 '((a . 2))
108 ))
109 #f
110 )
111
112 (load "tree-rewrite.scm");--------------------------------------------------
113
114 (test 'reduce-term-1
115 (lambda ()
116 (reduce-term
117 '(+ 6 (+ 3 3))
118 '(
119 ((+ #(A) #(A)) . (* #(A) 2))
120 )
121 ))
122 '(+ 6 (* 3 2))
123 )
124
125 (test 'reduce-term-2
126 (lambda ()
127 (reduce-term
128 '(+ (const 9) (* (const 2) (const 3)))
129 '(
130 ((const #(a)) . (push #(a) _) )
131 ((+ #(l) #(r)) . (then (then #(l) #(r)) (add _)) )
132 ((* #(l) #(r)) . (then (then #(l) #(r)) (mul _)) )
133 ((then _ #(c)) . #(c) )
134 ((then (#(op) #(a)) #(b)) . (#(op) (then #(a) #(b))) )
135 ((then (#(op) #(k) #(a)) #(b)) . (#(op) #(k) (then #(a) #(b))) )
136 )
137 ))
138 '(push 9 (push 2 (push 3 (mul (add _)))))
139 )
140
141 (test 'reduce-term-3
142 (lambda ()
143 (reduce-term
144 '(+ (const 9)
145 (if (> (const 3) (const 2))
146 (* (const 2) (const 3))
147 (const 1)))
148 '(
149 ((const #(a)) . (push #(a) _) )
150 ((+ #(l) #(r)) . (then (then #(l) #(r)) (add _)) )
151 ((* #(l) #(r)) . (then (then #(l) #(r)) (mul _)) )
152 ((> #(l) #(r)) . (then (then #(l) #(r)) (gt _)) )
153
154 ((if #(q) #(t) #(f)) .
155 (then #(q) (jfalse label:
156 (then #(t) (jmp end:
157 (label label:
158 (then #(f) (label end: _))))))) )
159
160 ((gt (jfalse #(l) #(rest))) . (jle #(l) #(rest)) )
161
162 ((then _ #(c)) . #(c) )
163 ((then (#(op) #(a)) #(b)) . (#(op) (then #(a) #(b))) )
164 ((then (#(op) #(k) #(a)) #(b)) . (#(op) #(k) (then #(a) #(b))) )
165 )
166 ))
167 '(push 9 (push 3 (push 2 (jle label: (push 2 (push 3 (mul (jmp end:
168 (label label: (push 1 (label end: (add _))))))))))))
169 )
170
171 (load "preprocess.scm");---------------------------------------------------
172
173 (test 'preprocess-1
174 (lambda ()
175 (preprocess
176 '(
177 ( ; list of named terms
178 (ast: (const a 4 (+ 3 (* a 3)))) ; a named term
179 (stab: eot)
180 (out: halt)
181 )
182 ( ; list of compound-rules
183 ((ast: foo => bar) (stab: bee => hive)) ; a compound-rule
184 )
185 )
186 ))
187 '#(
188 #((const a 4 (+ 3 (* a 3))) eot halt)
189 ((#(0 foo bar) #(1 bee hive)))
190 )
191 )
192
193 (load "forest-rewrite.scm");--------------------------------------------------
194
195 (test 'rewrite-tree-1
196 (lambda ()
197 (rewrite-forest (preprocess
198 '(
199 (
200 (ast: (+ (const 9) (* (const 2) (const 3))))
201 )
202 (
203 ((ast: (const #(a)) => (push #(a) _) ))
204 ((ast: (+ #(l) #(r)) => (then (then #(l) #(r)) (add _)) ))
205 ((ast: (* #(l) #(r)) => (then (then #(l) #(r)) (mul _)) ))
206 ((ast: (then _ #(c)) => #(c) ))
207 ((ast: (then (#(op) #(a)) #(b)) => (#(op) (then #(a) #(b))) ))
208 ((ast: (then (#(op) #(k) #(a)) #(b)) => (#(op) #(k) (then #(a) #(b))) ))
209 )
210 )
211 )))
212 '#((push 9 (push 2 (push 3 (mul (add _))))))
213 )
214
215 (test 'rewrite-tree-2
216 (lambda ()
217 (rewrite-forest (preprocess
218 '(
219 (
220 (ast: (+ (const 9)
221 (if (> (const 3) (const 2))
222 (* (const 2) (const 3))
223 (const 1)))
224 )
225 )
226 (
227 ((ast: (const #(a)) => (push #(a) _) ))
228 ((ast: (+ #(l) #(r)) => (then (then #(l) #(r)) (add _)) ))
229 ((ast: (* #(l) #(r)) => (then (then #(l) #(r)) (mul _)) ))
230 ((ast: (> #(l) #(r)) => (then (then #(l) #(r)) (gt _)) ))
231
232 ((ast: (if #(q) #(t) #(f)) =>
233 (then #(q) (jfalse label: (then #(t) (jmp end: (label label: (then #(f) (label end: _))))))) ))
234
235 ((ast: (gt (jfalse #(l) #(rest))) => (jle #(l) #(rest)) ))
236
237 ((ast: (then _ #(c)) => #(c) ))
238 ((ast: (then (#(op) #(a)) #(b)) => (#(op) (then #(a) #(b))) ))
239 ((ast: (then (#(op) #(k) #(a)) #(b)) => (#(op) #(k) (then #(a) #(b))) ))
240 )
241 )
242 )))
243 '#((push 9 (push 3 (push 2 (jle label: (push 2 (push 3 (mul (jmp end:
244 (label label: (push 1 (label end: (add _)))))))))))))
245 )
246
247 ;-------------------------------------------------------------------
248
249 (test 'rewrite-forest-1
250 (lambda ()
251 (rewrite-forest (preprocess
252 '(
253 (
254 (ast: (+ 3 (* 2 3)))
255 (out: halt)
256 )
257 (
258 ((ast: #(a num) => _) (out: halt => (push #(a) halt)))
259 ((ast: (+ _ _) => _) (out: halt => (add halt)))
260 ((ast: (* _ _) => _) (out: halt => (mul halt)))
261 )
262 )
263 )))
264 '#(_ (push 3 (push 2 (push 3 (mul (add halt))))))
265 )
266
267 (test 'rewrite-forest-2
268 (lambda ()
269 (rewrite-forest (preprocess
270 '(
271 (
272 (stab: (a 4 eot))
273 (ast: (+ 1 2 3 a 5 6 a 7 8 9))
274 )
275 (
276 ( (stab: (#(n) #(v) #(tab)) => (#(n) #(v) #(tab)) )
277 (ast: #(n sym) => #(v) ) )
278 )
279 )
280 )))
281 '#((a 4 eot) (+ 1 2 3 4 5 6 4 7 8 9))
282 )
283
284 (test 'rewrite-forest-3
285 (lambda ()
286 (rewrite-forest (preprocess
287 '(
288 (
289 (ast: (let a 4 (+ 3 (* a 3))) )
290 (stab: eot)
291 (out: halt)
292 )
293 (
294 ((ast: (let #(n sym) #(v) #(expr)) => #(expr) )
295 (stab: eot => (#(n) #(v) EOT) ))
296 ((ast: #(n sym) => #(v) )
297 (stab: (#(n) #(v) #(tab)) => (#(n) #(v) #(tab)) ))
298 ((ast: #(a num) => _ )
299 (out: halt => (push #(a) halt) ))
300 ((ast: (+ _ _) => _ )
301 (out: halt => (add halt) ))
302 ((ast: (* _ _) => _ )
303 (out: halt => (mul halt) ))
304 )
305 )
306 )))
307 '#(_ (a 4 eot) (push 3 (push 4 (push 3 (mul (add halt))))))
308 )
309
310 ;(test 'rewrite-forest-4
311 ; (lambda ()
312 ; (rewrite-forest (preprocess
313 ; '(
314 ; (
315 ; (ast: (if (> 6 4) (print 1) (print 2)) )
316 ; (bpt: eot)
317 ; (out: halt)
318 ; )
319 ; (
320 ; ((ast: (> _ _) => _ )
321 ; (out: halt => (gt halt) ))
322 ; ((ast: (print _) => _ )
323 ; (out: halt => (print halt) ))
324 ; ((ast: #(a num) => _ )
325 ; (out: halt => (push #(a) halt) ))
326 ; ((ast: (if _ #(t) #(p)) => (hmm #(t) #(p)) )
327 ; (out: halt => (test halt) ))
328 ; )
329 ; )
330 ; )))
331 ; '#(_ (a 4 eot) (push 3 (push 4 (push 3 (mul (add halt))))))
332 ;)
333
+97
-0
src/tree-rewrite.scm less more
0 ;
1 ; Bottom-Up Tree-Rewriting (Term-Rewriting)
2 ; Chris Pressey, sometime late January 2006
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 ; Try unifying the pattern part of the given rule with the given term;
36 ; if it matches, return a rewritten term based on the unifier and the
37 ; replacement part of the rule; otherwise return #f.
38 ;
39 (define rewrite-single-term
40 (lambda (term rules)
41 (cond
42 ((null? rules)
43 #f)
44 (else
45 (let* ((rule (car rules))
46 (pattern (car rule))
47 (replacement (cdr rule))
48 (unifier (unify term pattern '())))
49 (cond
50 (unifier
51 (expand-vars replacement unifier))
52 (else
53 (rewrite-single-term term (cdr rules)))))))))
54
55 ;
56 ; Rewrite the given term recursively, with the given set of rules,
57 ; from the bottom up (preorder traversal.) Returns the rewritten
58 ; term if successful, #f if not. rules is a list of pat-repl pairs.
59 ;
60 (define rewrite-bottom-up
61 (lambda (term rules)
62 (cond
63 ((list? term)
64 (let loop ((subterms term) ; first try to unify with each child
65 (acc '())) ; keep track of subterms we've seen
66 (cond
67 ((null? subterms) ; no more children, try rewrite.
68 (rewrite-single-term term rules))
69 (else
70 (let* ((subterm (car subterms))
71 (rest (cdr subterms))
72 (new-subterm (rewrite-bottom-up subterm rules)))
73 (cond
74 (new-subterm ; this child succeeded. incorporate it
75 (let* ((front (reverse acc))
76 (back (cons new-subterm rest))
77 (spliced-term (append front back)))
78 spliced-term))
79 (else ; this child failed, try next one
80 (loop (cdr subterms) (cons subterm acc)))))))))
81 (else
82 (rewrite-single-term term rules)))))
83
84 ;
85 ; Repeatedly rewrite the given term with the given rules until it
86 ; is reduced into a normal form (if one exists for these rules.)
87 ; Return the reduced term.
88 ;
89 (define reduce-term
90 (lambda (term rules)
91 (let* ((new-term (rewrite-bottom-up term rules)))
92 (cond
93 (new-term
94 (reduce-term new-term rules))
95 (else
96 term)))))
+139
-0
src/unify.scm less more
0 ;
1 ; Simple support for unification & pattern matching
2 ; Chris Pressey, late January 2006
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 ; Return #t if the given pattern is a variable, #f otherwise.
36 ;
37 (define pattern-var?
38 (lambda (pattern)
39 (vector? pattern))) ; just check that it is a vector
40
41 ;
42 ; Return the name of the given pattern variable.
43 ;
44 (define get-pattern-var-name
45 (lambda (pattern-var)
46 (vector-ref pattern-var 0))) ; just return the 1st element of the vector
47
48 ;
49 ; Return the optional predicate associated with the given pattern
50 ; variable, which determines what kind of (Scheme) terms it can
51 ; unify with. If no predicate is associated with the variable,
52 ; a dummy always-true predicate is returned.
53 ;
54 (define get-pattern-var-pred
55 (lambda (pattern-var)
56 (cond ((< (vector-length pattern-var) 2)
57 (lambda (x) #t))
58 (else
59 (let ((term-type (vector-ref pattern-var 1)))
60 (cond ((eqv? term-type 'num)
61 (lambda (x) (number? x)))
62 ((eqv? term-type 'sym)
63 (lambda (x) (symbol? x)))
64 (else
65 (lambda (x) #f))))))))
66
67 ;
68 ; Register that the named pattern variable should be associated with the given
69 ; term in the given unifier. A new unifier containing the new variable-term
70 ; association will be returned if possible; if it is not possible (i.e. the
71 ; variable is already bound to a different term,) #f is returned.
72 ;
73 (define bind-pattern-var
74 (lambda (term pattern unifier)
75 (let* ((var-name (get-pattern-var-name pattern))
76 (var-pred? (get-pattern-var-pred pattern))
77 (pair (assq var-name unifier)))
78 (cond
79 ((not (var-pred? term))
80 #f)
81 ((not (pair? pair)) ; if it's not in unifier,
82 (cons (cons var-name term) unifier)) ; add it up front
83 ((eqv? (cdr pair) term) ; already bound to the given term: alright
84 unifier)
85 (else ; already bound to something else: not good
86 #f)))))
87
88 ;
89 ; Helper function.
90 ; Given a term and a pattern, where we know both are lists,
91 ; fold over both of them, unifying all the corresponding elements.
92 ;
93 (define unify-lists
94 (lambda (term pattern unifier)
95 (cond ((and (null? term) (null? pattern)) ; end of both
96 unifier)
97 ((or (null? term) (null? pattern)) ; end of one but not the other
98 #f)
99 (else
100 (let ((new-unifier (unify (car term) (car pattern) unifier)))
101 (if new-unifier
102 (unify-lists (cdr term) (cdr pattern) new-unifier)
103 #f))))))
104
105 ;
106 ; Return #f if the term does not unify with the pattern,
107 ; or a list of substitutions if it does unify.
108 ;
109 (define unify
110 (lambda (term pattern unifier)
111 (cond ((pattern-var? pattern)
112 (bind-pattern-var term pattern unifier))
113 ((and (list? term) (list? pattern))
114 (unify-lists term pattern unifier))
115 ((eqv? term pattern)
116 unifier)
117 (else
118 #f))))
119
120 ;
121 ; Given a pattern and a unifier (set of substitutions,) return a term
122 ; where all the variables in the pattern have been replaced by their
123 ; associated term in the unifier.
124 ;
125 (define expand-vars
126 (lambda (pattern unifier)
127 (cond ((pattern-var? pattern) ; variable - replace if in unifier
128 (let* ((pair (assq (get-pattern-var-name pattern) unifier)))
129 (cond ((pair? pair)
130 (cdr pair))
131 (else
132 pattern))))
133 ((list? pattern) ; list - recurse
134 (map (lambda (subpattern)
135 (expand-vars subpattern unifier))
136 pattern))
137 (else ; ground term - leave it alone.
138 pattern))))
+126
-0
src/utils.scm less more
0 ;
1 ; Utility functions used by forest-rewriting project
2 ; Chris Pressey, late January 2006
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 ; Sort a list using mergesort.
36 ;
37 (define mergesort
38 (lambda (lst gt-pred?)
39 (cond ((null? lst)
40 lst)
41 ((null? (cdr lst))
42 lst)
43 (else
44 (let* ((pair (split lst '() '()))
45 (left (mergesort (car pair) gt-pred?))
46 (right (mergesort (cdr pair) gt-pred?)))
47 (merge left right gt-pred? '()))))))
48
49 ;
50 ; Yield a pair of lists, each containing roughly half the
51 ; elements of the given list.
52 ;
53 (define split
54 (lambda (lst acc1 acc2)
55 (cond
56 ((null? lst)
57 (cons (reverse acc1) (reverse acc2)))
58 ((null? (cdr lst))
59 (cons (reverse (append lst acc1)) (reverse acc2)))
60 (else
61 (let* ((left (car lst))
62 (right (cadr lst))
63 (rest (cddr lst)))
64 (split rest (cons left acc1) (cons right acc2)))))))
65
66 ;
67 ; Given two sorted lists, return a sorted list that contains
68 ; all of the elements from both lists.
69 ;
70 (define merge
71 (lambda (list1 list2 gt-pred? acc)
72 (cond
73 ((and (null? list1) (null? list2))
74 (reverse acc))
75 ((null? list1)
76 (merge list1 (cdr list2) gt-pred? (cons (car list2) acc)))
77 ((null? list2)
78 (merge (cdr list1) list2 gt-pred? (cons (car list1) acc)))
79 ((gt-pred? (car list1) (car list2))
80 (merge list1 (cdr list2) gt-pred? (cons (car list2) acc)))
81 (else
82 (merge (cdr list1) list2 gt-pred? (cons (car list1) acc))))))
83
84 ;
85 ; Side-effect-free alternative to vector-set!
86 ;
87 (define vector-store
88 (lambda (vec index item)
89 (let loop ((items (vector->list vec))
90 (index index)
91 (item item)
92 (acc '()))
93 (cond ((null? items)
94 (list->vector (reverse acc)))
95 ((zero? index)
96 (loop (cdr items) (- index 1) item (cons item acc)))
97 (else
98 (loop (cdr items) (- index 1) item (cons (car items) acc)))))))
99
100 ;
101 ; Debugging output.
102 ;
103 (define print
104 (lambda list
105 (for-each display list)))
106
107 (define println
108 (lambda list
109 (for-each display list)
110 (newline)))
111
112 ;
113 ; Testing framework.
114 ;
115 (define test
116 (lambda (test-name proc expected)
117 (print "Running test: " test-name "... ")
118 (let ((result (proc)))
119 (cond
120 ((equal? result expected)
121 (println "passed."))
122 (else
123 (println "FAILED!")
124 (println "Expected: " expected)
125 (println "Actual: " result))))))