Anonymous avatar Anonymous committed 5e36f09 Draft

Initial import of Arboretuum version 1.0 revision 2008.0304 sources.

Comments (0)

Files changed (7)

doc/arboretuum.html

+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/2002/REC-xhtml1-20020801/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en">
+<head>
+<title>The Arboretuum Programming Language</title>
+</head>
+<body>
+
+<h1>The Arboretuum Programming Language</h1>
+
+<p>March 2008, Chris Pressey, Cat's Eye Technologies.</p>
+
+<h2>Description</h2>
+
+<p><dfn>Arboretuum</dfn> is a language based on an experimental variant of
+tree-rewriting which we call <dfn>forest-rewriting</dfn>.  Appropriate to its name, during
+forest-rewriting, multiple trees (specifically, a finite set) are rewritten.
+Each tree is labelled with a name; a rewriting pattern can refer to multiple trees,
+and must match all of them simultaneously in order for a replacement to occur.</p>
+
+<p>As an experiment, Arboretuum was not entirely a success.  Forest-rewriting unfortunately turned out to
+be insufficient for what I wanted to apply it to, namely compiler specification.  The idea
+was to have each tree associated with some data structure used in the compilation process
+(AST, symbol table, output buffer, etc.)  However, it became apparent that, by itself,
+forest-rewriting could not synchronize the data across the trees the way it would need
+to be synchronized in a real compiler.  I plan to tackle the problem again, with a different variation
+on rewriting, in a future project.</p>
+
+<p>Regardless, Arboretuum is Turing-complete, as tree-rewriting is simply a special
+case of forest-rewriting: just have one tree in the forest.</p>
+
+<h2>Implementation</h2>
+
+<p>I will refer you to the reference implementation of Arboretuum
+for details on the semantics of the language.  Ordinarily I frown upon this
+sort of practice -- normatively defining a language by an implementation
+rather than by a specification -- but the interests of brevity, the experimental tack of the
+project, the unsuccessful outcome of the experiment, and the relative
+well-definedness of the implementation language (the purely functional subset of R<sup>5</sup>RS Scheme) conspire
+to make the consequences of this choice less painful than usual.</p>
+
+<p>The reference implementation comprises the following files:</p>
+
+<ul>
+
+<li><code>preprocess.scm</code>
+<p>Pre-processes the input program into an internal format
+suitable for forest-rewriting.
+</p></li>
+
+<li><code>unify.scm</code>
+<p>Implementation of the unification algorithm which is used to match
+the pattern part of rewriting rules to the forest.
+</p></li>
+
+<li><code>forest-rewrite.scm</code>
+<p>Implements the forest-rewriting process proper.
+</p></li>
+
+<li><code>utils.scm</code>
+<p>Miscellanous support procedures, including <code>mergesort</code>,
+<code>vector-store</code> (a side-effect-free alternative to <code>vector-set!</code>),
+<code>print</code> and <code>test</code>.
+</p></li>
+
+</ul>
+
+<p>In addition, the following supplementary files which are not definitive
+w.r.t. the Arboretuum language are included in the project:</p>
+
+<ul>
+
+<li><code>tests.scm</code>
+<p>Gives a set of unit tests to confirm the absence of certain erroneous behaviours.
+(Obviously, no number of unit tests could confirm the absence of <em>errors</em>...)
+</p></li>
+
+<li><code>tree-rewrite.scm</code>
+<p>Some basic tree-rewriting code, to provide contrast between it's complexity
+and that of forest rewriting.</p>
+
+</p></li>
+
+</ul>
+
+<p>Note that the Scheme implementation of algorithms in the above files are
+to be taken as <em>pedantic</em> rather than <em>efficient</em>.
+They are meant to be read (perhaps even enjoyed?) and only incidentally
+to be executed.</p>
+
+<h2>History</h2>
+
+<p>This project was begun in January 2006.  I'd been meaning to release
+it for a while before actually doing so in March of 2008.</p>
+
+<p>Happy forest-rewriting!</p>
+
+<p>-Chris Pressey
+<br>Cat's Eye Technologies
+<br>March 4, 2008
+<br>Chicago, Illinois, USA</p>
+
+
+</body>
+</html>

src/forest-rewrite.scm

+;
+; Forest Rewriting
+; Chris Pressey, late January 2006
+;
+
+; Copyright (c)2008 Cat's Eye Technologies.  All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+;    notices, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+;    notices, this list of conditions, and the following disclaimer in
+;    the documentation and/or other materials provided with the
+;    distribution.
+; 3. Neither the names of the copyright holders nor the names of their
+;    contributors may be used to endorse or promote products derived
+;    from this software without specific prior written permission. 
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+;
+; Given a term, a pattern to look for in that term, a replacement pattern,
+; and a unifier (set of substitutions,) determine if the term could be
+; rewritten, and if so, return a vector consisting of:
+;
+; - a partially rewritten term.  The replacement pattern is substituted into
+;   the term but WITHOUT the variables expanded into ground terms.
+; - a (possibly new) unifier
+;
+; The rewrite process first recurses into the term's children (bottom-up
+; rewriting.) If the given pattern fails to unify anywhere in the term,
+; #f is returned.
+;
+(define partial-rewrite
+  (lambda (term pattern replacement unifier)
+    (cond ((list? term)
+             (let loop ((subterms term)              ; first try to unify with each child
+                        (acc      '()))              ; keep track of subterms we've seen
+                (cond ((null? subterms)              ; no more children. lament failure.
+                        (direct-partial-rewrite term pattern replacement unifier))
+                      (else
+                        (let* ((subterm (car subterms))
+                               (rest    (cdr subterms))
+                               (result  (partial-rewrite subterm pattern replacement unifier)))
+                          (cond (result                   ; this child succeeded. pass along its result
+                                  (let* ((result-term    (vector-ref result 0))
+                                         (result-unifier (vector-ref result 1))
+                                         (front          (reverse acc))
+                                         (back           (cons result-term rest))
+                                         (spliced-term   (append front back)))
+                                    (vector spliced-term result-unifier)))
+                                (else                     ; this child failed,
+                                  (loop rest (cons subterm acc))))))))) ; try the next one.
+          (else
+            (direct-partial-rewrite term pattern replacement unifier)))))
+
+;
+; Essentially a helper function for partial-rewrite; if the given
+; pattern unifies with the given term, just return a vector containing
+; the replacement and the (updated) unifier, else return #f.
+;
+(define direct-partial-rewrite
+  (lambda (term pattern replacement unifier)
+    (let* ((new-unifier (unify term pattern unifier)))    ; try to unify
+      (cond (new-unifier                                  ; successfully unified, so rewrite
+              (vector replacement new-unifier))
+            (else
+              #f)))))
+
+;
+; Given a vector of terms with variable placeholders in them, and
+; a unifier, modify the vector so that the variables are replaced
+; by their respective replacements (substitutions) in the unifier,
+; and return the modified vector.
+;
+(define expand-forest
+  (lambda (terms unifier)
+    (let loop ((terms    terms)
+               (term-num (- (vector-length terms) 1)))
+      (cond ((< term-num 0)
+              terms)
+            (else
+              (let* ((term          (vector-ref terms term-num))
+                     (new-term      (expand-vars term unifier))
+                     (new-terms     (vector-store terms term-num new-term))
+                     (next-term-num (- term-num 1)))
+                (loop new-terms next-term-num)))))))
+
+;
+; Rewrite a vector of terms in tandem using a list of rules, with a
+; shared unifier (so that variable matches are common to all terms.)
+; Return a vector of rewritten terms, if the rule list matched, otherwise #f.
+;
+(define rewrite-terms-with-compound-rule
+  (lambda (original-terms original-compound-rule)
+      (let loop ((terms         original-terms)
+                 (compound-rule original-compound-rule)
+                 (unifier       '()))
+        (cond ((null? compound-rule)           ; when we reach the end of the list,
+                (expand-forest terms unifier)) ; expand variables in all the new terms
+              (else
+                (let* ((rule         (car compound-rule))
+                       (rest-rules   (cdr compound-rule))
+                       (targ-term-no (vector-ref rule 0))
+                       (pattern      (vector-ref rule 1))
+                       (replacement  (vector-ref rule 2))
+                       (term         (vector-ref terms targ-term-no))
+                       (result       (partial-rewrite term pattern replacement unifier)))
+                  (cond (result         ; we matched. update term, and try the next rule
+                          (let* ((new-term      (vector-ref result 0))
+                                 (new-unifier   (vector-ref result 1))
+                                 (new-terms     (vector-store terms targ-term-no new-term)))
+                            (loop new-terms rest-rules new-unifier)))
+                        (else           ; no match.  abort the entire thing.
+                          #f))))))))
+
+;
+; Given a vector(#2) of:
+;   a vector of terms, and
+;   a list of compound rules,
+; rewrite all terms simultaneously with each of the compound rules.
+; Rewriting a set of terms simultaneously means that the variables in the
+; compound rule are shared across the terms, and will only unify with subterms
+; that are common to all of the terms.
+;
+; Keep applying compound rules until there are none that apply any longer.
+;
+; Return a vector of terms so rewritten.
+;
+(define rewrite-forest
+  (lambda (everything)
+    (let* ((original-terms     (vector-ref everything 0))
+           (all-compound-rules (vector-ref everything 1)))
+      (let loop ((terms           original-terms)
+                 (compound-rules  all-compound-rules))
+        (cond ((null? compound-rules)
+                terms)                                  ; terminate and return new termlist
+              (else
+                (let* ((compound-rule (car compound-rules))
+                       (new-terms     (rewrite-terms-with-compound-rule
+                                         terms compound-rule)))
+                  (cond (new-terms                       ; successfully rewrote.
+                          (loop new-terms all-compound-rules)) ; try again, using all compound-rules
+                        (else
+                          (loop terms (cdr compound-rules))))))))))) ; try again, using rest of compound-rules

src/preprocess.scm

+;
+; Preprocessor for Forest Rewriter
+; Chris Pressey, sometime late January 2006
+;
+
+; Copyright (c)2008 Cat's Eye Technologies.  All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+;    notices, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+;    notices, this list of conditions, and the following disclaimer in
+;    the documentation and/or other materials provided with the
+;    distribution.
+; 3. Neither the names of the copyright holders nor the names of their
+;    contributors may be used to endorse or promote products derived
+;    from this software without specific prior written permission. 
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+;
+; The goal here is to allow the compound-rules to be specified in a nicer,
+; more flexible syntax, and preprocess them so that they are in a form that
+; this engine can handle (eventually they should be compiled to super-efficient
+; sequential code that "knows" which rewrites are likely immediately after
+; other rewrites occur; but, first things first.)
+;
+; The most important part of this is *sorting* the rules by *specificity*
+; so that the most specific rules are applied first.
+;
+; Ideally this would solve all our problems.  But it might not, so we probably
+; want a stable sorting algorithm that preserves the relative order specified
+; by the programmer.
+;
+; Another reason to do this is to do type checking and other static analysis.
+; e.g. a variable which appears on some RHS of a compound-rule, must also
+; appear on some LHS of that compound-rule.
+;
+
+;
+; The terms and compound-rules, before preprocessing, look like this:
+;
+; (
+;   (                                            ; list of named terms
+;     (ast: ())                                  ; a named terms
+;     (stab: ())
+;     (out: ())
+;   )
+;   (                                            ; list of compound-rules
+;     ((ast: foo => bar) (stab: bee => hive))    ; a compound-rule
+;   )
+; )
+
+
+;
+; Let's borrow Aardappel's specificity ordering here: var < num < sym < list
+;
+(define more-general-pattern-than?
+  (lambda (pattern-a pattern-b)
+    (cond ((null? pattern-a)
+            #t)
+          ((null? pattern-b)
+            #f)
+          ((and (list? pattern-a) (list? pattern-b))
+            (or (more-general-pattern-than? (car pattern-a) (car pattern-b))
+                (more-general-pattern-than? (cdr pattern-a) (cdr pattern-b))))
+          (else
+            (< (term-specificity pattern-a) (term-specificity pattern-b))))))
+
+(define term-specificity
+  (lambda (term)
+    (cond ((pattern-var? term)
+            1)
+          ((number? term)
+            2)
+          ((symbol? term)
+            3)
+          (else                ; list, most likely
+            4))))
+
+(define more-general-rule-than?
+  (lambda (rule-a rule-b)
+    (let* ((pattern-a (vector-ref rule-a 1))
+           (pattern-b (vector-ref rule-b 1)))
+      (more-general-pattern-than? pattern-a pattern-b))))
+
+(define sort-compound-rule
+  (lambda (compound-rule)
+    (mergesort compound-rule more-general-rule-than?)))
+
+;
+; Returns a list like: ((ast: . 1) (stab: . 2) (out: . 3))
+; so that we can access a term's position in the vector given its name
+;
+(define form-term-map
+  (lambda (named-terms-depic n acc)
+    (cond ((null? named-terms-depic)
+            (reverse acc))
+          (else
+            (let* ((named-term-depic (car named-terms-depic))
+                   (name             (car named-term-depic))
+                   (pair             (cons name n))
+                   (new-acc          (cons pair acc)))
+              (form-term-map (cdr named-terms-depic) (+ n 1) new-acc))))))
+
+(define preprocess-named-terms
+  (lambda (named-terms-depic acc)
+    (cond ((null? named-terms-depic)
+            (list->vector (reverse acc)))
+          (else
+            (let* ((named-term-depic (car named-terms-depic))
+                   (term             (cadr named-term-depic))
+                   (new-acc          (cons term acc)))
+              (preprocess-named-terms (cdr named-terms-depic) new-acc))))))
+
+;
+; ((ast: foo => bar) (stab: bee => hive))
+;
+(define preprocess-compound-rule
+  (lambda (compound-rule-depic term-map acc)
+    (cond ((null? compound-rule-depic)
+            (reverse acc))
+          (else
+            (let* ((rule-depic       (car compound-rule-depic))
+                   (rule-term-name   (car rule-depic))
+                   (rule-term-index  (cdr (assq rule-term-name term-map)))
+                   (rule-pattern     (cadr rule-depic))
+                   (rule-replacement (cadddr rule-depic))
+                   (rule             (vector rule-term-index rule-pattern rule-replacement))
+                   (new-acc          (cons rule acc)))
+              (preprocess-compound-rule (cdr compound-rule-depic) term-map new-acc))))))
+
+(define preprocess-compound-rules
+  (lambda (compound-rules-depic term-map acc)
+    (cond ((null? compound-rules-depic)
+            (reverse acc))
+          (else
+            (let* ((compound-rule-depic  (car compound-rules-depic))
+                   (compound-rule        (preprocess-compound-rule compound-rule-depic term-map '()))
+                   (sorted-compound-rule (sort-compound-rule compound-rule))
+                   (new-acc              (cons sorted-compound-rule acc)))
+              (preprocess-compound-rules (cdr compound-rules-depic) term-map new-acc))))))
+
+(define preprocess
+  (lambda (depic)
+    (let* ((named-terms-depic    (car depic))
+           (compound-rules-depic (cadr depic))
+           (term-map             (form-term-map named-terms-depic 0 '()))
+           (term-vector          (preprocess-named-terms named-terms-depic '()))
+           (compound-rules       (preprocess-compound-rules compound-rules-depic term-map '())))
+      (vector term-vector compound-rules))))
+;
+; Test suite for forest-rewriting project
+; Chris Pressey, sometime late January 2006
+;
+
+; Copyright (c)2008 Cat's Eye Technologies.  All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+;    notices, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+;    notices, this list of conditions, and the following disclaimer in
+;    the documentation and/or other materials provided with the
+;    distribution.
+; 3. Neither the names of the copyright holders nor the names of their
+;    contributors may be used to endorse or promote products derived
+;    from this software without specific prior written permission. 
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(load "utils.scm");--------------------------------------------------------
+
+(test 'split-1
+  (lambda ()
+    (split '(1 2 3 4 5 6 7 8) '() '()))
+  '((1 3 5 7) . (2 4 6 8))
+)
+
+(test 'split-2
+  (lambda ()
+    (split '(1 2 3 4 5 6 7) '() '()))
+  '((1 3 5 7) . (2 4 6))
+)
+
+(test 'merge-1
+  (lambda ()
+    (merge '(2 4 6 8) '(1 3 5 7) > '()))
+  '(1 2 3 4 5 6 7 8)
+)
+
+(test 'split-and-merge-1
+  (lambda ()
+    (let* ((pair (split '(1 2 3 4 5 6 7) '() '()))
+           (left (car pair))
+           (right (cdr pair)))
+      (merge left right > '())))
+  '(1 2 3 4 5 6 7)  
+)
+
+(test 'mergesort-1
+  (lambda ()
+    (mergesort '(8 26 4 78 13 65 12 91 64 2) >))
+  '(2 4 8 12 13 26 64 65 78 91)
+)
+
+(load "unify.scm");--------------------------------------------------------
+
+(test 'unify-1
+  (lambda ()
+    (unify
+      '(+ 1 2)
+      '(+ #(a) #(b))
+      '()
+    ))
+  '((b . 2) (a . 1))
+)
+
+(test 'unify-2
+  (lambda ()
+    (unify
+      '(+ 1 1)
+      '(+ #(a) #(a))
+      '()
+    ))
+  '((a . 1))
+)
+
+(test 'unify-3
+  (lambda ()
+    (unify
+      '(+ 1 2)
+      '(+ #(a) #(a))
+      '()
+    ))
+  #f
+)
+
+(test 'unify-4
+  (lambda ()
+    (unify
+      '(+ 1 1)
+      '(+ #(a) #(a))
+      '((a . 2))
+    ))
+  #f
+)
+
+(load "tree-rewrite.scm");--------------------------------------------------
+
+(test 'reduce-term-1
+  (lambda ()
+    (reduce-term
+      '(+ 6 (+ 3 3))
+      '(
+          ((+ #(A) #(A)) . (* #(A) 2))
+       )
+    ))
+  '(+ 6 (* 3 2))
+)
+
+(test 'reduce-term-2
+  (lambda ()
+    (reduce-term
+      '(+ (const 9) (* (const 2) (const 3)))
+      '(
+           ((const #(a))                  . (push #(a) _)                    )
+           ((+ #(l) #(r))                 . (then (then #(l) #(r)) (add _))  )
+           ((* #(l) #(r))                 . (then (then #(l) #(r)) (mul _))  )
+           ((then _ #(c))                 . #(c)                             )
+           ((then (#(op) #(a)) #(b))      . (#(op) (then #(a) #(b)))         )
+           ((then (#(op) #(k) #(a)) #(b)) . (#(op) #(k) (then #(a) #(b)))    )
+       )
+    ))
+  '(push 9 (push 2 (push 3 (mul (add _)))))
+)
+
+(test 'reduce-term-3
+  (lambda ()
+    (reduce-term
+      '(+ (const 9)
+         (if (> (const 3) (const 2))
+                (* (const 2) (const 3))
+                (const 1)))
+      '(
+           ((const #(a))                  . (push #(a) _)                   )
+           ((+ #(l) #(r))                 . (then (then #(l) #(r)) (add _)) )
+           ((* #(l) #(r))                 . (then (then #(l) #(r)) (mul _)) )
+           ((> #(l) #(r))                 . (then (then #(l) #(r)) (gt _))  )
+
+           ((if #(q) #(t) #(f))           .
+                  (then #(q) (jfalse label:
+                  (then #(t) (jmp end:
+                             (label label:
+                  (then #(f) (label end: _)))))))                           )
+
+           ((gt (jfalse #(l) #(rest)))    . (jle #(l) #(rest))              )
+
+           ((then _ #(c))                 . #(c)                            )
+           ((then (#(op) #(a)) #(b))      . (#(op) (then #(a) #(b)))        )
+           ((then (#(op) #(k) #(a)) #(b)) . (#(op) #(k) (then #(a) #(b)))   )
+       )
+    ))
+  '(push 9 (push 3 (push 2 (jle label: (push 2 (push 3 (mul (jmp end:
+     (label label: (push 1 (label end: (add _))))))))))))
+)
+
+(load "preprocess.scm");---------------------------------------------------
+
+(test 'preprocess-1
+  (lambda ()
+    (preprocess
+      '(
+         (                                            ; list of named terms
+           (ast:   (const a 4 (+ 3 (* a 3))))         ; a named term
+           (stab:  eot)
+           (out:   halt)
+         )
+         (                                            ; list of compound-rules
+           ((ast: foo => bar) (stab: bee => hive))    ; a compound-rule
+         )
+       )
+    ))
+   '#(
+       #((const a 4 (+ 3 (* a 3))) eot halt)
+        ((#(0 foo bar) #(1 bee hive)))
+     )
+)
+
+(load "forest-rewrite.scm");--------------------------------------------------
+
+(test 'rewrite-tree-1
+  (lambda ()
+    (rewrite-forest (preprocess
+      '(
+         (
+           (ast:   (+ (const 9) (* (const 2) (const 3))))
+         )
+         (
+           ((ast: (const #(a))                  => (push #(a) _)                     ))
+           ((ast: (+ #(l) #(r))                 => (then (then #(l) #(r)) (add _))   ))
+           ((ast: (* #(l) #(r))                 => (then (then #(l) #(r)) (mul _))   ))
+           ((ast: (then _ #(c))                 => #(c)                              ))
+           ((ast: (then (#(op) #(a)) #(b))      => (#(op) (then #(a) #(b)))          ))
+           ((ast: (then (#(op) #(k) #(a)) #(b)) => (#(op) #(k) (then #(a) #(b)))     ))
+         )
+       )
+    )))
+  '#((push 9 (push 2 (push 3 (mul (add _))))))
+)
+
+(test 'rewrite-tree-2
+  (lambda ()
+    (rewrite-forest (preprocess
+      '(
+         (
+           (ast:   (+ (const 9)
+                      (if (> (const 3) (const 2))
+                          (* (const 2) (const 3))
+                          (const 1)))
+           )
+         )
+         (
+           ((ast: (const #(a))                  => (push #(a) _)                     ))
+           ((ast: (+ #(l) #(r))                 => (then (then #(l) #(r)) (add _))   ))
+           ((ast: (* #(l) #(r))                 => (then (then #(l) #(r)) (mul _))   ))
+           ((ast: (> #(l) #(r))                 => (then (then #(l) #(r)) (gt _))    ))
+
+           ((ast: (if #(q) #(t) #(f))           =>
+                  (then #(q) (jfalse label: (then #(t) (jmp end: (label label: (then #(f) (label end: _)))))))  ))
+
+           ((ast: (gt (jfalse #(l) #(rest)))    => (jle #(l) #(rest))                ))
+
+           ((ast: (then _ #(c))                 => #(c)                              ))
+           ((ast: (then (#(op) #(a)) #(b))      => (#(op) (then #(a) #(b)))          ))
+           ((ast: (then (#(op) #(k) #(a)) #(b)) => (#(op) #(k) (then #(a) #(b)))     ))
+         )
+       )
+    )))
+  '#((push 9 (push 3 (push 2 (jle label: (push 2 (push 3 (mul (jmp end:
+     (label label: (push 1 (label end: (add _)))))))))))))
+)
+
+;-------------------------------------------------------------------
+
+(test 'rewrite-forest-1
+  (lambda ()
+    (rewrite-forest (preprocess
+      '(
+         (
+           (ast:   (+ 3 (* 2 3)))
+           (out:   halt)
+         )
+         (
+           ((ast: #(a num) => _) (out: halt => (push #(a) halt)))
+           ((ast: (+ _ _) => _)  (out: halt => (add halt)))
+           ((ast: (* _ _) => _)  (out: halt => (mul halt)))
+         )
+       )
+    )))
+  '#(_ (push 3 (push 2 (push 3 (mul (add halt))))))
+)
+
+(test 'rewrite-forest-2
+  (lambda ()
+    (rewrite-forest (preprocess
+      '(
+         (
+           (stab:  (a 4 eot))
+           (ast:   (+ 1 2 3 a 5 6 a 7 8 9))
+         )
+         (
+           ( (stab: (#(n) #(v) #(tab))            => (#(n) #(v) #(tab)) )
+             (ast:  #(n sym)                      => #(v)               ) )
+         )
+       )
+    )))
+  '#((a 4 eot) (+ 1 2 3 4 5 6 4 7 8 9))
+)
+
+(test 'rewrite-forest-3
+  (lambda ()
+    (rewrite-forest (preprocess
+      '(
+         (
+           (ast:   (let a 4 (+ 3 (* a 3))) )
+           (stab:  eot)
+           (out:   halt)
+         )
+         (
+           ((ast:  (let #(n sym) #(v) #(expr)) => #(expr)            )
+            (stab: eot                         => (#(n) #(v) EOT)    ))
+           ((ast:  #(n sym)                    => #(v)               )
+            (stab: (#(n) #(v) #(tab))          => (#(n) #(v) #(tab)) ))
+           ((ast: #(a num)                     => _                  )
+            (out: halt                         => (push #(a) halt)   ))
+           ((ast: (+ _ _)                      => _                  )
+            (out: halt                         => (add halt)         ))
+           ((ast: (* _ _)                      => _                  )
+            (out: halt                         => (mul halt)         ))
+         )
+       )
+    )))
+  '#(_ (a 4 eot) (push 3 (push 4 (push 3 (mul (add halt))))))
+)
+
+;(test 'rewrite-forest-4
+;  (lambda ()
+;    (rewrite-forest (preprocess
+;      '(
+;         (
+;           (ast:   (if (> 6 4) (print 1) (print 2)) )
+;          (bpt:   eot)
+;           (out:   halt)
+;         )
+;         (
+;           ((ast: (> _ _)                      => _                  )
+;           (out: halt                         => (gt halt)          ))
+;          ((ast: (print _)                    => _                  )
+;           (out: halt                         => (print halt)       ))
+;           ((ast: #(a num)                     => _                  )
+;           (out: halt                         => (push #(a) halt)   ))
+;           ((ast:  (if _ #(t) #(p))            => (hmm #(t) #(p))    )
+;           (out: halt                         => (test halt)        ))
+;         )
+;       )
+;    )))
+;  '#(_ (a 4 eot) (push 3 (push 4 (push 3 (mul (add halt))))))
+;)
+

src/tree-rewrite.scm

+;
+; Bottom-Up Tree-Rewriting (Term-Rewriting)
+; Chris Pressey, sometime late January 2006
+;
+
+; Copyright (c)2008 Cat's Eye Technologies.  All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+;    notices, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+;    notices, this list of conditions, and the following disclaimer in
+;    the documentation and/or other materials provided with the
+;    distribution.
+; 3. Neither the names of the copyright holders nor the names of their
+;    contributors may be used to endorse or promote products derived
+;    from this software without specific prior written permission. 
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+;
+; Try unifying the pattern part of the given rule with the given term;
+; if it matches, return a rewritten term based on the unifier and the
+; replacement part of the rule; otherwise return #f.
+;
+(define rewrite-single-term
+  (lambda (term rules)
+    (cond
+      ((null? rules)
+        #f)
+      (else
+        (let* ((rule        (car rules))
+               (pattern     (car rule))
+               (replacement (cdr rule))
+               (unifier     (unify term pattern '())))
+          (cond
+            (unifier
+              (expand-vars replacement unifier))
+            (else
+              (rewrite-single-term term (cdr rules)))))))))
+
+;
+; Rewrite the given term recursively, with the given set of rules,
+; from the bottom up (preorder traversal.)  Returns the rewritten
+; term if successful, #f if not.  rules is a list of pat-repl pairs.
+;
+(define rewrite-bottom-up
+  (lambda (term rules)
+    (cond
+      ((list? term)
+        (let loop ((subterms term)    ; first try to unify with each child
+                   (acc      '()))    ; keep track of subterms we've seen
+          (cond
+            ((null? subterms)         ; no more children, try rewrite.
+              (rewrite-single-term term rules))
+            (else
+              (let* ((subterm     (car subterms))
+                     (rest        (cdr subterms))
+                     (new-subterm (rewrite-bottom-up subterm rules)))
+                (cond
+                  (new-subterm        ; this child succeeded. incorporate it
+                    (let* ((front        (reverse acc))
+                           (back         (cons new-subterm rest))
+                           (spliced-term (append front back)))
+                      spliced-term))
+                  (else               ; this child failed, try next one
+                    (loop (cdr subterms) (cons subterm acc)))))))))
+    (else
+      (rewrite-single-term term rules)))))
+
+;
+; Repeatedly rewrite the given term with the given rules until it
+; is reduced into a normal form (if one exists for these rules.)
+; Return the reduced term.
+;
+(define reduce-term
+  (lambda (term rules)
+    (let* ((new-term (rewrite-bottom-up term rules)))
+      (cond
+        (new-term
+          (reduce-term new-term rules))
+        (else
+          term)))))
+;
+; Simple support for unification & pattern matching
+; Chris Pressey, late January 2006
+;
+
+; Copyright (c)2008 Cat's Eye Technologies.  All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+;    notices, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+;    notices, this list of conditions, and the following disclaimer in
+;    the documentation and/or other materials provided with the
+;    distribution.
+; 3. Neither the names of the copyright holders nor the names of their
+;    contributors may be used to endorse or promote products derived
+;    from this software without specific prior written permission. 
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+;
+; Return #t if the given pattern is a variable, #f otherwise.
+;
+(define pattern-var?
+  (lambda (pattern)
+    (vector? pattern)))                                   ; just check that it is a vector
+
+;
+; Return the name of the given pattern variable.
+;
+(define get-pattern-var-name
+  (lambda (pattern-var)
+    (vector-ref pattern-var 0)))                          ; just return the 1st element of the vector
+
+;
+; Return the optional predicate associated with the given pattern
+; variable, which determines what kind of (Scheme) terms it can
+; unify with.  If no predicate is associated with the variable,
+; a dummy always-true predicate is returned.
+;
+(define get-pattern-var-pred
+  (lambda (pattern-var)
+    (cond ((< (vector-length pattern-var) 2)
+            (lambda (x) #t))
+          (else
+            (let ((term-type (vector-ref pattern-var 1)))
+              (cond ((eqv? term-type 'num)
+                      (lambda (x) (number? x)))
+                    ((eqv? term-type 'sym)
+                      (lambda (x) (symbol? x)))
+                    (else
+                      (lambda (x) #f))))))))
+
+;
+; Register that the named pattern variable should be associated with the given
+; term in the given unifier.  A new unifier containing the new variable-term
+; association will be returned if possible; if it is not possible (i.e. the
+; variable is already bound to a different term,) #f is returned.
+;
+(define bind-pattern-var
+  (lambda (term pattern unifier)
+    (let* ((var-name  (get-pattern-var-name pattern))
+           (var-pred? (get-pattern-var-pred pattern))
+           (pair      (assq var-name unifier)))
+       (cond
+         ((not (var-pred? term))
+           #f)
+         ((not (pair? pair))                    ; if it's not in unifier,
+           (cons (cons var-name term) unifier)) ; add it up front
+         ((eqv? (cdr pair) term) ; already bound to the given term: alright
+           unifier)
+         (else                   ; already bound to something else: not good
+           #f)))))
+
+;
+; Helper function.
+; Given a term and a pattern, where we know both are lists,
+; fold over both of them, unifying all the corresponding elements.
+;
+(define unify-lists
+  (lambda (term pattern unifier)
+    (cond ((and (null? term) (null? pattern))  ; end of both
+            unifier)
+          ((or (null? term) (null? pattern))   ; end of one but not the other
+            #f)
+          (else
+            (let ((new-unifier (unify (car term) (car pattern) unifier)))
+              (if new-unifier
+                (unify-lists (cdr term) (cdr pattern) new-unifier)
+                #f))))))
+
+;
+; Return #f if the term does not unify with the pattern,
+; or a list of substitutions if it does unify.
+;
+(define unify
+  (lambda (term pattern unifier)
+    (cond ((pattern-var? pattern)
+            (bind-pattern-var term pattern unifier))
+          ((and (list? term) (list? pattern))
+            (unify-lists term pattern unifier))
+          ((eqv? term pattern)
+            unifier)
+          (else
+            #f))))
+
+;
+; Given a pattern and a unifier (set of substitutions,) return a term
+; where all the variables in the pattern have been replaced by their
+; associated term in the unifier.
+;
+(define expand-vars
+  (lambda (pattern unifier)
+    (cond ((pattern-var? pattern)      ; variable - replace if in unifier
+            (let* ((pair (assq (get-pattern-var-name pattern) unifier)))
+              (cond ((pair? pair)
+                      (cdr pair))
+                    (else
+                      pattern))))
+          ((list? pattern)             ; list - recurse
+            (map (lambda (subpattern)
+                   (expand-vars subpattern unifier))
+                 pattern))
+          (else                        ; ground term - leave it alone.
+            pattern))))
+;
+; Utility functions used by forest-rewriting project
+; Chris Pressey, late January 2006
+;
+
+; Copyright (c)2008 Cat's Eye Technologies.  All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+;    notices, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+;    notices, this list of conditions, and the following disclaimer in
+;    the documentation and/or other materials provided with the
+;    distribution.
+; 3. Neither the names of the copyright holders nor the names of their
+;    contributors may be used to endorse or promote products derived
+;    from this software without specific prior written permission. 
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+;
+; Sort a list using mergesort.
+;
+(define mergesort
+  (lambda (lst gt-pred?)
+    (cond ((null? lst)
+            lst)
+          ((null? (cdr lst))
+            lst)
+          (else
+            (let* ((pair  (split lst '() '()))
+                   (left  (mergesort (car pair) gt-pred?))
+                   (right (mergesort (cdr pair) gt-pred?)))
+                (merge left right gt-pred? '()))))))
+
+;
+; Yield a pair of lists, each containing roughly half the
+; elements of the given list.
+;
+(define split
+  (lambda (lst acc1 acc2)
+    (cond
+      ((null? lst)
+        (cons (reverse acc1) (reverse acc2)))
+      ((null? (cdr lst))
+        (cons (reverse (append lst acc1)) (reverse acc2)))
+      (else
+        (let* ((left  (car lst))
+               (right (cadr lst))
+               (rest  (cddr lst)))
+          (split rest (cons left acc1) (cons right acc2)))))))
+
+;
+; Given two sorted lists, return a sorted list that contains
+; all of the elements from both lists.
+;
+(define merge
+  (lambda (list1 list2 gt-pred? acc)
+    (cond
+      ((and (null? list1) (null? list2))
+        (reverse acc))
+      ((null? list1)
+        (merge list1 (cdr list2) gt-pred? (cons (car list2) acc)))
+      ((null? list2)
+        (merge (cdr list1) list2 gt-pred? (cons (car list1) acc)))
+      ((gt-pred? (car list1) (car list2))
+        (merge list1 (cdr list2) gt-pred? (cons (car list2) acc)))
+      (else
+        (merge (cdr list1) list2 gt-pred? (cons (car list1) acc))))))
+
+;
+; Side-effect-free alternative to vector-set!
+;
+(define vector-store
+  (lambda (vec index item)
+    (let loop ((items (vector->list vec))
+               (index index)
+               (item  item)
+               (acc   '()))
+      (cond ((null? items)
+              (list->vector (reverse acc)))
+            ((zero? index)
+              (loop (cdr items) (- index 1) item (cons item acc)))
+            (else
+              (loop (cdr items) (- index 1) item (cons (car items) acc)))))))
+
+;
+; Debugging output.
+;
+(define print
+  (lambda list
+    (for-each display list)))
+
+(define println
+  (lambda list
+    (for-each display list)
+    (newline)))
+
+;
+; Testing framework.
+;
+(define test
+  (lambda (test-name proc expected)
+    (print "Running test: " test-name "... ")
+    (let ((result (proc)))
+      (cond
+        ((equal? result expected)
+          (println "passed."))
+        (else
+          (println "FAILED!")
+          (println "Expected: " expected)
+          (println "Actual:   " result))))))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.