## gen-sml.pkg
# Compiled by:
# src/app/makelib/portable-graph/portable-graph-stuff.lib# Generate SML source code for a given library.
stipulate
package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg package p= portable_graph; # portable_graph is from src/app/makelib/portable-graph/portable-graph.pkgherein
package gen_sml: (weak) api {
Type = String;
Varname = String;
exception TYPE_ERROR (Type, Varname);
exception UNBOUND Varname;
exception IMPORT_MISMATCH;
gen: { graph: p::Graph,
nativesrc: String -> String,
importstructs: List( String ),
output_stream: fil::Output_Stream,
exportprefix: String,
use_toplocal: Bool
}
-> Void;
}
{
Type = String;
Varname = String;
exception TYPE_ERROR (Type, Varname);
exception UNBOUND Varname;
exception IMPORT_MISMATCH;
package m
=
red_black_map_g ( # red_black_map_g is from src/lib/src/red-black-map-g.pkg Key = String;
compare = string::compare;
);
Namespace = String;
Name = String;
Symbol = (Namespace, Name);
fun symbol_compare ((ns, n), (ns', n'))
=
case (string::compare (n, n'))
EQUAL => string::compare (ns, ns');
unequal => unequal;
esac;
package ss
=
red_black_set_g (
Key = Symbol;
compare = symbol_compare;
);
package sm
=
red_black_map_g (
Key = Symbol;
compare = symbol_compare;
);
Naming = SYM Symbol
| SYMS ss::Set
| DICTIONARY sm::Map( Symbol );
fun gen args
=
{ args
->
{ graph => p::GRAPH { imports, defs, export },
nativesrc,
importstructs,
output_stream => outs,
exportprefix,
use_toplocal
};
my (xlocal, xin, xend)
=
if use_toplocal ("stipulate", "herein", "end");
else ("/* stipulate */", "/* herein */", "/* end */"); fi;
fun out l
=
apply (\\ s = fil::write (outs, s)) l;
im
=
if (length imports == length importstructs)
fun add (v, str, m)
=
m::set (m, v, str);
m = paired_lists::fold_forward add m::empty (imports, importstructs);
\\ v = m::get (m, v);
else
raise exception IMPORT_MISMATCH;
fi;
gensym
=
{ next = REF 0;
\\ () => { i = *next;
next := i + 1;
"gs_" + int::to_string i;
}; end ;
};
fun genexport (ss, fmt)
=
{ sl = ss::vals_list ss;
sl' = map (\\ (ns, n) = (ns, gensym ())) sl;
fun oneline (symbol, symbol', e)
=
{ fmt (symbol, symbol');
sm::set (e, symbol, symbol');
};
paired_lists::fold_forward oneline sm::empty (sl, sl');
};
fun an_import (lib, ss)
=
{ lstruct = case (im lib)
NULL => raise exception UNBOUND lib;
THE n => n;
esac;
fun fmt ((ns, n), (_, n'))
=
out [ns, " ", n', " = ", lstruct, n, "\n"];
genexport (ss, fmt);
};
fun genimport ((ns, n), (_, n'))
=
out [" ", ns, " ", n, " = ", n', "\n"];
fun compile (src, native, e, oss)
=
{ fun fmt ((ns, n), (_, n'))
=
out [ns, " ", n', " = ", n, "\n"];
fun copyfile src
=
copy ()
where
ins = fil::open_for_read (if native src; else nativesrc src;fi);
fun copy ()
=
case (fil::read ins)
#
"" => fil::close_input ins;
s => { out [s]; copy (); };
esac;
end;
out [xlocal, "\n"];
sm::keyed_apply genimport e;
out [xin, "\n"];
copyfile src;
genexport (oss, fmt)
then
out [xend, "\n"];
};
fun filter (e, ss)
=
sm::keyed_filter (\\ (symbol, _) => ss::member (ss, symbol); end ) e;
fun get dm v
=
case (m::get (dm, v))
#
NULL => raise exception UNBOUND v;
THE d => d;
esac;
fun get_dictionary dm v
=
case (get dm v)
#
DICTIONARY m => m;
_ => raise exception TYPE_ERROR ("dictionary", v);
esac;
fun namespace p::SGN => "api";
namespace p::PACKAGE => "package";
namespace p::GENERIC => "generic";
end;
fun onedef (p::DEF { lhs, rhs }, dm)
=
{ get = get dm;
get_dictionary = get_dictionary dm;
fun get_sym v
=
case (get v)
#
SYM s => s;
_ => raise exception TYPE_ERROR ("symbol", v);
esac;
fun get_syms v
=
case (get v)
#
SYMS ss => ss;
_ => raise exception TYPE_ERROR ("syms", v);
esac;
m::set ( dm,
lhs,
case rhs
#
p::SYM (ns, n)
=>
SYM (namespace ns, n);
p::SYMS vl
=>
{ fun one (v, ss) = ss::add (ss, get_sym v);
SYMS (fold_forward one ss::empty vl);
};
p::IMPORT { lib, syms }
=>
DICTIONARY (an_import (lib, get_syms syms));
p::COMPILE { src => (src, native), env=>dictionary, syms }
=>
DICTIONARY (compile (src, native, get_dictionary dictionary, get_syms syms));
p::FILTER { env=>dictionary, syms }
=>
DICTIONARY (filter (get_dictionary dictionary, get_syms syms));
p::MERGE el
=>
{ fun one (v, e)
=
sm::union_with #2 (get_dictionary v, e);
DICTIONARY (fold_forward one sm::empty el);
};
esac
);
};
out ["stipulate\n"];
dm = fold_forward onedef m::empty defs;
ee = get_dictionary dm export;
fun libexport ((ns, n), (_, n'))
=
out [ns, " ", exportprefix, n, " = ", n', "\n"];
out ["herein\n"];
sm::keyed_apply libexport ee;
out ["end\n"];
};
};
end;
## (C) 2001 Lucent Technologies, Bell Labs
## author: Matthias Blume (blume@research.bell-labs.com)