# match-compiler-g.pkg
# A pattern matching compiler.
# This is based on Pettersson's 13p 1992 paper
# ``A Term Pattern-Match Compiler Inspired by Finite Automata Theory''
# ftp://ftp.ida.liu.se/pub/labs/pelab/papers/cc92pmc.ps.gz
# Compiled by:
# src/lib/compiler/back/low/tools/match-compiler.lib### "Concern should drive us into action
### and not into depression. No man is
### free who cannot control himself."
###
### -- Pythagoras
stipulate
package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package spp = simple_prettyprinter; # simple_prettyprinter is from src/lib/prettyprint/simple/simple-prettyprinter.pkg #
sanity_check = TRUE;
debug = FALSE;
herein
# 2008-01-29 CrT: So far as I can tell, this generic is invoked only by
#
# src/lib/compiler/back/low/tools/match-compiler/match-gen-g.pkg #
# which in turn appears not to be used in the compiler mainline.
# Compiler mainline pattern-match compilation is handled by
#
# src/lib/compiler/back/top/translate/translate-deep-syntax-pattern-to-lambdacode.pkg #
# This version differs from the mainline by supporting guard expressions
# as implemented by nowhere.pkg -- see
#
# src/lib/compiler/back/low/tools/doc/nowhere.tex
# src/lib/compiler/back/low/tools/nowhere/README
#
generic package match_compiler_g (
# ================
#
package var: # A variable
api { Var;
compare: (Var, Var) -> Order;
to_string: Var -> String;
};
package con: # Sumtype constructors.
api {
Con;
compare: (Con, Con) -> Order;
to_string: Con -> String;
variants: Con -> { known: List( Con ), others: Bool };
arity: Con -> Int;
};
package lit: # literals
api {
Literal;
compare: (Literal, Literal) -> Order;
to_string: Literal -> String;
variants: Literal -> Null_Or { known: List( Literal ), others: Bool };
};
package act:
api { Action; # An action.
to_string: Action -> String;
free_vars: Action -> List( var::Var );
};
package gua: # A guard expression.
api { Guard;
to_string: Guard -> String;
compare: (Guard, Guard) -> Order;
logical_and: (Guard, Guard) -> Guard;
};
package exp:
api { Expression;
to_string: Expression -> String;
};
)
: (weak) Match_Compiler # Match_Compiler is from src/lib/compiler/back/low/tools/match-compiler/match-compiler.api {
i2s = int::to_string;
fun listify (l, s, r) list
=
l + list::fold_backward
( \\ (x, "") => x;
(x, y) => x + s + y;
end
)
""
list + r;
# paired_lists::all has the wrong semantics!
fun forall f ([], [] ) => TRUE;
forall f (x ! xs, y ! ys) => f (x, y) and forall f (xs, ys);
forall f _ => FALSE;
end;
Index = INT Int
| LABEL var::Var;
Path = PATH List( Index );
package index {
fun compare (INT i, INT j) => int::compare (i, j);
compare (LABEL i, LABEL j) => var::compare (i, j);
compare (INT _, LABEL _) => LESS;
compare (LABEL _, INT _) => GREATER;
end;
fun equal (x, y)
=
compare (x, y) == EQUAL;
fun to_string (INT i) => i2s i;
to_string (LABEL l) => var::to_string l;
end;
};
package path {
fun compare (PATH p1, PATH p2)
=
loop (p1, p2)
where
fun loop ([], []) => EQUAL;
loop([], _) => LESS;
loop(_, []) => GREATER;
loop (x ! xs, y ! ys)
=>
case (index::compare (x, y))
EQUAL => loop (xs, ys);
ord => ord;
esac;
end;
end;
fun equal (p1, p2)
=
compare (p1, p2) == EQUAL;
fun append (PATH p1, PATH p2)
=
PATH (p1@p2);
fun dot (PATH p, i)
=
PATH (p @ [i]);
fun to_string (PATH p)
=
"["
+
list::fold_backward
(\\ (i, "") => index::to_string i;
(i, s ) => index::to_string i + "." + s;
end
)
""
p
+
"]";
fun to_ident (PATH p)
=
"v_"
+
list::fold_backward
(\\ (i, "") => index::to_string i;
(i, s) => index::to_string i + "_" + s;
end
)
""
p;
package map
=
red_black_map_g ( # red_black_map_g is from src/lib/src/red-black-map-g.pkg Key = Path;
compare = compare;
);
};
Name = VAR var::Var
| PVAR Path;
package name {
fun to_string (VAR v) => var::to_string v;
to_string (PVAR p) => path::to_string p;
end;
fun compare (VAR x, VAR y) => var::compare (x, y);
compare (PVAR x, PVAR y) => path::compare (x, y);
compare (VAR _, PVAR _) => LESS;
compare (PVAR _, VAR _) => GREATER;
end;
fun equal (x, y)
=
compare (x, y) == EQUAL;
package set
=
red_black_set_g ( Key = Name; compare = compare;);
fun set_to_string s
=
"{ "
+
list::fold_backward
(\\ (v, "") => to_string v;
(v, s ) => to_string v + "." + s;
end)
""
(set::vals_list s)
+
" }";
};
package var_set
=
red_black_set_g (
Key = var::Var;
compare = var::compare;
);
package subst
=
red_black_map_g ( # red_black_map_g is from src/lib/src/red-black-map-g.pkg Key = var::Var;
compare = var::compare;
);
# red_black_map_g def in src/lib/src/red-black-map-g.pkg Subst = subst::Map( Name );
fun merge_subst (s1, s2)
=
subst::keyed_fold_backward
(\\ (k, v, s) = subst::set (s, k, v))
s1
s2;
# Internal rep of pattern after
# every variable has been renamed:
#
Pattern
= WILDCARD_PATTERN # wild card
| APPLY_PATTERN (Decon, List( Pattern )) # Constructor
| TUPLEPAT List( Pattern ) # tupling
| RECORD_PATTERN List ((var::Var, Pattern)) # record
| OR_PATTERN List ((Subst, Pattern)) # Disjunction
| ANDPAT List ((Subst, Pattern)) # conjunction
| NOTPAT (Subst, Pattern) # negation
| WHEREPAT (Pattern, Subst, gua::Guard) # guard
| NESTEDPAT (Pattern, Subst, Path, ((Int, exp::Expression)), Pattern)
| CONTPAT (var::Var, Pattern)
also
Decon = CON con::Con
| LIT lit::Literal
;
exception MATCH_COMPILER String;
fun error msg = raise exception MATCH_COMPILER msg;
fun bug msg = error ("bug: " + msg);
package con = con;
package action = act;
package literal = lit;
package guard = gua;
package expression = exp;
package variable = var;
package decon {
fun kind (CON _) => 0;
kind (LIT _) => 1;
end;
fun compare (CON x, CON y) => con::compare (x, y);
compare (LIT x, LIT y) => lit::compare (x, y);
compare ( x, y) => int::compare (kind x, kind y);
end;
fun to_string (CON c) => con::to_string c;
to_string (LIT l) => lit::to_string l;
end;
fun equal (x, y)
=
compare (x, y) == EQUAL;
# red_black_map_g is from src/lib/src/red-black-map-g.pkg package map = red_black_map_g ( Key = Decon; compare = compare;);
package set = red_black_set_g ( Key = Decon; compare = compare;);
};
package pattern {
#
fun sort_by_label l
=
lms::sort_list
#
(\\ ((x, _), (y, _)) = var::compare (x, y) == GREATER)
#
l;
fun to_string (WILDCARD_PATTERN) => "_";
to_string (APPLY_PATTERN (c,[])) => decon::to_string c;
to_string (APPLY_PATTERN (c, xs))
=>
decon::to_string c + listify("(", ", ", ")") (map to_string xs);
to_string (TUPLEPAT patterns)
=>
listify("(", ", ", ")") (map to_string patterns);
to_string (RECORD_PATTERN lps)
=>
listify
("{ ", ", ", " }")
(map (\\ (l, p) = var::to_string l + "=" + to_string p)
lps
);
to_string (OR_PATTERN ps) => listify("(", " | ", ")") (map to_string' ps);
to_string (ANDPAT ps) => listify("(", " and ", ")") (map to_string' ps);
to_string (NOTPAT p) => "not " + to_string' p;
to_string (WHEREPAT (p, _, g)) => to_string p + " where " + gua::to_string g;
to_string (NESTEDPAT (p, _, _, (_, e), p'))
=>
to_string p + " where " + exp::to_string e + " in " + to_string p';
to_string (CONTPAT (v, p)) => to_string p + " exception " + var::to_string v;
end
also
fun to_string'(subst, p)
=
to_string p;
};
Rule_Number = Int;
Dfa = DFA { stamp: Int, # Unique dfa stamp
free_vars: Ref( name::set::Set ), # Free variables
ref_count: Ref( Int ), # Reference count
generated: Ref( Bool ), # Has code been generated?
height: Ref( Int ), # Dag height
test: Test # Type of tests
}
also
Test
= CASE (Path, List ((Decon, List( Path ), Dfa)), Null_Or( Dfa )) # multiway
| WHERE (gua::Guard, Dfa, Dfa) # if test
| OK (Rule_Number, act::Action) # final dfa
| BIND (Subst, Dfa) # Apply subst
| LET (Path, ((Int, exp::Expression)), Dfa) # let
| SELECT (Path, List ((Path, Index)), Dfa) # projections
| CONT (var::Var, Dfa) # Bind fate
| FAIL # error dfa
also
Compiled_Dfa
=
ROOT { dfa: Dfa,
used: name::set::Set,
exhaustive: Bool,
redundant: int_list_set::Set
}
also
Matrix
=
MATRIX
{ rows: List( Row ),
paths: List( Path ) # path (per column)
}
withtype Row =
{ patterns: List( Pattern ),
guard: Null_Or( (Subst, gua::Guard) ),
nested: List( (Subst, Path, ((Int, exp::Expression)), Pattern)),
dfa: Dfa
}
also Compiled_Rule =
(Rule_Number, List( Pattern ), Null_Or( gua::Guard ), Subst, act::Action)
also Compiled_Pat = (Pattern, Subst);
# Utilities for dfas
#
package dfa {
itow = unt::from_int;
fun h (DFA { stamp, ... } )
=
itow stamp;
fun hash (DFA { stamp, test, ... } )
=
case test
#
FAIL => 0u0;
OK _ => 0u123 + itow stamp;
CASE (path, cases, default)
=>
0u1234
+
fold_backward
(\\ ((_, _, x), y) = h x + y)
case default THE x => h x; NULL => 0u0; esac
cases;
SELECT(_, _, dfa) => 0u2313 + hash dfa;
CONT(_, dfa) => 0u1234 + hash dfa;
WHERE (g, yes, no) => 0u2343 + h yes + h no;
BIND(_, dfa) => 0u23234 + h dfa;
LET(_, (i, _), dfa) => itow i + h dfa + 0u843;
esac;
# Pointer equality:
#
fun eq (DFA { stamp=>s1, ... }, DFA { stamp=>s2, ... } )
=
s1 == s2;
fun eq_opt (NULL, NULL) => TRUE;
eq_opt (THE x, THE y) => eq (x, y);
eq_opt _ => FALSE;
end;
# One-level equality:
#
fun equal ( DFA { test=>t1, stamp=>s1, ... },
DFA { test=>t2, stamp=>s2, ... }
)
=
case (t1, t2)
#
(FAIL, FAIL) => TRUE;
(OK _, OK _) => s1 == s2;
(SELECT (p1, b1, x), SELECT (p2, b2, y))
=>
path::equal (p1, p2)
and
eq (x, y)
and
forall
(\\ ((px, ix), (py, iy)) = path::equal (px, py) and index::equal (ix, iy))
(b1, b2);
(CONT (k1, x), CONT (k2, y))
=>
var::compare (k1, k2) == EQUAL and eq (x, y);
(CASE (p1, c1, o1), CASE (p2, c2, o2))
=>
path::equal (p1, p2)
and
forall
(\\ ((u, _, x), (v, _, y))
=
decon::equal (u, v) and eq (x, y)
)
(c1, c2)
and
eq_opt (o1, o2);
( WHERE (g1, y1, n1),
WHERE (g2, y2, n2)
)
=>
gua::compare (g1, g2) == EQUAL
and eq (y1, y2) and eq (n1, n2);
( BIND (s1, x),
BIND (s2, y)
)
=>
eq (x, y)
and
forall
(\\ ((p, x), (q, y))
=
var::compare (p, q) == EQUAL
and
name::equal (x, y)
)
( subst::keyvals_list s1,
subst::keyvals_list s2
);
(LET (p1, (i1, _), x), LET (p2, (i2, _), y))
=>
path::equal (p1, p2) and i1==i2 and eq (x, y);
_ => FALSE;
esac;
# typelocked_hashtable_g is from src/lib/src/typelocked-hashtable-g.pkg package hashtable
=
typelocked_hashtable_g (
Hash_Key = Dfa;
same_key = equal;
hash_value = hash;
);
fun to_string (ROOT { dfa, ... } )
=
{ exception NOT_VISITED;
visited = iht::make_hashtable { size_hint => 32, not_found_exception => NOT_VISITED };
fun mark stamp
=
iht::set visited (stamp, TRUE);
fun is_visited stamp
=
null_or::the_else (iht::find visited stamp, FALSE);
# include package spp;
++ = spp::CONS;
infix my ++ ;
fun pr_args []
=>
spp::NOP;
pr_args ps
=>
spp::LIST
{ leftbracket => spp::PUNCTUATION "(",
separator => spp::PUNCTUATION ", ",
rightbracket => spp::PUNCTUATION ")",
elements => map (spp::ALPHABETIC o path::to_string) ps
};
end;
fun walk (DFA { stamp, test=>FAIL, ... } )
=>
spp::ALPHABETIC "fail";
walk (DFA { stamp, test, ref_count=>REF n, ... } ) =>
if (is_visited stamp)
#
spp::ALPHABETIC "goto" ++ spp::INT stamp;
else
mark stamp;
spp::PUNCTUATION "<" ++ spp::INT stamp ++ spp::PUNCTUATION ">"
++
if (n > 1) spp::PUNCTUATION "*";
else spp::NOP;
fi
++
case test
#
OK(_, a) => spp::ALPHABETIC "Ok" ++ spp::ALPHABETIC (act::to_string a);
FAIL => spp::ALPHABETIC "FAIL";
SELECT (root, namings, body)
=>
spp::INDENTED_LINE (spp::ALPHABETIC "Stipulate")
++
spp::INDENTED_BLOCK
(spp::LIST
{ leftbracket => spp::NOP,
separator => spp::NEWLINE,
rightbracket => spp::NOP,
elements => (map (\\ (p, i)
=
spp::INDENT ++
spp::ALPHABETIC (path::to_string p) ++ spp::ALPHABETIC "=" ++
spp::ALPHABETIC (path::to_string root) ++ spp::ALPHABETIC "." ++
spp::ALPHABETIC (index::to_string i)
)
namings
)
}
)
++
spp::INDENTED_LINE (spp::ALPHABETIC "in")
++
spp::INDENTED_BLOCK (walk body);
CONT (k, x)
=>
spp::INDENTED_LINE (spp::ALPHABETIC "Cont" ++ spp::ALPHABETIC (var::to_string k) ++ walk x);
CASE (p, cases, default)
=>
spp::INDENTED_LINE (spp::ALPHABETIC "Case" ++ spp::PUNCTUATION (path::to_string p))
++
spp::INDENTED_BLOCK
(spp::LIST
{ leftbracket => spp::NOP,
separator => spp::NEWLINE,
rightbracket => spp::NOP,
elements => ( (map (\\ (decon, args, dfa)
=
spp::INDENT ++ spp::ALPHABETIC (decon::to_string decon) ++ pr_args args
++ spp::ALPHABETIC "=>" ++ spp::MAYBE_BLANK ++ walk dfa
)
cases
)
@
case default
#
NULL => [];
THE dfa => [spp::ALPHABETIC "_" ++ spp::ALPHABETIC "=>" ++ spp::MAYBE_BLANK ++ walk dfa];
esac
)
}
);
WHERE (g, y, n)
=>
spp::INDENTED_LINE (spp::ALPHABETIC "If" ++ spp::ALPHABETIC (gua::to_string g))
++
spp::INDENTED_BLOCK ( spp::INDENT ++ spp::ALPHABETIC "then" ++ walk y ++ spp::NEWLINE
++
spp::INDENT ++ spp::ALPHABETIC "else" ++ walk n
);
BIND (subst, x)
=>
spp::INDENTED_LINE (subst::keyed_fold_backward
(\\ (v, n, prettyprint)
=
spp::INDENT ++ spp::ALPHABETIC (var::to_string v) ++ spp::PUNCTUATION "<-"
++
spp::ALPHABETIC (name::to_string n) ++ prettyprint
)
spp::NOP
subst
) ++
walk x;
LET (path, ( _, e), x)
=>
spp::INDENTED_LINE ( spp::ALPHABETIC "Stipulate"
++ spp::ALPHABETIC (path::to_string path)
++ spp::ALPHABETIC "="
++ spp::ALPHABETIC (exp::to_string e)
)
++
spp::INDENTED_BLOCK (walk x);
esac;
fi;
end; # fun walk
spp::prettyprint_expression_to_string (walk dfa ++ spp::NEWLINE);
};
};
# Utilities for the pattern matrix
#
package matrix {
fun row (MATRIX { rows, ... }, i)
=
list::nth (rows, i);
fun col (MATRIX { rows, ... }, i)
=
list::map
(\\ { patterns, ... } = list::nth (patterns, i))
rows;
fun path_of (MATRIX { paths, ... }, i)
=
list::nth (paths, i);
fun column_count m
=
list::length ((row (m, 0)).patterns);
fun is_empty (MATRIX { rows => [], ... } )
=>
TRUE;
is_empty _
=>
FALSE;
end;
fun remove_first_row (MATRIX { rows=>_ ! rows, paths } )
=>
MATRIX { rows, paths };
remove_first_row _
=>
error "removeFirstRow";
end;
fun check (MATRIX { rows, paths, ... } )
=
{ arity = length paths;
apply
(\\ { patterns, ... }
=
if (length patterns != arity) bug "bad matrix"; fi)
rows;
};
fun to_string (MATRIX { rows, paths, ... } )
=
listify
("", "\n", "\n")
(map
(\\ { patterns, ... }
=
listify
("[", "\t", "]")
(map pattern::to_string patterns))
rows
);
# Given a matrix, find the best column for matching.
#
# I'm using the heuristic that John (Reppy) uses:
# the first column i where pat_i0 is not a wild card, and
# with the maximum number of distinct constructors in the
# the column.
#
# If the first row is all wild card, then return NULL.
fun find_best_match_column (m as MATRIX { rows, ... } )
=
{ if sanity_check check m; fi;
if debug print (to_string m); fi;
n_col = column_count m;
fun score i # Score of doing pattern matching on column i
=
{ patterns_i = col (m, i);
patterns_i0 = head patterns_i;
case patterns_i0
#
WILDCARD_PATTERN => 0;
_ =>
{ my (cons, score)
=
# Count distinct constructors; skip refutable cards.
# Give records, tuples and or patterns, high scores
# so that they are immediately expanded
list::fold_backward
\\ (WILDCARD_PATTERN, (sss, n))
=>
(sss, n);
(APPLY_PATTERN (c, _), (sss, n))
=>
(decon::set::add (sss, c), n);
(_, (sss, n))
=>
(sss, 10000);
end
(decon::set::empty, 0)
patterns_i;
score + decon::set::vals_count cons;
};
esac;
};
# Find column with the highest score:
#
fun find_best (i, best_so_far)
=
if (i >= n_col)
#
best_so_far;
else
score_i = score i;
best = if case best_so_far
NULL => TRUE;
THE (_, best_score) => score_i > best_score;
esac
THE (i, score_i);
else
best_so_far;
fi;
find_best (i+1, best);
fi;
case (find_best (0, NULL))
#
THE (i, 0) => NULL; # A score of zero means all wildcards
THE (i, _) => THE i;
NULL => NULL;
esac;
}; # fun find_best_match_column
}; # package matrix
to_string = dfa::to_string;
# Rename user pattern into internal pattern.
# The path business is hidden from the client.
#
fun rename do_it
{ number => rule_no,
patterns,
guard,
action,
match_fail_exception # Currently ignored. I think intended to allow end-user selection of exception generated on match failure. -- 2011-04-23 CrT
}
=
{ empty = subst::empty;
fun bind (subst, v, p)
=
case (subst::get (subst, v))
#
NULL => subst::set (subst, v, PVAR p);
THE _ => error("duplicated pattern variable " + var::to_string v);
esac;
fun process (path, subst: Subst, pattern) : Compiled_Pat
=
{ fun id_pattern id
=
(WILDCARD_PATTERN, bind (subst, id, path));
fun as_pattern (id, p)
=
{ my (p, subst)
=
process (path, subst, p);
(p, bind (subst, id, path));
};
fun wild_pattern ()
=
(WILDCARD_PATTERN, subst);
fun lit_pattern lit
=
(APPLY_PATTERN (LIT lit, []), subst);
fun process_patterns patterns
=
loop (patterns, 0, [], subst)
where
fun loop ([], _, ps', subst)
=>
(reverse ps', subst);
loop (p ! ps, i, ps', subst)
=>
{ path' = path::dot (path, INT i);
my (p, subst)
=
process (path', subst, p);
loop (ps, i+1, p ! ps', subst);
};
end;
end;
fun process_lpatterns (lpatterns)
=
loop (lpatterns, [], subst)
where
fun loop ([], ps', subst)
=>
(reverse ps', subst);
loop((l, p) ! ps, ps', subst)
=>
{ path' = path::dot (path, LABEL l);
my (p, subst)
=
process (path', subst, p);
loop (ps, (l, p) ! ps', subst);
};
end;
end;
fun cons_pattern (c, args): Compiled_Pat
=
{ my (patterns, subst)
=
process_patterns (args);
# Arity check:
#
if (con::arity c != length args )
#
error ("arity mismatch " + con::to_string c);
fi;
(APPLY_PATTERN (CON c, patterns), subst);
};
fun tuple_pattern (patterns): Compiled_Pat
=
{ my (patterns, subst) = process_patterns (patterns);
#
(TUPLEPAT patterns, subst);
};
fun record_pattern (lpatterns): Compiled_Pat
=
{ my (lpatterns, subst) = process_lpatterns (lpatterns);
#
(RECORD_PATTERN lpatterns, subst);
};
fun no_dupl (subst, subst')
=
{ duplicated
=
var_set::vals_list (
#
var_set::intersection (
#
var_set::add_list (var_set::empty, subst::keys_list subst'),
var_set::add_list (var_set::empty, subst::keys_list subst )
)
);
case duplicated
#
[] => ();
_ => error ("duplicated pattern variables: " + listify("", ", ", "") (map var::to_string duplicated));
esac;
};
# Or patterns are tricky because the same variable name
# may be bound to different components. We handle this by renaming
# all variables to some canonical set of paths,
# then rename all variables to these paths.
#
fun logical_pattern (name, name2, f) []
=>
error("empty " + name + " pattern");
logical_pattern (name, name2, f) patterns
=>
{ results = map (\\ p => process (path, empty, p); end ) patterns;
ps = map #1 results;
or_substs = map #2 results;
fun same_vars ([], s')
=>
TRUE;
same_vars (s ! ss, s')
=>
forall
(\\ (x, y) = var::compare (x, y) == EQUAL)
(subst::keys_list s, s')
and
same_vars (ss, s');
end;
# Make sure all patterns use
# the same set of variable names:
or_names = subst::keys_list (head or_substs);
if (not (same_vars (tail or_substs, or_names)))
error("not all " + name2 + " have the same variable namings");
fi;
no_dupl (subst, head or_substs);
# Build the new substitution to
# include all names in the or
# patterns.
subst = subst::keyed_fold_backward
(\\ (v, _, subst) = subst::set (subst, v, VAR v))
subst
(head or_substs);
(f (paired_lists::zip (or_substs, ps)), subst);
};
end;
fun or_pattern patterns = logical_pattern ("or", "disjuncts", OR_PATTERN) patterns;
fun and_pattern patterns = logical_pattern ("and", "conjuncts", ANDPAT) patterns;
fun not_pattern pattern
=
{ my (pattern, subst') = process (path, empty, pattern);
no_dupl (subst, subst');
(NOTPAT (subst', pattern), subst);
};
fun where_pattern (pattern, e)
=
{ my (pattern, subst') = process (path, empty, pattern);
no_dupl (subst, subst');
(WHEREPAT (pattern, subst', e), subst);
};
fun nested_pattern (pattern1, e, pattern2)
=
{ path' = path::dot (path, INT -1);
my (pattern1, subst1) = process (path, subst, pattern1);
my (pattern2, subst2) = process (path', subst1, pattern2);
(NESTEDPAT (pattern1, subst1, path', e, pattern2), subst2);
};
do_it { id_pattern,
as_pattern,
wild_pattern,
cons_pattern,
tuple_pattern,
record_pattern,
lit_pattern,
or_pattern,
and_pattern,
not_pattern,
where_pattern,
nested_pattern
} pattern;
}; # fun process
fun process_all_patterns (i, [], subst, ps')
=>
(reverse ps', subst);
process_all_patterns (i, p ! ps, subst, ps')
=>
{ my (p, subst) = process (PATH [INT i], subst, p);
process_all_patterns (i+1, ps, subst, p ! ps');
};
end;
(process_all_patterns (0, patterns, empty, []))
->
(patterns, subst);
(rule_no, patterns, guard, subst, action);
};
package dfamap
=
red_black_map_g ( # red_black_map_g is from src/lib/src/red-black-map-g.pkg Key = Dfa;
fun st (DFA { stamp, ... } ) = stamp;
fun compare (x, y) = int::compare (st x, st y);
);
# Give the arguments to case,
# factor out the common case
# and make it the default.
#
fun factor_case (p, cases, d as THE _)
=>
(p, cases, d);
factor_case (p, cases, NULL)
=>
{ fun count (m, dfa)
=
the_else (dfamap::get (m, dfa), 0);
fun inc ((_, _, dfa), m)
=
dfamap::set (m, dfa, 1 + count (m, dfa));
m = fold_backward inc dfamap::empty cases;
best
=
dfamap::keyed_fold_backward
\\ (dfa, c, NULL)
=>
THE (dfa, c);
(dfa, c, best as THE(_, c'))
=>
if (c > c') THE (dfa, c);
else best;
fi;
end
NULL
m;
fun neq (DFA { stamp=>x, ... }, DFA { stamp=>y, ... } )
=
x != y;
case best
NULL => (p, cases, NULL);
THE (_, 1) => (p, cases, NULL);
THE (default_case, n)
=>
{ others
=
list::filter
(\\ (_, _, x) = neq (x, default_case))
cases;
(p, others, THE default_case);
};
esac;
};
end; # fun factor_case
# The main pattern matching compiler.
# The dfa states are constructed with hash consing at the same time
# so no separate DFA minimization step is needed.
#
fun compile { compiled_rules, compress }
=
{ exception NO_SUCH_STATE;
Expand_Type
= SWITCH (List ((Decon, List( Path ), Matrix)), Null_Or( Matrix ))
| PROJECT (Path, List ((Path, Index)), Matrix);
fun simp x
=
if compress factor_case x;
else x;
fi;
# Table for hash consing:
#
dfa_table = dfa::hashtable::make_hashtable { size_hint => 32, not_found_exception => NO_SUCH_STATE }
: dfa::hashtable::Hashtable( Dfa );
lookup_state
=
dfa::hashtable::get dfa_table;
insert_state
=
dfa::hashtable::set dfa_table;
stamp_counter = REF 0;
fun mk_state (test)
=
{ stamp = *stamp_counter;
stamp_counter := stamp + 1;
DFA { stamp, free_vars=>REF name::set::empty,
height=>REF 0, ref_count=>REF 0, generated=>REF FALSE, test
};
};
fun new_state test
=
{ s = mk_state (test);
lookup_state s
except
NO_SUCH_STATE = { insert_state (s, s);
s;
};
};
# State constructors
fail = new_state (FAIL);
fun ok x
=
new_state (OK x);
fun case'(_, [], THE x) => x;
case'(_, [], NULL) => fail;
case' (p, cases as (_, _, c) ! cs, default)
=>
if ( list::all
(\\ (_, _, c') = dfa::eq (c, c'))
cs
and
case default
#
THE x => dfa::eq (c, x);
NULL => TRUE;
esac
)
c;
else
new_state (CASE (simp (p, cases, default)));
fi;
end;
fun select (x) = new_state (SELECT (x));
fun cont (x) = new_state (CONT (x));
fun where' (g, yes, no)
=
if (dfa::eq (yes, no))
yes;
else
new_state (WHERE (g, yes, no));
fi;
fun bind (subst, x)
=
subst::vals_count subst == 0
?? x
:: new_state (BIND (subst, x));
fun let' x
=
new_state (LET x);
# Expand column i,
# Return a new list of matrixes indexed by the deconstructors.
fun expand_column (m as MATRIX { rows, paths, ... }, i)
=
{ ith_col = matrix::col (m, i);
path_i = matrix::path_of (m, i);
if debug
print ("Expanding column " + i2s i + "\n");
fi;
fun split_i ps
=
loop (0, ps, [])
where
fun loop (j, p ! ps, ps')
=>
if (i == j)
#
(reverse ps', p, ps);
else
loop (j+1, ps, p ! ps');
fi;
loop _
=>
bug "split_i";
end;
end;
# If the ith column cfind out what to expand
#
fun expand ((p as OR_PATTERN _) ! ps, this) => THE p;
expand ((p as ANDPAT _) ! ps, this) => THE p;
expand ((p as NOTPAT _) ! ps, this) => THE p;
expand ((p as WHEREPAT _) ! ps, this) => THE p;
expand ((p as NESTEDPAT _) ! ps, this) => THE p;
expand ((p as CONTPAT _) ! ps, this) => THE p;
expand ((p as TUPLEPAT _) ! ps, this) => expand (ps, THE p);
expand ((p as RECORD_PATTERN _) ! ps, this) => expand (ps, THE p);
expand ((p as APPLY_PATTERN _) ! ps, this) => expand (ps, THE p);
expand (WILDCARD_PATTERN ! ps, this) => expand (ps, this);
expand([], this) => this;
end;
# Split the paths:
#
my (prev_paths, _, next_paths)
=
split_i paths;
case (expand (ith_col, NULL))
#
THE (NOTPAT _) # Expand not patterns.
=>
expand (rows, [])
where
fun expand ([], _)
=>
bug "expand NOT";
expand ((row as { patterns, guard, nested, dfa } ) ! rows, rows')
=>
{ my (prev, pat_i, next)
=
split_i patterns;
case pat_i
NOTPAT (subst, p)
=>
{ rows' = reverse rows';
yes = { patterns => prev @ [WILDCARD_PATTERN] @ next,
nested,
guard,
dfa
};
m2 = MATRIX { rows, paths };
no = { patterns => prev @ [p] @ next,
guard => NULL,
nested => [],
dfa => bind (subst, match m2)
};
m1 = MATRIX { rows => rows' @ [no, yes] @ rows,
paths
};
expand_column (m1, i);
};
_ => expand (rows, row ! rows');
esac;
};
end; # fun expand
end; # THE (NOTPAT _)
THE (OR_PATTERN _ | WHEREPAT _ | NESTEDPAT _)
=>
# If we have or/where patterns then expand all rows
# with these patterns
#
{ fun expand (row as { patterns, dfa, nested, guard } )
=
{ my (prev, pat_i, next)
=
split_i patterns;
case pat_i
#
OR_PATTERN ps
=>
map
(\\ (subst, p)
=
{ patterns => prev @ [p] @ next,
dfa => bind (subst, dfa),
nested,
guard
}
)
ps;
WHEREPAT (p, subst', g)
=>
[ { patterns => prev @ [p] @ next,
dfa,
nested,
guard => case guard
NULL
=>
THE (subst', g);
THE (subst, g')
=>
THE ( merge_subst (subst, subst'),
gua::logical_and (g, g')
);
esac
}
];
NESTEDPAT (pattern, subst, path, expression, pattern')
=>
[ { patterns => prev @ [pattern] @ next,
dfa,
nested => (subst, path, expression, pattern') ! nested,
guard
}
];
_ => [row];
esac;
}; # fun expand
new_matrix
=
MATRIX { rows => list::cat (map expand rows),
paths
};
expand_column (new_matrix, i);
}; # THE (OR_PATTERN _ | WHEREPAT _ | NESTEDPAT _)
THE (TUPLEPAT patterns) # expand a tuple along all the columns
=>
{ arity = length patterns;
wilds = map
(\\ _ = WILDCARD_PATTERN)
patterns;
fun process_row { patterns, nested, dfa, guard }
=
{ my (prev, pat_i, next)
=
split_i patterns;
case pat_i
#
TUPLEPAT ps'
=>
{ n = length ps';
if (n != arity)
error ("tuple arity mismatch");
fi;
{ patterns => prev @ ps' @ next,
nested,
dfa,
guard
};
};
WILDCARD_PATTERN
=>
{ patterns=>prev @ wilds @ next,
nested,
dfa,
guard
};
pattern
=>
error ("mixing tuple and: " + pattern::to_string pattern);
esac;
};
rows = map process_row rows;
path_i' = list::from_fn (
arity,
\\ i = path::dot (path_i, INT i)
);
paths = prev_paths @ path_i' @ next_paths;
namings = list::from_fn (
arity,
\\ i = (path::dot (path_i, INT i), INT i)
);
PROJECT (
path_i,
namings,
MATRIX { rows, paths }
);
}; # THE (TUPLEPAT patterns)
THE (RECORD_PATTERN _) # expand a tuple along all the columns
=>
{ # All the labels that are in this column:
#
labels =
var_set::vals_list (
#
list::fold_backward
#
\\ (RECORD_PATTERN lps, lll)
=>
list::fold_backward
(\\ ((l, p), lll) = var_set::add (lll, l))
lll
lps;
(_, lll)
=>
lll;
end
var_set::empty
ith_col
);
if debug
print("Labels=" + listify("", ", ", "")
(map var::to_string labels) + "\n");
fi;
fun lp2s (l, p)
=
var::to_string l + "=" + pattern::to_string p;
fun lps2s lps
=
listify ("", "\t", "") (map lp2s lps);
fun ps2s ps
=
listify ("", "\t", "") (map pattern::to_string ps);
wilds
=
map
(\\ _ = WILDCARD_PATTERN)
labels;
fun process_row { patterns, nested, dfa, guard }
=
{ my (prev, pat_i, next)
=
split_i (patterns);
case pat_i
#
RECORD_PATTERN lps
=>
# Put lps in canonical order
{ lps = pattern::sort_by_label lps;
debug ?: print ("lpatterns=" + lps2s lps + "\n");
fun collect ([], [], ps')
=>
reverse ps';
collect (x ! xs, [], ps')
=>
collect (xs, [], WILDCARD_PATTERN ! ps');
collect (x ! xs, this as (l, p) ! lps, ps')
=>
case (var::compare (x, l))
EQUAL => collect (xs, lps, p ! ps');
LESS => collect (xs, this, WILDCARD_PATTERN ! ps');
GREATER => error "labels out of order";
esac;
collect _
=>
bug "processRow";
end;
ps = collect (labels, lps, []);
debug ?: print("new patterns=" + ps2s ps + "\n");
{ patterns => prev @ ps @ next,
nested,
dfa,
guard
};
}; # RECORD_PATTERN lps
WILDCARD_PATTERN
=>
{ patterns => prev @ wilds @ next,
nested,
dfa,
guard
};
pattern
=>
error ("mixing record and: " + pattern::to_string pattern);
esac;
}; # fun process_row
rows = map process_row rows;
path_i'
=
map
(\\ l = path::dot (path_i, LABEL l))
labels;
paths = prev_paths
@ path_i'
@ next_paths;
namings
=
map
(\\ l = (path::dot (path_i, LABEL l), LABEL l))
labels;
PROJECT (
path_i,
namings,
MATRIX { rows, paths }
);
};
THE (APPLY_PATTERN (decon, _))
=>
# Find out how many variants
# there are in this case:
#
{ fun get_variants ()
=
decon::set::vals_list
(list::fold_backward
\\ (APPLY_PATTERN (x, _), sss) => decon::set::add (sss, x);
(_, sss) => sss;
end
decon::set::empty
ith_col
);
my (all_variants, has_default)
=
case decon
#
CON c =>
{ (con::variants c) -> { known, others };
( case known
[] => get_variants();
_ => map CON known;
esac,
others
);
};
LIT l
=>
case (lit::variants l)
#
THE { known, others } => (map LIT known, others);
NULL => (get_variants(), TRUE);
esac;
esac;
# function from con -> matrix; initially no rows
#
fun insert (table, key, x)
=
decon::map::set (table, key, x);
fun lookup (table, key)
=
case (decon::map::get (table, key))
#
THE x => x;
NULL => bug("can't find constructor " + decon::to_string key);
esac;
empty = decon::map::empty;
fun create ([], table)
=>
table;
create((con as CON c) ! cons, table)
=>
{ n = con::arity c;
paths = list::from_fn
(n, \\ i = path::dot (path_i, INT i));
create (cons, insert (table, con, { args => paths, rows => [] } ));
};
create((con as LIT l) ! cons, table)
=>
create (cons, insert (table, con, { args => [], rows => [] } ));
end;
table = create (all_variants, empty);
fun insert_row (table, decon, row)
=
{ my { args, rows } = lookup (table, decon);
insert (table, decon, { args, rows => rows @ [row] } );
};
fun foreach_row ([], table)
=>
table;
foreach_row( { patterns, dfa, nested, guard } ! rows, table)
=>
{ (split_i patterns) -> (prev, pat_i, next);
fun add_row (table, decon, patterns)
=
insert_row
(
table,
decon,
{ patterns, nested, dfa, guard }
);
fun add_wild_to_every_row (table)
=
fold_backward
(\\ (c, table)
=
{ my { args, rows } = lookup (table, c);
wilds = map (\\ _ => WILDCARD_PATTERN; end ) args;
patterns = prev @ wilds @ next;
add_row (table, c, patterns);
}
)
table
all_variants;
table = case pat_i
#
WILDCARD_PATTERN
=>
add_wild_to_every_row table;
APPLY_PATTERN (decon, args)
=>
{ patterns = prev @ args @ next;
add_row (table, decon, patterns);
};
_ => error "expecting constructor but found tuple/record";
esac;
foreach_row (rows, table);
};
end;
table = foreach_row (rows, table);
fun collect_cases (decon, { args, rows }, rules)
=
{ matrix = MATRIX { rows, paths=>prev_paths @ args @ next_paths };
(decon, args, matrix) ! rules;
};
cases = decon::map::keyed_fold_backward collect_cases [] table;
# If we have a default then the default matrix
# contains the original matrix with rows whose
# column i is the wild card.
#
default
=
if (not has_default)
#
NULL;
else
THE(
MATRIX { rows=>list::filter
(\\ { patterns, ... }
=
case (list::nth (patterns, i))
WILDCARD_PATTERN => TRUE;
_ => FALSE;
esac
)
rows,
paths
}
);
fi;
SWITCH (decon::map::keyed_fold_backward collect_cases [] table, default);
};
THE p => bug ("expand_column: " + pattern::to_string p);
NULL => bug "expand_column";
esac;
} # fun expand_column
# Generate the DFA
also
fun match matrix
=
if (matrix::is_empty matrix)
#
fail;
else
case (matrix::find_best_match_column matrix)
#
NULL =>
# First row is all wild cards.
#
case (matrix::row (matrix, 0))
#
{ guard => THE (subst, g), nested => [], dfa, ... }
=>
# Generate guard:
#
bind (subst,
where' (g, dfa,
match (matrix::remove_first_row matrix)));
{ guard => NULL, dfa, nested => [], ... }
=>
dfa;
{ guard, patterns, nested=>n ! ns, dfa, ... }
=>
# Handle nested patterns:
#
{ n -> (subst, path, expression, pattern);
matrix -> MATRIX { rows, paths };
row0 = { guard, patterns=>pattern ! patterns,
nested=>ns, dfa };
rows' = tail rows;
rows' = map (\\ { patterns, nested, dfa, guard }
=
{ patterns=>WILDCARD_PATTERN ! patterns, nested, dfa, guard }
)
rows';
m = MATRIX { rows=>row0 ! rows', paths=>path ! paths };
bind (subst, let' (path, expression, match m));
};
esac;
THE i =>
# Mixture rule; split at column i
#
case (expand_column (matrix, i))
#
# Splitting a constructor:
#
SWITCH (cases, default)
=>
{ cases = map (\\ (c, p, m) = (c, p, match m))
cases;
case' (matrix::path_of (matrix, i), cases,
null_or::map match default);
};
# Splitting a tuple or record;
# recompute new namings.
#
PROJECT (p, namings, m)
=>
select (p, namings, match m);
esac;
esac;
fi;
fun make_matrix rules
=
{ (head rules) -> (_, patterns0, _, _, _);
arity = length patterns0;
fun make_row (r, patterns, NULL, subst, action)
=>
{ patterns,
guard => NULL,
nested => [],
dfa => bind (subst, ok (r, action))
};
make_row (r, patterns, THE g, subst, action)
=>
{ patterns,
guard => THE (subst, g),
nested => [],
dfa => ok (r, action)
};
end;
MATRIX {
rows => map make_row rules,
paths => list::from_fn (arity, \\ i = PATH [INT i] )
};
};
dfa = match (make_matrix compiled_rules);
rule_nos = map #1 compiled_rules;
# 1. Update the reference counts.
# 2. Compute the set of free path variables at each state.
# 3. Compute the set of path variables that are actually used.
# 4. Compute the height of each node.
exception NOT_VISITED;
visited = iht::make_hashtable { size_hint => 32, not_found_exception => NOT_VISITED };
fun mark s
=
iht::set visited (s, TRUE);
fun is_visited s
=
the_else (iht::find visited s, FALSE);
fun set (fv, s)
=
{ fv := s;
s;
};
fun set_h (height, h)
=
{ height := h;
h;
};
union = name::set::union;
diff = name::set::difference;
add = name::set::add;
empty = name::set::empty;
fun diff_paths (fvs, ps)
=
diff (fvs, name::set::add_list (name::set::empty, map PVAR ps));
used = REF name::set::empty;
fun occurs s
=
used := name::set::union (*used, s);
redundant = REF (int_list_set::add_list (int_list_set::empty, rule_nos));
fun rule_used r
=
redundant := int_list_set::drop (*redundant, r);
fun vars subst
=
name::set::add_list (empty, subst::vals_list subst);
fun visit (DFA { stamp, ref_count, test, free_vars, height, ... }, pvs)
=
{ ref_count := *ref_count + 1;
#
if (is_visited stamp)
#
(*free_vars, *height);
else
mark stamp;
case test
#
FAIL => (empty, 0);
BIND (subst, dfa)
=>
{ patvars = name::set::add_list (empty,
map VAR (subst::keys_list subst));
my (s, h)
=
visit (dfa, union (pvs, patvars));
variables = vars subst;
s' = union (s, variables);
s' = diff (s', patvars);
occurs s';
(set (free_vars, s'), set_h (height, h + 1));
};
LET (p, _, dfa)
=>
{ (visit (dfa, pvs)) -> (s, h);
#
(set (free_vars, s), set_h (height, h+1));
};
OK (rule_no, action)
=>
{ fvs = name::set::add_list (empty,
map VAR (act::free_vars action));
# (print("Action = " + act::to_string action + "\n");
# print("PVs = " + Name::setToString PVs + "\n");
# print("FVs = " + Name::setToString fvs + "\n")
# )
fvs = name::set::intersection (pvs, fvs);
rule_used rule_no;
(set (free_vars, fvs), 0);
};
CASE (p, cases, opt)
=>
{ my (fvs, h)
=
list::fold_backward
(\\ ((_, ps, x), (s, h))
=
{ my (fv, h')
=
visit (x, pvs);
fv = diff_paths (fv, ps);
(union (fv, s), int::max (h, h'));
}
)
(empty, 0)
cases;
my (fvs, h)
=
case opt
#
NULL => (fvs, h);
THE x
=>
{ my (fv, h')
=
visit (x, pvs);
(union (fvs, fv), int::max (h, h'));
};
esac;
fvs = add (fvs, PVAR p);
occurs fvs;
(set (free_vars, fvs), set_h (height, h+1));
};
WHERE(_, y, n)
=>
{ my (sy, hy) = visit (y, pvs);
my (sn, hn) = visit (n, pvs);
s = union (sy, sn);
h = int::max (hy, hn) + 1;
occurs s;
(set (free_vars, s), set_h (height, h));
};
SELECT (p, bs, x)
=>
{ my (s, h) = visit (x, pvs);
s = add (s, PVAR p);
bs = fold_backward
(\\ ((p, _), sss) = add (sss, PVAR p))
s
bs;
fvs = diff (s, bs);
occurs bs;
(set (free_vars, fvs), set_h (height, h+1));
};
CONT (k, x)
=>
{ my (s, h) = visit (x, pvs); # Always generate a state function
ref_count := *ref_count + 1;
(set (free_vars, s), set_h (height, h+1));
};
esac;
fi;
};
visit (dfa, empty);
my DFA { ref_count=>fail_count, ... }
=
fail;
ROOT {
used => *used,
dfa,
exhaustive => *fail_count == 0,
redundant => *redundant
};
};
fun exhaustive (ROOT { exhaustive, ... } ) = exhaustive;
fun redundant (ROOT { redundant, ... } ) = redundant;
# Generate final code for pattern matching.
#
fun code_gen
{ gen_fail: Void -> A_expression,
gen_ok,
gen_path,
gen_bind,
gen_case,
gen_if: (gua::Guard, A_expression, A_expression) -> A_expression,
gen_goto,
gen_fun,
gen_let: (List( A_decl ), A_expression) -> A_expression,
gen_proj: (Path, List( (Null_Or( Path ), Index) )) -> A_decl,
gen_variable: Path -> var::Var,
gen_val: (var::Var, A_expression) -> A_decl,
gen_cont
} (root, dfa)
=
{ dfa -> ROOT { dfa, used, ... };
fun gen_pattern p
=
if (name::set::member (used, PVAR p)) THE p;
else NULL;
fi;
# fun arg p = THE p
fun make_vars free_var_set
=
map (\\ PVAR p => gen_variable p;
VAR v => v;
end
)
(name::set::vals_list *free_var_set);
fun enque (dfa, (fff, bbb))
=
(fff, dfa ! bbb);
empty_queue = ([], []);
# Walk a state, if it is shared then
# just generate a goto to the state
# function; otherwise expand it:
#
fun walk (dfa as DFA { stamp, ref_count, generated, free_vars, ... },
work_list)
=
if (*ref_count > 1)
#
code = gen_goto (stamp, make_vars free_vars); # Just generate a goto.
if *generated
#
(code, work_list);
else
generated := TRUE;
(code, enque (dfa, work_list));
fi;
else
expand_dfa (dfa, work_list);
fi
# Generate a new function definition:
#
also
fun gen_new_fun (dfa as DFA { stamp, free_vars, height, ... }, work_list)
=
{ my (body, work_list)
=
expand_dfa (dfa, work_list);
((*height, gen_fun (stamp, make_vars free_vars, body)), work_list);
}
also
fun expand_yes_no (yes, no, work_list)
=
(yes, no, work_list)
where
my (yes, work_list) = walk (yes, work_list);
my (no, work_list) = walk (no, work_list);
end
# Expand the dfa always:
#
also
fun expand_dfa (DFA { stamp, test, free_vars, ... }, work_list)
=
case test
#
OK (rule_no, action) # Action
=>
(gen_ok (action), work_list);
FAIL # failure
=>
(gen_fail(), work_list);
BIND (subst, dfa) # guard
=>
{ my (code, work_list)
=
walk (dfa, work_list);
namings
=
subst::keyed_fold_backward
\\ (v, PVAR p, b) => (v, gen_path p) ! b;
(v, VAR v', b) => b;
end
[]
subst;
(gen_let (gen_bind namings, code), work_list);
};
LET (path, (_, e), dfa)
=>
{ my (code, work_list)
=
walk (dfa, work_list);
(gen_let (gen_bind [(gen_variable path, e)], code), work_list);
};
WHERE (g, yes, no)
=>
{ my (yes, no, work_list)
=
expand_yes_no (yes, no, work_list);
(gen_if (g, yes, no), work_list);
};
CASE (path, cases, default)
=>
{ my (cases, work_list)
=
list::fold_backward
(\\ ((con, paths, dfa), (cases, work_list))
=
{ my (code, work_list)
=
walk (dfa, work_list);
((con, map gen_pattern paths, code) ! cases, work_list);
}
)
([], work_list)
cases;
# Find the most common case
# and make it the default:
#
my (default, work_list)
=
case default
NULL
=>
(NULL, work_list);
THE dfa
=>
{ my (code, work_list)
=
walk (dfa, work_list);
(THE code, work_list);
};
esac;
(gen_case (gen_variable path, cases, default), work_list);
};
SELECT (path, namings, body)
=>
{ my (body, work_list)
=
walk (body, work_list);
namings
=
map
(\\ (p, v) = (THE p, v))
namings;
(gen_let([gen_proj (path, namings)], body), work_list);
};
CONT (k, body)
=>
{ my (body, work_list)
=
walk (body, work_list);
(gen_let([gen_cont (k, stamp, make_vars free_vars)], body), work_list);
};
esac;
# Generate code for the dfa;
# accumulate all the auxiliary
# functions together and generate a let.
#
fun gen_all (root, dfa)
=
{ my (expression, work_list)
=
walk (dfa, empty_queue);
fun gen_aux_functions (([], []), funs)
=>
funs;
gen_aux_functions (([], bbb), funs)
=>
gen_aux_functions ((reverse bbb,[]), funs);
gen_aux_functions ((dfa ! fff, bbb), funs)
=>
{ my (new_fun, work_list)
=
gen_new_fun (dfa, (fff, bbb));
gen_aux_functions (work_list, new_fun ! funs);
};
end;
root_decl
=
gen_val (gen_variable (PATH [INT 0]), root);
funs = gen_aux_functions (work_list, []);
# Order the functions by dependencies;
# sort by lowest height:
#
funs = lms::sort_list
#
(\\ ((h, _), (h', _)) = h > h')
#
funs;
funs = map #2 funs;
gen_let (root_decl ! funs, expression);
};
gen_all (root, dfa);
};
};
end; # stipulate