## private-makelib-tools.pkg
#
# Private interface to makelib's tools mechanism.
# It lacks certain public features implemented by tools_g
# but provides other, non-public routines such as "expand".
# Compiled by:
# src/app/makelib/makelib.sublib### "Klingon software is not "released".
### It escapes, leaving behind a bloody
### trail of QA people."
stipulate
package ad = anchor_dictionary; # anchor_dictionary is from src/app/makelib/paths/anchor-dictionary.pkg package bc = basic_control; # basic_control is from src/lib/compiler/front/basics/main/basic-control.pkg package ci = global_control_index; # global_control_index is from src/lib/global-controls/global-control-index.pkg package ctl = global_control; # global_control is from src/lib/global-controls/global-control.pkg package lst = list; # list is from src/lib/std/src/list.pkg package mvi = makelib_version_intlist; # makelib_version_intlist is from src/app/makelib/stuff/makelib-version-intlist.pkg package shm = sharing_mode; # sharing_mode is from src/app/makelib/stuff/sharing-mode.pkg package spm = source_path_map; # source_path_map is from src/app/makelib/paths/source-path-map.pkg package stm = string_map; # string_map is from src/lib/src/string-map.pkgherein
# This package is referenced (only) in:
#
# src/app/makelib/stuff/raw-libfile.pkg # src/app/makelib/parse/libfile.grammar
# src/app/makelib/parse/libfile-grammar-actions.pkg # src/app/makelib/tools/main/tools-g.pkg #
package private_makelib_tools
: (weak) Private_Makelib_Tools # Private_Makelib_Tools is from src/app/makelib/tools/main/private-makelib-tools.api {
Ilk = String;
File_Path = ad::File;
Dir_Path = ad::Dir_Path;
Renamings = ad::Renamings; # MUSTDIE
native_spec = ad::os_string_relative;
native_pre_spec = ad::os_string_basename_relative;
srcpath = ad::file;
augment = ad::extend;
exception TOOL_ERROR { tool: String,
msg: String
};
Pathmaker = Void -> Dir_Path;
Fnspec
=
{ name: String,
make_path: Pathmaker
};
Tool_Option
= STRING Fnspec
| SUBOPTS { name: String,
tool_options: Tool_Options
}
withtype
Tool_Options = List( Tool_Option );
Tooloptcvt
=
Null_Or( Tool_Options ) ->
Null_Or( Tool_Options );
Spec
=
{ name: String,
make_path: Pathmaker,
#
ilk: Null_Or( Ilk ),
tool_options: Null_Or( Tool_Options ),
#
derived: Bool
};
Inlining
=
Null_Or( Null_Or( Int ) );
Controller
=
{ save_controller_state: Void -> Void -> Void,
set: Void -> Void
};
Ml_Parameters
=
{ share: shm::Request,
pre_compile_code: Null_Or(String),
postcompile_code: Null_Or(String),
split: Inlining,
noguid: Bool,
is_local: Bool,
controllers: List( Controller )
};
Makelib_Parameters
=
{ version: Null_Or( mvi::Makelib_Version_Intlist )
, renamings: Renamings # MUSTDIE
};
Expansion
=
{ source_files: List( (File_Path, Ml_Parameters) ),
makelib_files: List( (File_Path, Makelib_Parameters) ),
sources: List( (File_Path, { ilk: String, derived: Bool }) )
};
Partial_Expansion
=
(Expansion, List( Spec ));
Rulefn
=
Void -> Partial_Expansion;
Rulecontext
=
Rulefn -> Partial_Expansion;
Rule
=
{ spec: Spec,
context: Rulecontext,
native2pathmaker: String -> Pathmaker,
default_ilk_of: Fnspec -> Null_Or( Ilk ),
sysinfo: { get_makelib_preprocessor_symbol_value: String -> Null_Or( Int ),
platform: String
}
}
->
Partial_Expansion;
Gcarg = { name: String,
make_filename: Void -> String
};
Index = { ilks: Ref( stm::Map( Rule ) ),
filename_suffix_classifiers: Ref( String -> Null_Or( Ilk ) ) ,
general_filename_classifiers: Ref( Gcarg -> Null_Or( Ilk ) )
};
fun layer (get1, get2) s
=
case (get1 s)
#
NULL => get2 s;
x => x;
esac;
fun make_index ()
=
{ ilks => REF stm::empty,
filename_suffix_classifiers => REF (\\ _ = NULL),
general_filename_classifiers => REF (\\ _ = NULL)
}
:
Index;
# Three indices:
#
# 1. global: Where globally available tools are noted and found.
#
# 2. local: Where locally available tools are found;
# the local index is set anew every time "expand"
# is being called; each instance of a local registry belongs
# to one description file that is being processed.
#
# 3. plugin indices:
# Mapping from tool implementations (indexed
# by their respective description files) to that tool's
# index. This is where local tools register themselves;
# the rule for the "tool" ilk causes the tool to register
# itself if it has not already done so and then merges
# the contents of the tool's index into the current
# local index.
#
# These complications exist because tools
# register themselves via side-effects.
#
global_index
=
make_index ();
my local_index: Ref( Index ) # XXX SUCKO FIXME More icky thread-hostile mutable global state.
=
REF (make_index ());
my plugin_indices: Ref( spm::Map( Index ) ) # XXX SUCKO FIXME More icky thread-hostile mutable global state.
=
REF spm::empty;
current_plugin = ((REF NULL): Ref( Null_Or( ad::File ) )); # XXX SUCKO FIXME More icky thread-hostile mutable global state.
stipulate
fun index select convert s
=
{ get = convert o (*_) o select;
#
layer (get *local_index, get global_index) s;
};
fun curry f x y
=
f (x, y);
herein
ilks = index .ilks (curry stm::get);
filename_suffix_classifiers = index .filename_suffix_classifiers (\\ x = x);
general_filename_classifiers = index .general_filename_classifiers (\\ x = x);
end;
Filename_Classifier
#
= FILENAME_SUFFIX_CLASSIFIER String -> Null_Or( Ilk )
| GENERAL_FILENAME_CLASSIFIER Gcarg -> Null_Or( Ilk )
;
fun standard_filename_suffix_classifier { suffix, ilk }
=
FILENAME_SUFFIX_CLASSIFIER
(\\ e
=
if (suffix == e) THE ilk;
else NULL;
fi
);
stipulate
fun upd select augment
=
{ rf = select case *current_plugin # "rf" might be "ref".
#
NULL => global_index;
#
THE p => case (spm::get (*plugin_indices, p))
#
THE r => r;
#
NULL =>
{ r = make_index ();
plugin_indices
:=
spm::set (*plugin_indices, p, r);
r;
};
esac;
esac;
rf := augment *rf;
};
herein
fun note_ilk (ilk, rule)
=
upd .ilks (\\ index = stm::set (index, ilk, rule));
fun note_filename_classifier (FILENAME_SUFFIX_CLASSIFIER c)
=>
upd .filename_suffix_classifiers (\\ c' = layer (c, c'));
note_filename_classifier (GENERAL_FILENAME_CLASSIFIER c)
=>
upd .general_filename_classifiers (\\ c' = layer (c, c'));
end;
fun transfer_local p
=
{ lr = *local_index;
case (spm::get (*plugin_indices, p))
#
NULL => ();
#
THE pr => { fun upd select join
=
select lr := join (*(select pr), *(select lr));
upd .ilks (stm::union_with #1);
upd .filename_suffix_classifiers layer;
upd .general_filename_classifiers layer;
};
esac;
};
fun with_plugin p thunk
=
safely::do
{
open_it => {. *current_plugin
then
current_plugin := THE p;
},
close_it => \\ prev = { transfer_local p;
current_plugin := prev;
},
cleanup => \\ _ = ()
}
(\\ _ = thunk ());
end;
Extension_Style
= EXTEND List( (String, Null_Or(Ilk), Tooloptcvt))
| REPLACE (List(String), List ((String, Null_Or(Ilk), Tooloptcvt)))
;
fun extend_filename (EXTEND l) (f, too)
=>
map
(\\ (s, co, toc) = (cat [f, ".", s], co, toc too))
l;
extend_filename (REPLACE (ol, nl)) (f, too)
=>
{ (winix__premicrothread::path::split_base_ext f)
->
{ base, ext };
fun join b (e, co, toc)
=
(winix__premicrothread::path::join_base_ext { base => b, ext => THE e }, co, toc too);
fun gen b
=
map (join b) nl;
fun same_ext (e1: String) (e2: String)
=
e1 == e2;
case ext
#
NULL => gen base;
#
THE e => if (lst::exists (same_ext e) ol) gen base;
else gen f;
fi;
esac;
};
end;
stipulate
fun timex f
=
(winix__premicrothread::file::last_file_modification_time f, TRUE)
except
_ = (time::zero_time, FALSE);
my (<) = time::(<);
fun older_than t f
=
winix__premicrothread::file::last_file_modification_time f < t;
fun cannot_access tool f
=
raise exception TOOL_ERROR { tool, msg => "cannot access " + f };
herein
fun outdated tool (l, f)
=
{ (timex f) -> (ftime, fexists);
#
(lst::exists (older_than ftime) l)
except
_ = if fexists TRUE;
else cannot_access tool f; fi;
};
fun outdated' tool { source_file_name, timestamp_file_name, target_file_name }
=
{ (timex source_file_name) -> (source_t, source_e);
(timex target_file_name) -> (target_t, target_e);
#
if (not source_e)
#
if target_e FALSE;
else cannot_access tool source_file_name;
fi;
else
if target_e
#
(timex timestamp_file_name)
->
(timestamp_t, timestamp_e);
if timestamp_e timestamp_t < source_t;
else target_t < source_t;
fi;
else
TRUE;
fi;
fi;
};
end;
open_text_output
=
autodir::open_text_output;
make_all_directories_on_path
=
autodir::make_all_directories_on_path;
fun globally load_plugin arg
=
safely::do
{
open_it => {. *current_plugin
then
current_plugin := NULL;
},
close_it => \\ prev = current_plugin := prev,
cleanup => \\ _ = ()
}
(\\ _ = load_plugin arg);
# Query default ilk
#
fun default_ilk_of load_plugin (s: Fnspec)
=
{ p = s.name;
make_filename = ad::os_string_basename o .make_path s;
gcarg = { name => p, make_filename };
fun filename_suffix_gen_check e
=
case (filename_suffix_classifiers e)
#
THE c => THE c;
NULL => general_filename_classifiers gcarg;
esac;
case (winix__premicrothread::path::ext p)
#
THE e
=>
case (filename_suffix_gen_check e)
#
THE c => THE c;
#
NULL
=>
{ plugin = cat ["$/", e, "-ext.lib"];
if (globally load_plugin plugin) filename_suffix_gen_check e;
else NULL;
fi;
};
esac;
NULL => general_filename_classifiers gcarg;
esac;
};
fun parse_options { tool, keywords, tool_options }
=
loop (tool_options, stm::empty, [])
where
fun err m
=
raise exception TOOL_ERROR { tool, msg => m };
fun is_kw kw
=
lst::exists
(\\ kw' = kw == kw')
keywords;
fun loop ([], m, ro)
=>
{ matches => \\ kw = stm::get (m, kw),
remaining_options => reverse ro
};
loop (STRING { name, ... } ! t, m, ro)
=>
loop (t, m, name ! ro);
loop (SUBOPTS { name, tool_options } ! t, m, ro)
=>
if (not (is_kw name))
#
raise exception err (cat ["keyword option `", name, "' not recognized"]);
else
case (stm::get (m, name))
#
THE _ => err (cat ["keyword option `", name,
"' specified more than once"]);
NULL => loop (t, stm::set (m, name, tool_options), ro);
esac;
fi;
end;
end;
fun ml_rule enforce_lazy
{
spec,
context,
native2pathmaker,
default_ilk_of,
sysinfo
}
=
{ spec -> { name, make_path, tool_options => oto, derived, ... } : Spec;
tool = "pkg";
fun err s = raise exception TOOL_ERROR { tool, msg => s };
fun fail s = raise exception DIE ("(SML Tool) " + s);
kw_pre_compile_code = "pre_compile_code";
kw_postcompile_code = "postcompile_code";
kw_with = "with";
kw_lambdasplit = "lambdasplit";
kw_noguid = "noguid";
kw_local = "local";
kw_lazy = "lazy";
use_default = NULL;
suggest = THE;
lazy_controller
=
{ save_controller_state
=>
{. orig = *global_controls::lazy_is_a_keyword;
#
{. global_controls::lazy_is_a_keyword := orig; };
},
set =>
{. global_controls::lazy_is_a_keyword := TRUE; }
};
my (srq, pre_compile_code, postcompile_code, inlining, noguid, is_local, controllers)
=
case oto
#
NULL => ( shm::DONT_CARE,
NULL,
NULL,
use_default,
FALSE,
FALSE,
if enforce_lazy [lazy_controller];
else [];
fi
);
THE to
=>
{ my { matches, remaining_options }
=
parse_options
{
tool,
keywords => [ kw_pre_compile_code,
kw_postcompile_code,
kw_with,
kw_lambdasplit
],
tool_options => to
};
fun is_sharing_specification "shared" => TRUE;
is_sharing_specification "private" => TRUE;
is_sharing_specification _ => FALSE;
end;
my (sh_options, remaining_options)
=
lst::partition
is_sharing_specification
remaining_options;
srq = case sh_options # "srq" might be "sharing_request".
#
[] => shm::DONT_CARE;
["shared"] => shm::SHARED;
["private"] => shm::PRIVATE;
_ => err "invalid option (s)";
esac;
fun is_kw kw s
=
string::compare (kw, s) == EQUAL;
my (locals, remaining_options)
=
lst::partition (is_kw kw_local) remaining_options;
my (noguids, remaining_options)
=
lst::partition (is_kw kw_noguid) remaining_options;
my (lazies, remaining_options)
=
lst::partition (is_kw kw_lazy) remaining_options;
is_local = not (lst::null locals);
noguid = not (lst::null noguids);
lazy_is_a_keyword
=
enforce_lazy or not (lst::null lazies);
if (not (lst::null remaining_options))
#
err (cat
( "invalid option (s): "
!
fold_backward
(\\ (x, l) = " " ! x ! l)
[]
remaining_options
)
);
fi;
pre_compile_code
=
case (matches kw_pre_compile_code)
#
NULL => NULL;
THE [] => NULL;
THE [STRING s] => THE s.name;
#
_ => err "invalid pre_compile_code spec";
esac;
postcompile_code
=
case (matches kw_postcompile_code)
#
NULL => NULL;
THE [] => NULL;
THE [STRING s] => THE s.name;
_ => err "invalid postcompile_code spec";
esac;
controllers
=
case (matches kw_with)
#
NULL => [];
THE subopts
=>
loop (subopts, [])
where
fun fields c s
=
string::fields
(\\ c' = c == c')
s;
fun set (c, v)
=
ctl::set' (c, v)
except
ctl::BAD_VALUE_SYNTAX vse
=
fail (cat ["error setting \
\ controller: \
\unable to parse \
\value `",
vse.value, "' for ",
vse.control_name, " : ",
vse.name_of_type
] );
fun mk (n, v)
=
case (ci::find_control bc::top_index (fields '.' n))
#
THE c => { save_controller_state => {. ctl::save_controller_state c; },
#
set => set (c, v)
};
NULL => err ("no such control: " + n);
esac;
fun loop ([], a)
=>
a;
loop (STRING nv ! r, a)
=>
case (fields '=' nv.name)
[n, v] => loop (r, mk (n, v) ! a);
[n] => loop (r, mk (n, "true") ! a);
_ => err "invalid controller spec";
esac;
loop (SUBOPTS { name => "name",
tool_options => [STRING n] } !
SUBOPTS { name => "value",
tool_options => [STRING v] } ! r,
a)
=>
loop (r, mk (n.name, v.name) ! a);
loop (SUBOPTS { name => "name",
tool_options => [STRING n] } ! r,
a)
=>
loop (r, mk (n.name, "true") ! a);
loop _
=>
err "invalid controller spec";
end;
end;
esac;
inlining
=
{ fun invalid ()
=
err "invalid lambdasplit spec";
fun spec (s: Fnspec)
=
case (lsplit_arg::arg s.name)
#
THE ls => ls;
NULL => invalid ();
esac;
case (matches kw_lambdasplit)
#
NULL => use_default;
THE [] => suggest (THE 0); # == "on"
THE [STRING x] => spec x;
_ => invalid ();
esac;
};
controllers
=
if lazy_is_a_keyword lazy_controller ! controllers;
else controllers;
fi;
(srq, pre_compile_code, postcompile_code, inlining, noguid, is_local, controllers);
};
esac;
p = srcpath (make_path ());
sparam # "sparam" may be "(per-)sourcefile parameters".
=
{ share => srq,
split => inlining,
#
pre_compile_code,
postcompile_code,
#
noguid,
is_local,
controllers
};
( { source_files => [(p, sparam)],
sources => [(p, { ilk => "sml", derived } )],
makelib_files => []
},
[]
);
};
fun makelib_rule { spec: Spec, context, native2pathmaker, default_ilk_of, sysinfo }
=
{ spec -> { name, make_path, tool_options => oto, derived, ... };
fun err m
=
raise exception TOOL_ERROR { tool => "cm", msg => m };
fun process_options (rb, vrq, [])
=>
(rb, vrq);
process_options (_, _, STRING _ ! _)
=>
err "ill-formed option";
process_options (rb, vrq, SUBOPTS { name => "version", tool_options } ! r)
=>
{ fun ill ()
=
err "ill-formed version specification";
case (vrq, tool_options)
#
(THE _, _)
=>
err "version cannot be specified more than once";
#
(NULL, [STRING { name, ... } ])
=>
case (mvi::from_string name)
#
NULL => ill ();
THE v => process_options (rb, THE v, r);
esac;
_ => ill ();
esac;
};
process_options (rb, vrq, SUBOPTS { name => "bind", tool_options } ! r)
=>
case tool_options
#
[ SUBOPTS { name => "anchor", tool_options => [STRING { name, ... } ] },
SUBOPTS { name => "value", tool_options => [STRING v] }
]
=>
process_options ( { anchor => name, value => v.make_path () }
! rb,
vrq, r);
_ =>
err "ill-formed bind specification";
esac;
process_options (_, _, SUBOPTS { name, ... } ! _)
=>
err ("unknown option: " + name);
end;
my (rb, vrq) # XXX BUGGO KILLME 'rb' is old anchor rebindings which can die.
=
case oto
#
NULL => ([], NULL);
THE l => process_options ([], NULL, l);
esac;
p = srcpath (make_path ());
cparams
=
{ version => vrq
, renamings => reverse rb # MUSTDIE
};
( { source_files => [],
sources => [(p, { ilk => "cm", derived } )],
makelib_files => [(p, cparams)]
},
[]
);
};
fun expand
{
error: String -> Void,
local_index => lr,
spec: Spec,
path_root: ad::Path_Root,
load_plugin: ad::Path_Root -> String -> Bool,
sysinfo
}
=
{ dummy
=
( { source_files => [],
makelib_files => [],
sources => []
},
[]
);
fun norule _
=
dummy;
fun native2pathmaker file_path ()
=
ad::from_native
{ plaint_sink => error }
{ path_root, file_path };
fun ilk2rule ilk
=
case (ilks ilk)
#
THE rule
=>
rule;
NULL
=>
{ base = cat ["$/", ilk, "-tool"];
plugin
=
winix__premicrothread::path::join_base_ext
{
base,
ext => THE "lib"
};
fun complain ()
=
{ error (cat ["unknown ilk: ", ilk]);
norule;
};
if (globally (load_plugin path_root) plugin)
#
case (ilks ilk)
#
THE rule => rule;
NULL => complain ();
esac;
else
complain ();
fi;
};
esac;
fun expand1 (spec as { name, make_path, ilk => co, ... } )
=
{ fns = { name, make_path };
rule
=
case co
#
THE c0
=>
ilk2rule (string::map char::to_lower c0);
NULL
=>
case (default_ilk_of (load_plugin path_root) fns)
#
THE c => ilk2rule c;
#
NULL => { error (cat ["unable to classify: ", name]);
norule;
};
esac;
esac;
fun rcontext rf # "rf" might be "rule function"
=
{ dir = ad::os_string_dir path_root;
cwd = winix__premicrothread::file::current_directory ();
safely::do
{
open_it => {. winix__premicrothread::file::change_directory dir; },
close_it => {. winix__premicrothread::file::change_directory cwd; },
cleanup => \\ _ = ()
}
rf;
};
rule {
spec,
sysinfo,
native2pathmaker,
context => rcontext,
default_ilk_of => default_ilk_of (load_plugin path_root)
}
except
TOOL_ERROR { tool, msg }
=
{ error (cat ["tool \"", tool, "\" failed: ", msg]);
dummy;
};
};
fun loop ([], expansion)
=>
expansion;
loop (item ! items, { source_files, makelib_files, sources })
=>
{ (expand1 item)
->
( { source_files => source_files',
makelib_files => makelib_files',
sources => sources'
},
il
);
loop ( il @ items,
{ source_files => source_files @ source_files',
makelib_files => makelib_files @ makelib_files',
sources => sources @ sources'
}
);
};
end;
safely::do
{
open_it => {. *local_index
then
local_index := lr;
},
close_it => {. local_index := #prev; },
cleanup => \\ _ = ()
}
(\\ _
=
loop (
[spec],
{ source_files => [],
makelib_files => [],
sources => []
}
)
);
}; # fun expand
stipulate
fun suffix (suffix, ilk)
=
note_filename_classifier
#
(standard_filename_suffix_classifier { suffix, ilk } );
herein
my _ =
note_ilk ("sml", ml_rule FALSE); my _ =
note_ilk ("lazy-mythryl", ml_rule TRUE); my _ =
note_ilk ("cm", makelib_rule); my _ =
note_ilk ("makelib", makelib_rule); my _ =
suffix ("lib", "makelib"); my _ = # foo.lib files contain Mythryl library definitions.
suffix ("sublib", "makelib"); my _ = # foo.sublib files contain Mythryl sublibrary definitions.
suffix ("api", "sml"); my _ = # foo.api files contain Mythryl sourcecode.
suffix ("pkg", "sml"); my _ = # foo.pkg files contain Mythryl sourcecode.
suffix ("class", "sml"); my _ = # foo.class files contain Mythryl sourcecode.
suffix ("lazy-api", "lazy-mythryl"); my _ = # foo.lazy-api files contain Mythryl sourcecode with laziness support. (Unsupported, undocumented functionality.)
suffix ("lazy-pkg", "lazy-mythryl"); # foo.lazy-pkg files contain Mythryl sourcecode with laziness support. (Unsupported, undocumented functionality.)
end;
};
end;
# Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
# (C) 2000 Lucent Technologies, Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.