open BasicIO Nonstdio Fnlib Config PP; exception Toplevel;exception EndOfFile;exception LexicalError of string * int * int; val toplevel = ref false; val pp_out = mk_ppstream{ linewidth = 79, flush = fn() => flush_out std_out, consumer = outputc std_out}; fun msgCBlock offset = begin_block pp_out CONSISTENT offset;fun msgIBlock offset = begin_block pp_out INCONSISTENT offset;fun msgEBlock() = end_block pp_out;fun msgBreak size_offset = add_break pp_out size_offset;fun msgClear() = clear_ppstream pp_out;fun msgFlush() = flush_ppstream pp_out; val msgString = add_string pp_out; fun msgChar (i : char) = msgString (String.str i);local prim_val sml_string_of_int : int -> string = 1 "sml_string_of_int"; prim_val sml_string_of_float : real -> string = 1 "sml_string_of_float"; prim_val sml_hexstring_of_word : word -> string = 1 "sml_hexstring_of_word";in fun msgInt (i : int) = msgString (sml_string_of_int i); fun msgReal (r : real) = msgString (sml_string_of_float r); fun msgWord (w : word) = msgString (sml_hexstring_of_word w);end fun msgEOL() = add_newline pp_out; fun msgPrompt s = (if !toplevel then msgString toplevel_output_prompt else msgString batch_output_prompt; msgString s); fun msgContPrompt s = (if !toplevel then msgString toplevel_output_cont_prompt else msgString batch_output_cont_prompt; msgString s); fun errPrompt s = (if !toplevel then msgString toplevel_error_prompt else msgString batch_error_prompt; msgString s); val msgStyle = ref "default"; (* Handling files and directories *) val path_library = ref "";val load_path = ref ([] : string list); (* This MUST be ref false; the default (value polymorphism/imperative types) * is set in files Mainc.sml and Maint.sml instead: *)val value_polymorphism = ref false; fun cannot_find filename = raise (Fail ("Cannot find file "^filename)); fun find_in_path filename = if file_exists filename then filename else if Filename.is_absolute filename then cannot_find filename else let fun h [] = cannot_find filename | h (a::rest) = let val b = Filename.concat a filename in if file_exists b then b else h rest end in h (!load_path) end; fun remove_file f = Miscsys.remove f handle SysErr _ => (); (* ---------- *) datatype Lab = INTlab of int | STRINGlab of string; type 'a Row = (Lab * 'a) list; fun printLab (STRINGlab s) = msgString s | printLab (INTlab i) = msgInt i; val labOne = INTlab 1and labTwo = INTlab 2; fun isPairRow [(INTlab 1, _), (INTlab 2, _)] = true | isPairRow [(INTlab 2, _), (INTlab 1, _)] = true | isPairRow _ = false; fun isTupleRow' n [] = true | isTupleRow' n (((INTlab i), _) :: fs) = if n = i then isTupleRow' (n+1) fs else false | isTupleRow' n _ = false fun isTupleRow fs = (List.length fs <> 1) andalso (isTupleRow' 1 fs); fun mkPairRow x1 x2 = [(labOne, x1), (labTwo, x2)]; fun mkTupleRow' n [] = [] | mkTupleRow' n (x :: xs) = (INTlab n, x) :: mkTupleRow' (n+1) xs; fun mkTupleRow xs = mkTupleRow' 1 xs; fun lt_lab (STRINGlab s1) (STRINGlab s2) = s1 < s2 | lt_lab (STRINGlab _) (INTlab _) = true | lt_lab (INTlab _) (STRINGlab _) = false | lt_lab (INTlab i1) (INTlab i2) = i1 < i2; fun insertField (lab, x) fields = case fields of [] => [(lab, x)] | (lab', x') :: rest => if lt_lab lab lab' then (lab, x) :: fields else if lt_lab lab' lab then (lab', x') :: insertField (lab, x) rest else fatalError "insertField"; fun sortRow row = foldL insertField [] row; (* --- Local environments --- *) datatype ('a, 'b) Env = NILenv | BNDenv of 'a * 'b * ('a, 'b) Env | TOPenv of ('a, 'b) Hasht.t * ('a, 'b) Env | COMPenv of ('a, 'b) Env * ('a, 'b) Env; fun plusEnv NILenv env2 = env2 | plusEnv env1 NILenv = env1 | plusEnv env1 (BNDenv(k, v, NILenv)) = BNDenv(k, v, env1) | plusEnv env1 env2 = COMPenv(env2, env1); fun lookupEnv env key = let val rec search = fn NILenv => raise Subscript | BNDenv(k, v, env) => if key = k then v else search env | TOPenv(x, env) => (Hasht.find x key handle Subscript => search env) | COMPenv(env1, env2) => (search env1 handle Subscript => search env2) in search env end; fun bindInEnv env k v = BNDenv(k, v, env);fun bindTopInEnv env x = TOPenv(x, env); fun mk1Env k v = BNDenv(k, v, NILenv);fun mk1TopEnv x = TOPenv(x, NILenv); fun revEnvAcc NILenv acc = acc | revEnvAcc (BNDenv(k, v, env)) acc = revEnvAcc env (BNDenv(k, v, acc)) | revEnvAcc (TOPenv(x, env)) acc = revEnvAcc env (TOPenv(x, acc)) | revEnvAcc (COMPenv(env1, env2)) acc = revEnvAcc env2 (revEnvAcc env1 acc); fun revEnv env = revEnvAcc env NILenv; fun traverseEnv action env = let fun traverse NILenv = () | traverse (BNDenv(k, v, env)) = (action k v; traverse env) | traverse (TOPenv(x, env)) = (Hasht.apply action x; traverse env) | traverse (COMPenv(env1, env2)) = (traverse env1; traverse env2) in traverse env end; fun mapEnv f env0 = case env0 of NILenv => NILenv | BNDenv(k, v, env) => BNDenv(k, f k v, mapEnv f env) | TOPenv(x, env) => (* This can be improved by simply making a copy of the hash table *) let val newx = Hasht.new 17 fun ins k v = Hasht.insert newx k (f k v) in Hasht.apply ins x; TOPenv(newx, mapEnv f env) end | COMPenv(env1, env2) => COMPenv(mapEnv f env1, mapEnv f env2); fun foldEnv f u env0 = case env0 of NILenv => u | BNDenv(k, v, env) => f k v (foldEnv f u env) | TOPenv(x, env) => Hasht.fold f (foldEnv f u env) x | COMPenv(env1, env2) => foldEnv f (foldEnv f u env2) env1; fun mkHashEnv n env = if n < 7 then env else let val hashenv = Hasht.new n in traverseEnv (Hasht.insert hashenv) (revEnv env); mk1TopEnv hashenv end fun cleanEnv env = foldEnv (fn k => fn v => fn cont => fn acc => if (member k acc) then cont acc else bindInEnv (cont (k::acc)) k v) (fn acc => NILenv) env []; local fun insertInEnv (k:string) v env = case env of NILenv => BNDenv(k,v,NILenv) | BNDenv(k', v', env') => if k = k' then BNDenv(k,v,env') else if k < k' then BNDenv(k',v',insertInEnv k v env') else BNDenv(k,v,env) | _ => fatalError "insertInEnv"in fun sortEnv env = foldEnv insertInEnv NILenv envend; fun lookupEnvWithPos size env key = (* cvr: assumes env is clean (no shadowed bindings) *) foldEnv (fn k => fn v => fn cont => fn pos => if key = k then (pos,v) else cont (pos+size(v))) (fn pos => raise Subscript) env; (* --- Stamps of compiled signatures --- *) type SigStamp = string; val char_star = Char.chr 42;val dummySigStamp = CharVector.tabulate(22, fn _ => char_star); (* This table is used by `load' to prevent mismatching *)(* versions of compiled units from being loaded, and also *)(* to prevent the same unit from being loaded twice. *) val watchDog = ref (Hasht.new 17 : (string, SigStamp) Hasht.t); (* The list of automatically preloaded units. *)(* Some of them are also preopened. *) val preloadedUnits = ref ([] : string list);val preopenedPreloadedUnits = ref ([] : string list); (* compilation mode *) datatype Mode = STRmode | TOPDECmode; val currentMode = ref STRmode; (* vanilla SML compliance levels *) datatype Compliance = Orthodox (* SML only, reject extensions *) | Conservative (* warn of any extensions *) | Liberal (* anything goes *); val currentCompliance = ref Liberal;
open BasicIO Nonstdio Fnlib Config PP;
exception Toplevel;
exception EndOfFile;
exception LexicalError of string * int * int;
val toplevel = ref false;
val pp_out = mk_ppstream
{
linewidth = 79,
flush = fn() => flush_out std_out,
consumer = outputc std_out
};
fun msgCBlock offset = begin_block pp_out CONSISTENT offset;
fun msgIBlock offset = begin_block pp_out INCONSISTENT offset;
fun msgEBlock() = end_block pp_out;
fun msgBreak size_offset = add_break pp_out size_offset;
fun msgClear() = clear_ppstream pp_out;
fun msgFlush() = flush_ppstream pp_out;
val msgString = add_string pp_out;
fun msgChar (i : char) = msgString (String.str i);
local
prim_val sml_string_of_int : int -> string = 1 "sml_string_of_int";
prim_val sml_string_of_float : real -> string = 1 "sml_string_of_float";
prim_val sml_hexstring_of_word : word -> string = 1 "sml_hexstring_of_word";
in
fun msgInt (i : int) = msgString (sml_string_of_int i);
fun msgReal (r : real) = msgString (sml_string_of_float r);
fun msgWord (w : word) = msgString (sml_hexstring_of_word w);
end
fun msgEOL() = add_newline pp_out;
fun msgPrompt s =
(if !toplevel then msgString toplevel_output_prompt
else msgString batch_output_prompt;
msgString s)
;
fun msgContPrompt s =
(if !toplevel then msgString toplevel_output_cont_prompt
else msgString batch_output_cont_prompt;
msgString s)
;
fun errPrompt s =
(if !toplevel then msgString toplevel_error_prompt
else msgString batch_error_prompt;
msgString s)
;
val msgStyle = ref "default";
(* Handling files and directories *)
val path_library = ref "";
val load_path = ref ([] : string list);
(* This MUST be ref false; the default (value polymorphism/imperative types)
* is set in files Mainc.sml and Maint.sml instead:
*)
val value_polymorphism = ref false;
fun cannot_find filename =
raise (Fail ("Cannot find file "^filename))
;
fun find_in_path filename =
if file_exists filename then
filename
else if Filename.is_absolute filename then
cannot_find filename
else
let fun h [] =
cannot_find filename
| h (a::rest) =
let val b = Filename.concat a filename in
if file_exists b then b else h rest
end
in h (!load_path) end
;
fun remove_file f =
Miscsys.remove f
handle SysErr _ => ()
;
(* ---------- *)
datatype Lab =
INTlab of int
| STRINGlab of string
;
type 'a Row = (Lab * 'a) list;
fun printLab (STRINGlab s) = msgString s
| printLab (INTlab i) = msgInt i
;
val labOne = INTlab 1
and labTwo = INTlab 2
;
fun isPairRow [(INTlab 1, _), (INTlab 2, _)] = true
| isPairRow [(INTlab 2, _), (INTlab 1, _)] = true
| isPairRow _ = false
;
fun isTupleRow' n [] = true
| isTupleRow' n (((INTlab i), _) :: fs) =
if n = i then isTupleRow' (n+1) fs else false
| isTupleRow' n _ = false
fun isTupleRow fs =
(List.length fs <> 1) andalso (isTupleRow' 1 fs)
;
fun mkPairRow x1 x2 = [(labOne, x1), (labTwo, x2)];
fun mkTupleRow' n [] = []
| mkTupleRow' n (x :: xs) =
(INTlab n, x) :: mkTupleRow' (n+1) xs
;
fun mkTupleRow xs = mkTupleRow' 1 xs;
fun lt_lab (STRINGlab s1) (STRINGlab s2) = s1 < s2
| lt_lab (STRINGlab _) (INTlab _) = true
| lt_lab (INTlab _) (STRINGlab _) = false
| lt_lab (INTlab i1) (INTlab i2) = i1 < i2
;
fun insertField (lab, x) fields =
case fields of
[] => [(lab, x)]
| (lab', x') :: rest =>
if lt_lab lab lab' then
(lab, x) :: fields
else if lt_lab lab' lab then
(lab', x') :: insertField (lab, x) rest
else
fatalError "insertField"
;
fun sortRow row = foldL insertField [] row;
(* --- Local environments --- *)
datatype ('a, 'b) Env
= NILenv
| BNDenv of 'a * 'b * ('a, 'b) Env
| TOPenv of ('a, 'b) Hasht.t * ('a, 'b) Env
| COMPenv of ('a, 'b) Env * ('a, 'b) Env
;
fun plusEnv NILenv env2 = env2
| plusEnv env1 NILenv = env1
| plusEnv env1 (BNDenv(k, v, NILenv)) = BNDenv(k, v, env1)
| plusEnv env1 env2 = COMPenv(env2, env1)
;
fun lookupEnv env key =
let val rec search = fn
NILenv => raise Subscript
| BNDenv(k, v, env) =>
if key = k then v else search env
| TOPenv(x, env) =>
(Hasht.find x key handle Subscript => search env)
| COMPenv(env1, env2) =>
(search env1 handle Subscript => search env2)
in search env end
;
fun bindInEnv env k v = BNDenv(k, v, env);
fun bindTopInEnv env x = TOPenv(x, env);
fun mk1Env k v = BNDenv(k, v, NILenv);
fun mk1TopEnv x = TOPenv(x, NILenv);
fun revEnvAcc NILenv acc = acc
| revEnvAcc (BNDenv(k, v, env)) acc =
revEnvAcc env (BNDenv(k, v, acc))
| revEnvAcc (TOPenv(x, env)) acc =
revEnvAcc env (TOPenv(x, acc))
| revEnvAcc (COMPenv(env1, env2)) acc =
revEnvAcc env2 (revEnvAcc env1 acc)
;
fun revEnv env = revEnvAcc env NILenv;
fun traverseEnv action env =
let fun traverse NILenv = ()
| traverse (BNDenv(k, v, env)) =
(action k v; traverse env)
| traverse (TOPenv(x, env)) =
(Hasht.apply action x; traverse env)
| traverse (COMPenv(env1, env2)) =
(traverse env1; traverse env2)
in traverse env end
;
fun mapEnv f env0 =
case env0 of
NILenv => NILenv
| BNDenv(k, v, env) =>
BNDenv(k, f k v, mapEnv f env)
| TOPenv(x, env) =>
(* This can be improved by simply making a copy of the hash table *)
let val newx = Hasht.new 17
fun ins k v = Hasht.insert newx k (f k v)
in
Hasht.apply ins x;
TOPenv(newx, mapEnv f env)
end
| COMPenv(env1, env2) =>
COMPenv(mapEnv f env1, mapEnv f env2)
;
fun foldEnv f u env0 =
case env0 of
NILenv => u
| BNDenv(k, v, env) =>
f k v (foldEnv f u env)
| TOPenv(x, env) =>
Hasht.fold f (foldEnv f u env) x
| COMPenv(env1, env2) =>
foldEnv f (foldEnv f u env2) env1
;
fun mkHashEnv n env =
if n < 7 then env
else
let val hashenv = Hasht.new n
in
traverseEnv (Hasht.insert hashenv) (revEnv env);
mk1TopEnv hashenv
end
fun cleanEnv env =
foldEnv (fn k => fn v => fn cont =>
fn acc =>
if (member k acc)
then cont acc
else bindInEnv (cont (k::acc)) k v)
(fn acc => NILenv) env [];
local
fun insertInEnv (k:string) v env =
case env of
NILenv => BNDenv(k,v,NILenv)
| BNDenv(k', v', env') =>
if k = k' then BNDenv(k,v,env')
else if k < k' then BNDenv(k',v',insertInEnv k v env')
else BNDenv(k,v,env)
| _ => fatalError "insertInEnv"
in
fun sortEnv env = foldEnv insertInEnv NILenv env
end;
fun lookupEnvWithPos size env key =
(* cvr: assumes env is clean (no shadowed bindings) *)
foldEnv (fn k => fn v => fn cont =>
fn pos => if key = k then (pos,v) else cont (pos+size(v)))
(fn pos => raise Subscript) env;
(* --- Stamps of compiled signatures --- *)
type SigStamp = string;
val char_star = Char.chr 42;
val dummySigStamp = CharVector.tabulate(22, fn _ => char_star);
(* This table is used by `load' to prevent mismatching *)
(* versions of compiled units from being loaded, and also *)
(* to prevent the same unit from being loaded twice. *)
val watchDog = ref (Hasht.new 17 : (string, SigStamp) Hasht.t);
(* The list of automatically preloaded units. *)
(* Some of them are also preopened. *)
val preloadedUnits = ref ([] : string list);
val preopenedPreloadedUnits = ref ([] : string list);
(* compilation mode *)
datatype Mode = STRmode | TOPDECmode
;
val currentMode = ref STRmode
;
(* vanilla SML compliance levels *)
datatype Compliance =
Orthodox (* SML only, reject extensions *)
| Conservative (* warn of any extensions *)
| Liberal (* anything goes *);
val currentCompliance = ref Liberal;