--* From postmaster%watson.vnet.ibm.com@yktvmv.watson.ibm.com  Thu Jul 14 15:05:52 1994
--* Received: from yktvmv-ob.watson.ibm.com by asharp.watson.ibm.com (AIX 3.2/UCB 5.64/930311)
--*           id AA26275; Thu, 14 Jul 1994 15:05:52 -0400
--* Received: from watson.vnet.ibm.com by yktvmv.watson.ibm.com (IBM VM SMTP V2R3)
--*    with BSMTP id 5591; Thu, 14 Jul 94 15:05:54 EDT
--* Received: from YKTVMV by watson.vnet.ibm.com with "VAGENT.V1.0"
--*           id <A.JENKS.NOTE.VAGENT2.1655.Jul.14.15:05:51.-0400>
--*           for asbugs@watson; Thu, 14 Jul 94 15:05:54 -0400
--* Received: from YKTVMV by watson.vnet.ibm.com with "VAGENT.V1.0"
--*           id 1619; Thu, 14 Jul 1994 15:05:51 EDT
--* Received: from leonardo.watson.ibm.com by yktvmv.watson.ibm.com
--*    (IBM VM SMTP V2R3) with TCP; Thu, 14 Jul 94 15:05:36 EDT
--* Received: by leonardo.watson.ibm.com (AIX 3.2/UCB 5.64/920123)
--*           id AA25258; Thu, 14 Jul 1994 15:00:53 -0400
--* Date: Thu, 14 Jul 1994 15:00:53 -0400
--* From: jenks@leonardo.watson.ibm.com
--* X-External-Networks: yes
--* Message-Id: <9407141900.AA25258@leonardo.watson.ibm.com>
--* To: asbugs@watson.ibm.com
--* Subject: [5] segmentation violation in compiling "and" [/u/jenks/dimacs94/ex.pm/match.asbug][36-0]

--@ Fixed  by:  SSD   Thu Jul 28 16:42:42 EDT 1994 
--@ Tested by:  none 
--@ Summary:    Cannot reproduce the bug. When submitting a bug, please make sure that the submitted bug file is self-contained. 


#include "xxtree.as"

XS ==> Xtree String;
RR ==> RewriteRule String;
RS ==> Ruleset String;
PXS ==> Partial XS;
PRS==> Partial RS;
PRR ==> Partial RR;

PatternMatch: with {
        applyOnce: (RS, XS) -> XS;
                ++ applyOnce(rs, x) applies ruleset rs to x once: if for a
                ++ given rewrite rule L -> R  of rs, the pattern L matches
                ++ x or a subtree of x, that rewrite rule is applied to
                ++ x to produce a new value x' that is returned as the value.
                ++ Otherwise, the original expression x is returned.
        apply: (RS, XS) -> XS;
                ++ apply(rs, x) means "apply forever": ruleset rs is applied
                ++ to expression x; if a rule L -> R is applicable to x or
                ++ a subtree of x, then x or that subtree is rewritten
                ++ to produce a new tree x; this process is repeated until
                ++ an x is produced which can no longer be transformed by rs;
                ++ this final value of x is returned.
} == add {
        import from XS, RR, RS, PXS, PRS, PRR, String;

        applyOnce(rs: RS, e:XS): XS == rewrite(rs, copy e);

        apply(rs: RS, e: XS): XS == {
                e := copy e;
                while e ~= (e := rewrite(rs, e)) repeat ();
                e
        }

        local rewrite(rs: RS, e: XS): XS == {
                -- rewrite(x, rs) uses rewrites x using ruleset rs, or
                -- returns e if no rule in rs is applicable.
                (match := matchRuleset?(rs, e)) => match :: XS;
                e
        }

        local matchRuleset?(rs: RS, e: XS): PXS == {
                -- matchRuleset?(rs, x) returns x transformed by ruleset rs,
                -- or "failed" if no rule in rs is applicable to x.
                import from List XS;
                for rewriteRule in rs
                        while not (match := matchRule?(rewriteRule,e)) repeat ();
                match => replace!(e, match :: XS) :: PXS;
                leaf? e => failed;
                for x in branches e
                        while not (success := matchRuleset?(rs, x)) repeat();
                success
        }

        local matchRule?(r: RR, e: XS): PXS == {
                -- matchRule?(r, x) returns a substitution list if rule r matches x,
                -- or failed if rule r is not applicable to x.
                (subl := matchRuleExactly?(r.lhs, e, empty)) => {
                        print << r << " matches " << e << " with " << (subl :: RS) << newline;
                        substitute(subl::RS, r.rhs) :: PXS;
                }
                failed@PXS
        }

        local matchRuleExactly?(p: XS, s: XS, subl: RS): PRS == {
                (v := lookup(p, subl)) => {
                        s = (v :: RR).rhs => subl :: PRS;
                        failed@PRS
                }
                wildcard? p => insert!(rewriteRule(p, s), subl) :: PRS;
                s = p => subl :: PRS;
                node s = node p =>
                        matchRuleParts?(branches p, branches s, subl);
                failed
        }

        local matchRuleParts?(pl: List XS, sl: List XS, subl: RS): PRS == {
                empty? pl => {
                        empty? sl => subl :: PRS;
                        failed
                }
                (subl1 := matchRuleExactly?(pl.first, sl.first, subl)) =>
                        matchRuleParts?(pl.rest, sl.rest, subl1 :: RS);
                failed
        }

        local wildcard?(x: XS): Boolean == {false};
--                import from Character, String, SingleInteger;
--                leaf? x => {
--                        s := node x;
--                        #s = 1 => {letter? s.1 => true; false}
--                        false
--                }
--                false;
--        }

}