## profiling-dictionary-g.pkg
# Compiled by:
#
src/lib/compiler/debugging-and-profiling/debugprof.sublib### "The term 'bug' is used, to a limited extent,
### to designate any fault or trouble in the
### connections or working of electric apparatus."
###
### -- N Hawkin, 1896
# This generic is (only) invoked in:
#
#
src/lib/compiler/toplevel/compiler/mythryl-compiler-g.pkg#
generic package profiling_dictionary_g (
#
Dictionary;
symbolmapstack_part: Dictionary -> symbolmapstack::Symbolmapstack;
evaluate: (String, Dictionary) -> Dictionary;
layer: (Dictionary, Dictionary) -> Dictionary;
)
: Profiling_Dictionary # Profiling_Dictionary is from
src/lib/compiler/debugging-and-profiling/profiling/profiling-dictionary.api where Dictionary == Dictionary
=
package {
Dictionary = Dictionary;
package td = tell_dictionary; # tell_dictionary is from
src/lib/compiler/debugging-and-profiling/profiling/tell-env.pkg fun prof (e0: td::Dictionary)
=
{ accum = REF (NIL: List( String ));
fun say x = accum := x ! *accum;
indentlev = REF 0;
spaces = " ";
fun nl ()
=
{
say "\n";
say (substring (spaces, 0, int::min (size spaces, *indentlev)));
};
fun indent f x = { indentlev := *indentlev + 1;
f x;
indentlev := *indentlev - 1;};
fun any_in_env e
=
list::exists any_in_naming (td::components e)
also
fun any_in_naming (_, b)
=
case (td::str_bind b, td::val_bind b)
#
(THE str, _) => any_in_env str;
(_, THE v) => any_in_ty v;
_ => FALSE;
esac
also
fun any_in_ty type
=
case (td::fun_type type)
#
THE _ => TRUE;
NULL => FALSE;
esac;
fun pr_env (e: td::Dictionary)
=
apply pr_naming (td::components e)
also
fun pr_naming
(
symbol: td::Symbol,
b: td::Naming
)
=
case ( td::str_bind b,
td::val_bind b
)
(THE str, _) => pr_str (symbol, str);
(_, THE v) => pr_val (symbol, v);
_ => ();
esac
also
fun pr_str
( symbol: td::Symbol,
e: td::Dictionary
)
=
if (any_in_env e)
say "package ";
say (td::name symbol);
say " {"; nl();
say " include package ";
say (td::name symbol);
indent (\\ () = { nl(); pr_env e; }) ();
say "};"; nl();
fi
also
fun pr_val
( symbol: td::Symbol,
type: td::Typoid
)
=
{ fun curried (funid, argid, type)
=
case (td::fun_type type)
#
NULL =>
{ say "op ";
say funid;
say " ";
say argid;
};
THE(_, type') =>
{
say "stipulate my op f = op ";
say funid;
say " ";
say argid;
indent (\\() = { nl ();
say "herein \\ x => ";
curried ("f", "x", type');
nl ();
say "end";
}
)
();
};
esac;
case (td::fun_type type)
#
THE(_, type') => { say "my op ";
say (td::name symbol);
say " = \\ x => ";
curried (td::name symbol, "x", type');
nl ();
};
_ => ();
esac;
};
pr_env e0;
cat (reverse *accum);
};
fun replace { get_mapstack_set, set_mapstack_set }
=
{ e0 = get_mapstack_set ();
#
s = prof (symbolmapstack_part e0);
e1 = evaluate (s, e0);
set_mapstack_set (layer (e1, e0));
};
};
## COPYRIGHT (c) 1995 AT&T Bell Laboratories.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.