## to-portable.pkg
# Compiled by:
# src/app/makelib/makelib.sublib# Generate list-of-edges dependency graph representation from
# internal makelib data structures.
stipulate
package ad = anchor_dictionary; # anchor_dictionary is from src/app/makelib/paths/anchor-dictionary.pkg package flt = frozenlib_tome; # frozenlib_tome is from src/app/makelib/freezefile/frozenlib-tome.pkg package ftm = frozenlib_tome_map; # frozenlib_tome_map is from src/app/makelib/freezefile/frozenlib-tome-map.pkg package lg = inter_library_dependency_graph; # inter_library_dependency_graph is from src/app/makelib/depend/inter-library-dependency-graph.pkg package mls = makelib_state; # makelib_state is from src/app/makelib/main/makelib-state.pkg package pg = portable_graph; # portable_graph is from src/app/makelib/portable-graph/portable-graph.pkg package sg = intra_library_dependency_graph; # intra_library_dependency_graph is from src/app/makelib/depend/intra-library-dependency-graph.pkg package spm = source_path_map; # source_path_map is from src/app/makelib/paths/source-path-map.pkg package ss = symbol_set; # symbol_set is from src/app/makelib/stuff/symbol-set.pkg package str = string; # string is from src/lib/std/string.pkg package sym = symbol_map; # symbol_map is from src/app/makelib/stuff/symbol-map.pkg package tlt = thawedlib_tome; # thawedlib_tome is from src/app/makelib/compilable/thawedlib-tome.pkg package ttm = thawedlib_tome_map; # thawedlib_tome_map is from src/app/makelib/compilable/thawedlib-tome-map.pkgherein
package to_portable: (weak) api {
export: ( lg::Inter_Library_Dependency_Graph,
mls::Makelib_State
)
->
( pg::Graph,
List( ad::File )
);
}
{
package slm
=
red_black_map_g( # red_black_map_g is from src/lib/src/red-black-map-g.pkg Key = List( String );
fun compare ([], []) => EQUAL;
compare ([], _) => LESS;
compare (_, []) => GREATER;
compare (h ! t, h' ! t')
=>
case (str::compare (h, h'))
#
EQUAL => compare (t, t');
unequal => unequal;
esac;
end;
);
package fm
=
red_black_map_g(
Key = (String, String);
fun compare ((v, f), (v', f'))
=
case (str::compare (v, v'))
#
EQUAL => str::compare (f, f');
unequal => unequal;
esac;
);
package ssm
=
red_black_map_g(
Key = ss::Set;
compare = ss::compare;
);
package im
=
red_black_map_g(
Key = (ad::File, String);
fun compare ((p, s), (p', s'))
=
case (ad::compare (p, p'))
#
EQUAL => str::compare (s, s');
unequal => unequal;
esac;
);
ignored_symbols
=
ss::add_list ( ss::empty,
[ pervasive_symbol::pervasive_package_symbol, core_symbol::core_symbol ]
);
fun export (lg::BAD_LIBRARY, _)
=>
raise exception DIE "to_portable::export BAD_LIBRARY";
export (lg::LIBRARY { catalog, sublibraries, libfile, ... }, makelib_state)
=>
{ cwd = winix__premicrothread::file::current_directory ();
fun to_absolute p
=
if (winix__premicrothread::path::is_absolute p)
p;
else winix__premicrothread::path::make_absolute { path => p, relative_to => cwd };fi;
library_dir
=
winix__premicrothread::path::dir (to_absolute (ad::os_string libfile));
stipulate
fun make_tome_to_libfile_maps []
=>
( ttm::empty, # This will map thawedlib_tome -> (libfile, exports_mask)
ftm::empty # This will map frozenlib_tome -> (libfile, exports_mask)
);
make_tome_to_libfile_maps ((lt: lg::Library_Thunk) ! ls)
=>
{ (make_tome_to_libfile_maps ls)
->
(thawedlib_tome_map, frozenlib_tome_map);
fun update (get, set) (map, i, (p, ex))
=
case (get (map, i))
#
THE (p', ex') => set (map, i, (p', ss::union (ex, ex')));
NULL => set (map, i, (p, ex));
esac;
update_thawedlib_tome_map = update (ttm::get, ttm::set);
update_frozenlib_tome_map = update (ftm::get, ftm::set);
fun one_e (symbol, (tome: lg::Fat_Tome), (thawedlib_tome_map, frozenlib_tome_map))
=
case (tome.masked_tome_thunk ())
#
{ exports_mask, tome_tin => sg::TOME_IN_FROZENLIB { frozenlib_tome_tin => sg::FROZENLIB_TOME_TIN tin, ... } }
=>
(thawedlib_tome_map, update_frozenlib_tome_map (frozenlib_tome_map, tin.frozenlib_tome, (lt.libfile, tome.exports_mask)));
{ exports_mask, tome_tin => sg::TOME_IN_THAWEDLIB (sg::THAWEDLIB_TOME_TIN tin) }
=>
(update_thawedlib_tome_map (thawedlib_tome_map, tin.thawedlib_tome, (lt.libfile, tome.exports_mask)), frozenlib_tome_map);
esac;
case (lt.library_thunk ())
#
lg::LIBRARY { catalog, ... }
=>
sym::keyed_fold_forward one_e (thawedlib_tome_map, frozenlib_tome_map) catalog;
_ => (thawedlib_tome_map, frozenlib_tome_map);
esac;
};
end;
(make_tome_to_libfile_maps sublibraries)
->
(thawedlib_tome_map, frozenlib_tome_map);
fun drop_ignored_symbols (p, ex)
=
( p,
ss::difference (ex, ignored_symbols)
);
thawedlib_tome_map = ttm::map drop_ignored_symbols thawedlib_tome_map;
frozenlib_tome_map = ftm::map drop_ignored_symbols frozenlib_tome_map;
herein
fun get_libfile_and_exports_for_frozenlib_tome
#
(frozenlib_tome: flt::Frozenlib_Tome)
=
case (ftm::get (frozenlib_tome_map, frozenlib_tome))
#
THE libfile_and_exports => libfile_and_exports;
NULL => raise exception DIE "get_libfile_and_exports_for_frozenlib_tome";
esac;
fun get_libfile_and_exports_for_thawedlib_tome
#
(thawedlib_tome: tlt::Thawedlib_Tome)
=
ttm::get (thawedlib_tome_map, thawedlib_tome);
end;
stipulate
namings = REF [];
herein
fun gen_bind (lhs, rhs)
=
namings := pg::DEF { lhs, rhs } ! *namings;
fun all_namings ()
=
reverse *namings;
end;
fun relname i
=
{ p = to_absolute (ad::os_string (tlt::sourcepath_of i));
s = winix__premicrothread::path::make_relative { path => p, relative_to => library_dir };
my { arcs, is_absolute, disk_volume }
=
winix__premicrothread::path::from_string s;
fun badarc a
=
a != winix__premicrothread::path::current_arc and
a != winix__premicrothread::path::parent_arc and
(a == "." or a == ".." or char::contains a '/');
fun to_unix []
=>
".";
to_unix (h ! t)
=>
{ fun trans a
=
if (a == winix__premicrothread::path::current_arc ) ".";
elif (a == winix__premicrothread::path::parent_arc ) "..";
else a;
fi;
cat (reverse (fold_forward (\\ (a, l) = trans a ! "/" ! l)
[trans h] t));
};
end;
if (is_absolute or disk_volume != "" or
list::exists badarc arcs
)
(s, TRUE);
else
(to_unix arcs, FALSE);
fi;
};
gensym
=
{ next = REF 0;
\\ prefix
=
{ i = *next;
prefix + int::to_string i
then
next := i + 1;
};
};
smlmap = REF ttm::empty;
imports = REF spm::empty;
fun gen_lib p
=
case (spm::get (*imports, p))
#
THE v => v;
NULL => { v = gensym "l";
imports := spm::set (*imports, p, v);
v;
};
esac;
stipulate
symbols = REF sym::empty;
herein
fun gen_sym s
=
case (sym::get (*symbols, s))
#
THE v => v;
NULL
=>
{ my (p, ns)
=
case (symbol::name_space s)
#
symbol::API_NAMESPACE => ("sgn", pg::SGN);
symbol::PACKAGE_NAMESPACE => ("str", pg::PACKAGE);
symbol::GENERIC_NAMESPACE => ("fct", pg::GENERIC);
symbol::GENERIC_API_NAMESPACE => raise exception DIE "funsig not permitted in portable graphs";
#
_ => raise exception DIE "unexpected namespace";
esac;
v = gensym p;
gen_bind (v, pg::SYM (ns, symbol::name s));
symbols := sym::set (*symbols, s, v);
v;
};
esac;
end;
stipulate
sets = REF ssm::empty;
herein
fun gen_syms ss
=
case (ssm::get (*sets, ss))
#
THE v => v;
NULL => { v = gensym "ss";
sl = ss::vals_list ss;
gen_bind (v, pg::SYMS (map gen_sym sl));
sets := ssm::set (*sets, ss, v);
v;
}; esac;
end;
stipulate
filters = REF fm::empty;
imps = REF im::empty;
herein
fun prevent_filter (e, f)
=
filters := fm::set (*filters, (e, f), e);
fun gen_filter (v, f)
=
{ s = gen_syms f;
case (fm::get (*filters, (v, s)))
#
THE e => e;
NULL => { e = gensym "e";
gen_bind (e, pg::FILTER { env => v, syms => s } );
filters := fm::set (*filters, (v, s), e);
prevent_filter (e, s);
e;
};
esac;
};
fun gen_filter' (vex as (v, ex), f)
=
{ f' = ss::intersection (ex, f);
#
if (ss::equal (ex, f')) vex;
else (gen_filter (v, f'), f');
fi;
};
fun unlayer l
=
loop (l, ss::empty, [])
where
fun loop ([], _, a)
=>
reverse a;
loop ((h, hss) ! t, ss, a)
=>
{ i = ss::intersection (ss, hss);
u = ss::union (ss, hss);
f = ss::difference (hss, ss);
if (ss::is_empty f) loop (t, u, a);
elif (ss::is_empty i) loop (t, u, h ! a);
else loop (t, u, gen_filter (h, f) ! a);
fi;
};
end;
end;
stipulate
merges = REF slm::empty;
herein
fun gen_merge [e]
=>
e;
gen_merge l
=>
case (slm::get (*merges, l))
#
THE e => e;
NULL => { e = gensym "e";
gen_bind (e, pg::MERGE l);
merges := slm::set (*merges, l, e);
e;
};
esac;
end;
end;
fun gen_compile (v, s, e, ex)
=
{ ss = gen_syms ex;
prevent_filter (v, ss);
gen_bind (v, pg::COMPILE { src => s, env => e, syms => ss } );
};
fun gen_import (lib, ex)
=
if (ss::is_empty ex)
#
("dummy", ex);
else
s = gen_syms ex;
case (im::get (*imps, (lib, s)))
#
THE v => (v, ex);
NULL
=>
{ v = gensym "e";
l = gen_lib lib;
imps := im::set (*imps, (lib, s), v);
gen_bind (v, pg::IMPORT { lib => l, syms => s } );
prevent_filter (v, s);
(v, ex);
};
esac;
fi;
end;
fun do_thawedlib_tome_import (thawedlib_tome: tlt::Thawedlib_Tome)
=
case (get_libfile_and_exports_for_thawedlib_tome thawedlib_tome)
#
THE libfile_and_exports => THE (gen_import libfile_and_exports);
NULL => NULL;
esac;
fun do_frozenlib_tome (frozenlib_tome: flt::Frozenlib_Tome)
=
gen_import (get_libfile_and_exports_for_frozenlib_tome frozenlib_tome);
fun do_thawedlib_tome_tin (sg::THAWEDLIB_TOME_TIN { thawedlib_tome, near_imports, far_imports } )
=
case (ttm::get (*smlmap, thawedlib_tome))
#
THE vex => vex;
#
NULL =>
{ v = gensym "e";
ex = case (tlt::exports makelib_state thawedlib_tome)
#
THE ex => ex;
NULL => raise exception DIE "cannot parse SML file";
esac;
vex = (v, ex);
my _ =
smlmap := ttm::set (*smlmap, thawedlib_tome, vex);
gi = map do_masked_tome far_imports;
li = map do_thawedlib_tome_tin near_imports;
e = gen_merge (unlayer (li @ gi));
gen_compile (v, relname thawedlib_tome, e, ex);
vex;
};
esac
also
fun do_masked_tome { exports_mask => NULL, tome_tin } => do_tome_tin tome_tin;
do_masked_tome { exports_mask => THE f, tome_tin } => gen_filter' (do_tome_tin tome_tin, f);
end
also
fun do_tome_tin (sg::TOME_IN_THAWEDLIB (tome_tin as sg::THAWEDLIB_TOME_TIN { thawedlib_tome, ... } ))
=>
case (do_thawedlib_tome_import thawedlib_tome)
#
NULL => do_thawedlib_tome_tin tome_tin;
THE vex => vex;
esac;
do_tome_tin (sg::TOME_IN_FROZENLIB { frozenlib_tome_tin => sg::FROZENLIB_TOME_TIN tome_tin, ... })
=>
do_frozenlib_tome tome_tin.frozenlib_tome;
end;
fun import_export (fat_tome: lg::Fat_Tome)
=
#1 (gen_filter' (do_masked_tome (fat_tome.masked_tome_thunk ()), fat_tome.exports_mask));
iel = # "iel" == "import export list"... ?
sym::fold_backward
(\\ (ie, l)
=
import_export ie ! l
)
[]
catalog;
export = gen_merge iel;
( pg::GRAPH { imports => spm::vals_list *imports,
defs => all_namings (),
export
},
spm::keys_list *imports
);
};
end;
};
end;
## (C) 2001 Lucent Technologies, Bell Labs
## author: Matthias Blume (blume@research.bell-labs.com)
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.