# match-gen-g.pkg
# Interface with the match compiler to generate Mythryl code.
# Compiled by:
# src/lib/compiler/back/low/tools/match-compiler.lib### "Do not eat your heart."
###
### -- Pythagoras
# 2008-01-29 CrT: So far as I can tell, this generic is not invoked
# by the compiler mainline. It -is- invoked by:
#
# src/lib/c-glue/ml-grinder/ml-grinder.pkg# src/lib/compiler/back/low/tools/nowhere/nowhere.pkg# src/lib/compiler/back/low/tools/match-compiler/test-match-g.pkg#
# Compiler mainline pattern-match compilation is handled by
#
# src/lib/compiler/back/top/translate/translate-deep-syntax-pattern-to-lambdacode.pkg #
stipulate
package ils = int_list_set; # int_list_set is from src/lib/src/int-list-set.pkg package spp = simple_prettyprinter; # simple_prettyprinter is from src/lib/prettyprint/simple/simple-prettyprinter.pkg package rrs = adl_rewrite_raw_syntax_parsetree; # adl_rewrite_raw_syntax_parsetree is from src/lib/compiler/back/low/tools/adl-syntax/adl-rewrite-raw-syntax-parsetree.pkg package raw = adl_raw_syntax_form; # adl_raw_syntax_form is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-form.pkgherein
# This generic is invoked in:
#
# src/lib/compiler/back/low/tools/nowhere/nowhere.pkg #
# src/lib/c-glue/ml-grinder/ml-grinder.pkg (broken) # src/lib/compiler/back/low/tools/match-compiler/test-match-g.pkg (broken) #
generic package match_gen_g (
# ===========
#
package rsu: Adl_Raw_Syntax_Unparser; # Adl_Raw_Syntax_Unparser is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-unparser.api package rsj: Adl_Raw_Syntax_Junk; # Adl_Raw_Syntax_Junk is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-junk.api )
: (weak) Match_G # Match_G is from src/lib/compiler/back/low/tools/match-compiler/match-g.api {
# Exported to clients:
# mc
# lit_map
# dictionary
#
stipulate
package rsu = rsu; # "rsu" == "raw_syntax_unparser".
herein
++ = spp::CONS;
infix my ++ ;
i2s = int::to_string;
package guard {
#
Guard = (Int, raw::Expression);
fun to_string (_, e)
=
spp::prettyprint_expression_to_string (rsu::expression e);
fun compare ((i, _), (j, _))
=
int::compare (i, j);
counter = REF 0;
fun guard e
=
(*counter, e)
then
counter := *counter + 1;
fun logical_and ((_, x), (_, y))
=
guard
(rsj::and_fn (x, y));
};
package expression {
#
Expression = raw::Expression;
to_string = spp::prettyprint_expression_to_string o rsu::expression;
};
package literal {
#
Literal = raw::Literal;
to_string = spp::prettyprint_expression_to_string o rsu::literal;
compare = rsj::compare_literal;
bools = THE { others => FALSE,
known => [raw::BOOL_LIT FALSE, raw::BOOL_LIT TRUE]
};
fun variants (raw::BOOL_LIT _) => bools;
variants _ => NULL;
end;
package map
=
red_black_map_g ( # red_black_map_g is from src/lib/src/red-black-map-g.pkg Key = Literal;
compare = compare;
);
};
package lit_map # Exported to client packages.
=
literal::map;
Valcon_Form
=
VALCON_FORM (List( raw::Id ), raw::Constructor, raw::Sumtype)
|
EXCEPTION (List( raw::Id ), raw::Id, Null_Or( raw::Type ));
package con {
#
Con = Valcon_Form;
fun to_string (VALCON_FORM (path, raw::CONSTRUCTOR { name, ... }, _))
=>
spp::prettyprint_expression_to_string (rsu::uppercase_ident (raw::IDENT (path, name)));
to_string (EXCEPTION (path, id, type))
=>
spp::prettyprint_expression_to_string (rsu::uppercase_ident (raw::IDENT (path, id)));
end;
fun compare (VALCON_FORM(_, raw::CONSTRUCTOR { name=>x, ... }, _),
VALCON_FORM(_, raw::CONSTRUCTOR { name=>y, ... }, _))
=>
string::compare (x, y);
compare (EXCEPTION(_, x, _), EXCEPTION(_, y, _))
=>
string::compare (x, y);
compare (VALCON_FORM _, EXCEPTION _) => LESS;
compare (EXCEPTION _, VALCON_FORM _) => GREATER;
end;
fun variants (VALCON_FORM (path, _, dt as raw::SUMTYPE { cbs, ... } ))
=>
{ others => FALSE,
known => map
(\\ c = VALCON_FORM (path, c, dt))
cbs
};
variants (EXCEPTION _)
=>
{ known => [], others => TRUE };
variants _ => raise exception DIE "Bug: Unsupported case in 'variants'.";
end;
fun arity (VALCON_FORM (_, raw::CONSTRUCTOR { type => NULL, ... }, _)) => 0;
arity (VALCON_FORM (_, raw::CONSTRUCTOR { type => THE type, ... }, _)) => 1;
#
arity (EXCEPTION(_, _, NULL)) => 0;
arity (EXCEPTION(_, _, THE _)) => 1;
end;
};
package variable {
#
Var = raw::Id;
compare = string::compare;
fun to_string x
=
x;
package map
=
red_black_map_g ( # red_black_map_g is from src/lib/src/red-black-map-g.pkg Key = Var;
compare = compare;
);
package set
=
red_black_set_g (
Key = Var;
compare = compare;
);
};
package action {
#
Action = raw::Expression;
to_string
=
spp::prettyprint_expression_to_string o rsu::expression;
fun free_vars e
=
{ fvs = REF variable::set::empty;
fun expression _ (e as raw::ID_IN_EXPRESSION (raw::IDENT([], x)))
=>
{ fvs := variable::set::add(*fvs, x);
e;
};
expression _ e
=>
e;
end;
(rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_EXPRESSION_NODE expression ]).rewrite_expression_parsetree
e;
variable::set::vals_list *fvs;
};
};
package mc # Exported to client packages.
=
match_compiler_g ( # match_compile_g is from src/lib/compiler/back/low/tools/match-compiler/match-compiler-g.pkg #
package gua = guard;
package exp = expression;
package lit = literal;
package con = con;
package var = variable;
package act = action;
);
fun id_fn x
=
raw::ID_IN_EXPRESSION (raw::IDENT([], x));
fun state_fn x
=
"state_" + (i2s x);
exception MATCH_COMPILER = mc::MATCH_COMPILER;
package dictionary {
#
Dictionary
=
DICTIONARY
{ cons: variable::map::Map( Valcon_Form ),
sigs: variable::map::Map( Dictionary )
};
fun insert_cons (DICTIONARY { cons, sigs }, id, pick_valcon_form)
=
DICTIONARY {
cons => variable::map::set (cons, id, pick_valcon_form),
sigs
};
fun bind_api_identifier (DICTIONARY { cons, sigs }, id, dictionary)
=
DICTIONARY {
cons,
sigs => variable::map::set (sigs, id, dictionary)
};
fun lookup_sig (DICTIONARY { sigs, ... }, id) = variable::map::get (sigs, id);
fun lookup_cons (DICTIONARY { cons, ... }, id) = variable::map::get (cons, id);
empty = DICTIONARY
{
cons => variable::map::empty,
sigs => variable::map::empty
};
};
Compiled_Type_Info
=
dictionary::Dictionary;
# Enter all sumtypes
# definitions into a list:
#
fun compile_types ds
=
decls (ds, dictionary::empty)
where
fun decl (raw::SUMTYPE_DECL (dbs, _), dictionary) => dbinds (dbs, dictionary);
decl (raw::EXCEPTION_DECL ebs, dictionary) => ebinds (ebs, dictionary);
decl (raw::SOURCE_CODE_REGION_FOR_DECLARATION(_, d), dictionary) => decl (d, dictionary);
decl (raw::API_DECL (id, raw::DECLARATIONS_API ds), dictionary) => decls (ds, dictionary);
decl (raw::PACKAGE_DECL (id, _, _, raw::DECLSEXP ds), dictionary) => nested (id, ds, dictionary);
decl (raw::SEQ_DECL ds, dictionary) => decls (ds, dictionary);
decl (_, dictionary) => dictionary;
end
also
fun decls (ds, dictionary)
=
list::fold_backward decl dictionary ds
also
fun dbind (t as raw::SUMTYPE { cbs, ... }, dictionary)
=>
list::fold_backward
(\\ (c as raw::CONSTRUCTOR { name, ... }, dictionary)
=
dictionary::insert_cons (dictionary, name, VALCON_FORM([], c, t))
)
dictionary
cbs;
dbind(_, dictionary)
=>
dictionary;
end
also
fun dbinds (dbs, dictionary)
=
list::fold_backward dbind dictionary dbs
also
fun ebind (raw::EXCEPTION (id, type), dictionary)
=>
dictionary::insert_cons (dictionary, id, EXCEPTION([], id, type));
ebind(_, dictionary)
=>
dictionary;
end
also
fun ebinds (ebs, dictionary)
=
list::fold_backward ebind dictionary ebs
also
fun nested (id, ds, dictionary)
=
{ dictionary' = decls (ds, dictionary::empty);
dictionary::bind_api_identifier (dictionary, id, dictionary');
};
end;
fun pr_clause (p, g)
=
spp::prettyprint_expression_to_string
( rsu::pattern p ++ spp::MAYBE_BLANK
++
case g NULL => spp::ALPHABETIC "=> ...";
THE e => spp::ALPHABETIC "where ... => ...";
esac
);
fun compile dictionary clauses
=
{ # Rename all rules
fun has_con x
=
not_null (dictionary::lookup_cons (dictionary, x));
fun lookup (dictionary, path,[], x)
=>
case (dictionary::lookup_cons (dictionary, x))
#
THE (VALCON_FORM(_, c, t))
=>
VALCON_FORM (path, c, t);
THE (EXCEPTION(_, id, t))
=>
EXCEPTION (path, id, t);
NULL => raise exception MATCH_COMPILER ("undefined constructor " + x);
esac;
lookup (dictionary, path, p ! ps, x)
=>
case (dictionary::lookup_sig (dictionary, p))
#
THE dictionary
=>
lookup (dictionary, path, ps, x);
NULL =>
raise exception MATCH_COMPILER("undefined package " + p + " in " +
spp::prettyprint_expression_to_string (rsu::lowercase_ident (raw::IDENT (path, x))));
esac;
end;
fun lookup_con (raw::IDENT (p, x))
=
lookup (dictionary, p, p, x);
# Rewrite list patterns
#
fun trans_list_pattern p
=
{ fun cons (x, y)
=
raw::CONSPAT (raw::IDENT([], "::"), THE (raw::TUPLEPAT [x, y]));
nil = raw::CONSPAT (raw::IDENT([], "NIL"), NULL);
fun listify ([], THE p) => p;
listify ([], NULL) => nil;
listify (p ! ps, t) => cons (p, listify (ps, t));
end;
fun pattern _ (raw::LISTPAT (ps, t)) => listify (ps, t);
pattern _ p => p;
end;
fns = rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_PATTERN_NODE pattern ];
fns.rewrite_pattern_parsetree p;
};
rule_no = REF 0;
fun rename_rule (c as raw::CLAUSE ([pattern], guard, e))
=>
{ my (e, match_fail_exception)
=
case e
raw::MATCH_FAIL_EXCEPTION_IN_EXPRESSION (e, x) => (e, THE x); # Some odd extension -- 'x' names an exception 'FOO', from surface syntax <pattern> <guard> exception FOO => <expression>;
_ => (e, NULL);
esac;
mc::rename
(\\ { id_pattern, as_pattern, cons_pattern, wild_pattern,
tuple_pattern, record_pattern, lit_pattern,
or_pattern, and_pattern, not_pattern, where_pattern, nested_pattern, ...
}
=
\\ raw::ASPAT (id, p) => as_pattern (id, p);
raw::WILDCARD_PATTERN => wild_pattern();
raw::CONSPAT (c, NULL) => cons_pattern (lookup_con c,[]);
raw::CONSPAT (c, THE (p)) => cons_pattern (lookup_con c,[p]);
raw::TUPLEPAT ps => tuple_pattern ps;
raw::RECORD_PATTERN (lps, _) => record_pattern lps;
raw::LITPAT lit => lit_pattern lit;
raw::OR_PATTERN ps => or_pattern ps;
raw::ANDPAT ps => and_pattern ps;
raw::NOTPAT p => not_pattern p;
raw::WHEREPAT (p, e) => where_pattern (p, guard::guard e);
raw::NESTEDPAT (p, e, p') => nested_pattern (p, guard::guard e, p');
raw::IDPAT id
=>
if (has_con id)
#
cons_pattern (lookup_con (raw::IDENT([], id)),[]);
else
id_pattern id;
fi;
p => raise exception mc::MATCH_COMPILER ( "illegal pattern "
+ spp::prettyprint_expression_to_string (rsu::pattern p)
);
end
)
# (I think) our return record will be processed by fun rename in
# src/lib/compiler/back/low/tools/match-compiler/match-compiler-g.pkg #
{ number => *rule_no,
patterns => [trans_list_pattern pattern],
guard => null_or::map guard::guard guard,
action => e,
match_fail_exception # Currently ignored. I think intended to allow end-user selection of exception generated on match failure. -- 2011-04-23 CrT
}
then
rule_no := *rule_no + 1;
}
except
mc::MATCH_COMPILER msg
=
raise exception mc::MATCH_COMPILER (msg + " in " + pr_clause (pattern, guard));
rename_rule _ => raise exception DIE "Bug: Unsupported case in rename_rule";
end; # fun rename_rule
rules = map rename_rule clauses;
# Compile the rules into a dfa:
#
dfa = mc::compile
{
compiled_rules => rules,
compress => TRUE
};
dfa;
}; # fun compile
# Report errors:
#
fun report { warning, error, log, dfa, rules }
=
{ red = mc::redundant dfa;
ex = mc::exhaustive dfa;
bad = ils::vals_count red > 0;
error = bad ?? error
:: warning;
message
=
if ex
bad ?? "redundant matches"
:: "";
else
bad ?? "non-exhaustive and redundant matches"
:: "non-exhaustive matches";
fi;
fun dump_rules (i, [])
=>
();
dump_rules (i, r ! rules)
=>
{ tab = if (ils::member (red, i)) "---> ";
else " ";
fi;
my (p, g)
=
case r raw::CLAUSE ([p], g, _) => (p, g);
/* */ _ => raise exception DIE "Bug: Unsupported case in dump_rules.";
esac;
text = pr_clause (p, g);
log (tab + text);
dump_rules (i+1, rules);
};
end;
if (not ex or bad)
#
error message;
dump_rules (0, rules);
fi;
};
exception GEN_REAL also GEN_INTEGER;
stipulate
integer_compare = raw::ID_IN_EXPRESSION (raw::IDENT (["integer"], "compare"));
real_eq = raw::ID_IN_EXPRESSION (raw::IDENT (["Float"], "==")); # XXX BUGGO FIXME does this need to change to "===="?
eq = raw::ID_IN_EXPRESSION (raw::IDENT ([], "=")); # XXX BUGGO FIXME does this need to change to "=="?
equal = raw::ID_IN_EXPRESSION (raw::IDENT ([], "EQUAL"));
herein
fun make_integer_eq (x, y)
=
raw::APPLY_EXPRESSION (
eq,
raw::TUPLE_IN_EXPRESSION [
raw::APPLY_EXPRESSION (
integer_compare,
raw::TUPLE_IN_EXPRESSION [x, y]
),
equal
]
);
fun make_real_eq (x, y)
=
raw::APPLY_EXPRESSION (real_eq, raw::TUPLE_IN_EXPRESSION [x, y]);
end;
name_counter
=
REF 0;
fun new_name ()
=
*name_counter
then
name_counter := *name_counter + 1;
fun init ()
=
name_counter := 0;
# Generate Mythryl code:
#
fun code_gen { root, dfa, fail=>gen_fail, literals }
=
{ # Make unique name for path variables:
name_table
=
REF mc::path::map::empty;
fun gen_lit (l as raw::INTEGER_LIT _)
=>
case (literal::map::get (*literals, l))
#
THE v => rsj::id v;
NULL =>
{ v = "lit_" + i2s (new_name());
literals := literal::map::set (*literals, l, v);
rsj::id v;
};
esac;
gen_lit l
=>
raw::LITERAL_IN_EXPRESSION l;
end;
fun get_name path
=
case (mc::path::map::get (*name_table, path))
#
THE name => name;
#
NULL =>
{ v = "v_" + i2s (new_name());
name_table
:=
mc::path::map::set (*name_table, path, v);
v;
};
esac;
# Now generate the code; we just
# have to hook things up with the MC
#
fun gen_variable path
=
get_name path;
fun gen_path path
=
id_fn (gen_variable path);
fun gen_bind []
=>
[];
gen_bind namings
=>
[ raw::VAL_DECL (
map
(\\ (v, e)
=
raw::NAMED_VARIABLE (raw::IDPAT v, e)
)
namings
)
];
end;
fun gen_ok (e)
=
e;
fun path_to_pattern (path)
=
raw::IDPAT (get_name path);
fun arg NULL => raw::WILDCARD_PATTERN;
arg (THE p) => raw::IDPAT (get_name p);
end;
fun from_rep (VALCON_FORM (path, raw::CONSTRUCTOR c, _))
=>
raw::IDENT (path, c.name);
from_rep (EXCEPTION (path, id, _))
=>
raw::IDENT (path, id);
end;
fun gen_con_pattern (mc::CON con, [])
=>
raw::CONSPAT (from_rep con, NULL);
gen_con_pattern (mc::CON con, paths)
=>
raw::CONSPAT (from_rep con, THE (raw::TUPLEPAT (map arg paths)));
gen_con_pattern (mc::LIT (raw::FLOAT_LIT _), _)
=>
raise exception GEN_REAL;
gen_con_pattern (mc::LIT (raw::INTEGER_LIT _), _)
=>
raise exception GEN_INTEGER;
gen_con_pattern (mc::LIT lit, _)
=>
raw::LITPAT lit;
end;
fun gen_case (v, cases, default)
=
raw::CASE_EXPRESSION
(
id_fn v,
map (\\ (con, paths, e)
=
raw::CLAUSE( [gen_con_pattern (con, paths)], NULL, e)
)
cases
@
case default
#
NULL => [];
THE default => [raw::CLAUSE([raw::WILDCARD_PATTERN], NULL, default)];
esac
)
except
GEN_REAL => gen_lit_cmp (make_real_eq, v, cases, default);
GEN_INTEGER => gen_lit_cmp (make_integer_eq, v, cases, default);
end
also
fun gen_lit_cmp (eq, v, cases, THE default)
=>
{ x = id_fn v;
#
fun equal lit
=
eq (x, gen_lit lit);
list::fold_backward f default cases
where
fun f ((mc::LIT lit, _, e), rest)
=>
raw::IF_EXPRESSION (equal lit, e, rest);
f _ => raise exception DIE "Bug: Unsupported case in gen_lit_cmp.";
end;
end;
};
gen_lit_cmp (_, _, _, NULL) => raise exception DIE "Bug: Unsupported case in gen_lit_cmp.";
end;
fun gen_if ((_, e), y, n)
=
raw::IF_EXPRESSION (e, y, n);
fun gen_goto (f, args)
=
raw::APPLY_EXPRESSION (id_fn (state_fn f), raw::TUPLE_IN_EXPRESSION (map id_fn args));
fun gen_fun (f, args, body)
=
raw::FUN_DECL [
raw::FUN (
state_fn f,
[ raw::CLAUSE (
[ raw::TUPLEPAT (map raw::IDPAT args) ],
NULL,
body
)
]
)
];
fun gen_let ([], e) => e;
gen_let ( d, e) => raw::LET_EXPRESSION (d,[e]);
end;
fun gen_val (v, e)
=
raw::VAL_DECL [ raw::NAMED_VARIABLE (raw::IDPAT v, e) ];
fun gen_proj (path, namings)
=
{ pattern
=
case namings
#
[] =>
raw::WILDCARD_PATTERN;
(p, mc::INT _) ! ps
=>
raw::TUPLEPAT
(map
(\\ (p, _) = arg p)
namings
);
(p, mc::LABEL _) ! ps
=>
raw::RECORD_PATTERN (map f namings, TRUE)
where
fun f (p, mc::LABEL l) => (l, arg p);
f (p, _ ) => raise exception DIE "Bug: Unsupported case in gen_proj";
end;
end;
esac;
raw::VAL_DECL [raw::NAMED_VARIABLE (pattern, id_fn (get_name path)) ];
};
fun gen_cont (k, f, vars)
=
raw::FUN_DECL [
raw::FUN (
k,
[ raw::CLAUSE (
[ raw::TUPLEPAT [] ],
NULL,
raw::APPLY_EXPRESSION (
id_fn (state_fn f),
raw::TUPLE_IN_EXPRESSION (map id_fn vars)
)
)
]
)
];
mc::code_gen
{ gen_fail,
gen_ok,
gen_path,
gen_bind,
gen_case,
gen_if,
gen_goto,
gen_cont,
gen_fun,
gen_let,
gen_variable,
gen_val,
gen_proj
}
(root, dfa);
}; # fun code_gen
fun complex_pattern p
=
*complex
where
complex = REF FALSE;
fun rewrite_pattern_node _ (p as raw::WHEREPAT _) => { complex := TRUE; p; };
rewrite_pattern_node _ (p as raw::NESTEDPAT _) => { complex := TRUE; p; };
rewrite_pattern_node _ (p as raw::ANDPAT _) => { complex := TRUE; p; };
rewrite_pattern_node _ (p as raw::NOTPAT _) => { complex := TRUE; p; };
rewrite_pattern_node _ (p as raw::OR_PATTERN _) => { complex := TRUE; p; };
rewrite_pattern_node _ (p as raw::LITPAT (raw::FLOAT_LIT _)) => { complex := TRUE; p; };
rewrite_pattern_node _ (p as raw::LITPAT (raw::INTEGER_LIT _)) => { complex := TRUE; p; };
rewrite_pattern_node _ p => p;
end;
fns.rewrite_pattern_parsetree p
where
fns = rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_PATTERN_NODE rewrite_pattern_node ];
end;
end;
# Are clauses conditional?
#
is_complex
=
list::exists
(\\ raw::CLAUSE (p, g, _)
=
not_null g or list::exists complex_pattern p
);
end; # stipulate
}; # generic package match_gen_g
end; # stipulate