(* Symtable.sml : to assign numbers to global variables and so on *) local open Misc Nonstdio Obj Fnlib Config Mixture Const;in (* Hashtables for numbering objects *) type 'a numtable ={ num_cnt: int ref, (* The current number *) num_tbl: ('a, int) Hasht.t (* The table *)}; fun new_numtable size = { num_cnt = ref 0, num_tbl = Hasht.new size }; fun find_in_numtable (nt : ''a numtable) = Hasht.find (#num_tbl nt); fun enter_in_numtable (nt : ''_a numtable) key = let val c = !(#num_cnt nt) in #num_cnt nt := !(#num_cnt nt) + 1; Hasht.insert (#num_tbl nt) key c; c end; fun remove_from_numtable (nt : ''a numtable) key = Hasht.remove (#num_tbl nt) key; (* Global variables *) val global_table = ref (new_numtable 1 : (QualifiedIdent * int) numtable) and literal_table = ref ([] : (int * StructConstant) list); fun get_slot_for_variable (uid as (qualid, stamp)) = find_in_numtable (!global_table) uid handle Subscript => (let val {qual,id} = qualid val mid = longIdentAsIdent id "get_slot_for_variable" val (desc,s) = case unmangle mid of ValId s => ("Value ",s) | ModId s => ("Structure ",s) | FunId s => ("Functor ",s) in msgIBlock 0; msgEOL(); errPrompt desc; msgString qual; msgString "."; msgString s; if stamp <> 0 then (msgString "/"; msgInt stamp) else (); msgString " hasn't been defined yet"; msgEOL(); msgEBlock(); raise Toplevel end); fun get_slot_for_defined_variable (uid as (qualid, stamp)) = enter_in_numtable (!global_table) uid; fun get_slot_for_literal cst = let val c = !(#num_cnt (!global_table)) in #num_cnt(!global_table) := !(#num_cnt (!global_table)) + 1; literal_table := (c, cst) :: !literal_table; c end; fun number_of_globals () = !(#num_cnt (!global_table)); fun defineGlobalValueAlias uid uid' = let val slot = get_slot_for_variable uid' in Hasht.insert (#num_tbl (!global_table)) uid slot end; (* The exception tags *) (* ps: val unknown_exn_name = ({qual="?", id=["?"]}, 0);val exn_tag_table = ref(new_numtable 1 : (QualifiedIdent * int) numtable);val tag_exn_table = ref(Array.fromList [] : (QualifiedIdent * int) Array.array ); *) (* cvr: fun fromShortTagExnTable a = Array.tabulate ((Array.length a), (fn i => case Array.sub (a, i) of ({qual=qual,id = id},i) => ({qual=qual,id = [id]},i))); fun toShortTagExnTable a = Array.tabulate ((Array.length a), (fn i => case Array.sub (a, i) of ({qual=qual,id = [id]},i) => ({qual=qual,id = id},i))); fun get_num_of_exn (name, stamp) = Hasht.find (#num_tbl (!exn_tag_table)) (name, stamp) handle Subscript => let val c = enter_in_numtable (!exn_tag_table) (name, stamp) val len = Array.length (!tag_exn_table) in if c < len then () else let val new_len = 2 * len val new_tag_exn_table = Array.array(new_len, unknown_exn_name) in Array.copy {src = !tag_exn_table, si = 0, len = NONE, dst = new_tag_exn_table, di = 0}; tag_exn_table := new_tag_exn_table end; Array.update(!tag_exn_table, c, (name, stamp)); c end; fun get_exn_of_num tag = if tag >= Array.length (!tag_exn_table) then unknown_exn_name else Array.sub(!tag_exn_table, tag); fun defineGlobalExceptionAlias (q, (q', stamp')) = let val tag = get_num_of_exn (q', stamp') in Hasht.insert (#num_tbl (!exn_tag_table)) (q, 0) tag end;*) fun intOfTag (CONtag(n,_)) = n(* | intOfTag (EXNtag(id, stamp)) = fatalError "intOfTag" (* ps: get_num_of_exn(id, stamp) *) *); (* The C primitives *) val c_prim_table = ref (new_numtable 0 : string numtable); (* cvr: 144 merge fun set_c_primitives prim_vect = (c_prim_table := new_numtable 31; for (fn i => ignore (enter_in_numtable (!c_prim_table) (Vector.sub(prim_vect, i)))) 0 (Vector.length prim_vect - 1));*)fun set_c_primitives prim_vect = (c_prim_table := new_numtable 67; Vector.app (ignore o enter_in_numtable (!c_prim_table)) prim_vect); fun get_num_of_prim name = find_in_numtable (!c_prim_table) name handle Subscript => (msgIBlock 0; errPrompt "Unavailable C primitive: "; msgString name; msgEOL(); msgEBlock(); raise Toplevel); fun exportPublicNames uname excRenList valRenList = ((* ps: List.app defineGlobalExceptionAlias excRenList; *) List.app (fn (id, stamp) => defineGlobalValueAlias ({ qual=uname, id=[id] }, 0) ({ qual=uname, id=[id] }, stamp)) valRenList); (* Initialization *) (* ps: val normalizeExnName = fn {qual="sys", id=["Break"]} => {qual="General", id=["Interrupt"]} | {qual="sys", id=["Sys_error"]} => {qual="General", id=["SysErr"]} | {qual="exc", id=["Not_found"]} => {qual="General", id=["Subscript"]} | {qual="io", id=["End_of_file"]} => {qual="General", id=["Size"]} | {qual="exc", id=["Out_of_memory"]} => {qual="General", id=["Out_of_memory"]} | {qual="exc", id=["Invalid_argument"]} => {qual="General", id=["Invalid_argument"]} | {qual="exc", id=["Failure"]} => {qual="General", id=["Fail"]} | {qual="graphics", id=["Graphic_failure"]} => {qual="General", id=["Graphic_failure"]} | {qual="general", id=["Exception"]} => {qual="General", id=["(Exception)"]} | {qual="general", id=[id]} => {qual="General", id=[id]} | qualid => qualid; *) fun reset_linker_tables () =( global_table := new_numtable 263; literal_table := []; List.app (fn {qual, id} => ignore( get_slot_for_defined_variable (* ps: ({qual="(global)", id=[id]}, 0) *) ({qual=qual, id=[id]}, 0) )) Predef.predef_variables;(* ps: exn_tag_table := new_numtable 31; tag_exn_table := Array.array(50, unknown_exn_name); List.app (fn ({qual,id}, stamp) => ignore(get_num_of_exn (normalizeExnName {qual=qual,id = [id]}, 0))) Predef.predef_exn;*) set_c_primitives Prim_c.primitives_table); fun save_linker_tables outstream =( output_binary_int outstream (! (#num_cnt(!global_table)))(* cvr: removed output_value outstream (!exn_tag_table); output_value outstream (!tag_exn_table)*)(* cvr: added: *)(* ps: ; output_value outstream (toShortExnTagTable(!exn_tag_table)); output_value outstream (toShortTagExnTable(!tag_exn_table))(* cvr: *) *)); (* To read linker tables from the executable file *) fun load_linker_tables () = ( let val is = open_in_bin (Vector.sub(Miscsys.command_line, 0)) (* The code, data, symb, and debug indexes are located 20 bytes before the end of the bytecode file. *) val () = seek_in is (in_stream_length is - 20) val size_code = input_binary_int is val size_data = input_binary_int is val size_symb = input_binary_int is val size_debug = input_binary_int is in seek_in is (in_stream_length is - 20 - size_debug - size_symb); (* We don't need information about the internals *) (* of Moscow ML system! *) global_table := new_numtable 263; #num_cnt (!global_table) := input_binary_int is end ) handle _ => fatalError "Unable to read linker tables from bytecode"; (* Initialization *) prim_val available_primitives : unit -> string Vector.vector = 1 "available_primitives"; fun init_linker_tables () =( load_linker_tables(); (* Hasht.clear (#num_tbl (!global_table)); *) appFrom (fn slot => fn {qual,id} => Hasht.insert (#num_tbl (!global_table)) ({qual=qual,id=[id]}, 0) slot) 0 Predef.predef_variables; literal_table := []; set_c_primitives (available_primitives())); (* added -- 07Sep95 e *) fun protect_linker_tables fct = let val saved_global_table = !global_table and saved_literal_table = !literal_table and saved_c_prim_table = !c_prim_table in (fct(); global_table := saved_global_table; literal_table := saved_literal_table; c_prim_table := saved_c_prim_table ) handle x => (global_table := saved_global_table; literal_table := saved_literal_table; c_prim_table := saved_c_prim_table; raise x) end end;
(* Symtable.sml : to assign numbers to global variables and so on *)
local
open Misc Nonstdio Obj Fnlib Config Mixture Const;
in
(* Hashtables for numbering objects *)
type 'a numtable =
{
num_cnt: int ref, (* The current number *)
num_tbl: ('a, int) Hasht.t (* The table *)
};
fun new_numtable size =
{ num_cnt = ref 0, num_tbl = Hasht.new size }
;
fun find_in_numtable (nt : ''a numtable) =
Hasht.find (#num_tbl nt)
;
fun enter_in_numtable (nt : ''_a numtable) key =
let val c = !(#num_cnt nt) in
#num_cnt nt := !(#num_cnt nt) + 1;
Hasht.insert (#num_tbl nt) key c;
c
end;
fun remove_from_numtable (nt : ''a numtable) key =
Hasht.remove (#num_tbl nt) key
;
(* Global variables *)
val global_table =
ref (new_numtable 1 : (QualifiedIdent * int) numtable)
and literal_table =
ref ([] : (int * StructConstant) list)
;
fun get_slot_for_variable (uid as (qualid, stamp)) =
find_in_numtable (!global_table) uid
handle Subscript =>
(let val {qual,id} = qualid
val mid = longIdentAsIdent id "get_slot_for_variable"
val (desc,s) =
case unmangle mid of
ValId s =>
("Value ",s)
| ModId s =>
("Structure ",s)
| FunId s =>
("Functor ",s)
in
msgIBlock 0;
msgEOL();
errPrompt desc;
msgString qual; msgString "."; msgString s;
if stamp <> 0 then (msgString "/"; msgInt stamp) else ();
msgString " hasn't been defined yet"; msgEOL();
msgEBlock();
raise Toplevel
end)
;
fun get_slot_for_defined_variable (uid as (qualid, stamp)) =
enter_in_numtable (!global_table) uid
;
fun get_slot_for_literal cst =
let val c = !(#num_cnt (!global_table)) in
#num_cnt(!global_table) := !(#num_cnt (!global_table)) + 1;
literal_table := (c, cst) :: !literal_table;
c
end;
fun number_of_globals () =
!(#num_cnt (!global_table))
;
fun defineGlobalValueAlias uid uid' =
let val slot = get_slot_for_variable uid' in
Hasht.insert (#num_tbl (!global_table)) uid slot
end;
(* The exception tags *)
(* ps: val unknown_exn_name = ({qual="?", id=["?"]}, 0);
val exn_tag_table = ref(new_numtable 1 : (QualifiedIdent * int) numtable);
val tag_exn_table = ref(Array.fromList [] : (QualifiedIdent * int) Array.array );
*)
(* cvr:
fun fromShortTagExnTable a = Array.tabulate
((Array.length a),
(fn i => case Array.sub (a, i) of
({qual=qual,id = id},i) => ({qual=qual,id = [id]},i)));
fun toShortTagExnTable a = Array.tabulate
((Array.length a),
(fn i => case Array.sub (a, i) of
({qual=qual,id = [id]},i) => ({qual=qual,id = id},i)));
fun get_num_of_exn (name, stamp) =
Hasht.find (#num_tbl (!exn_tag_table)) (name, stamp)
handle Subscript =>
let val c = enter_in_numtable (!exn_tag_table) (name, stamp)
val len = Array.length (!tag_exn_table)
in
if c < len then () else
let val new_len = 2 * len
val new_tag_exn_table = Array.array(new_len, unknown_exn_name)
in
Array.copy {src = !tag_exn_table, si = 0, len = NONE,
dst = new_tag_exn_table, di = 0};
tag_exn_table := new_tag_exn_table
end;
Array.update(!tag_exn_table, c, (name, stamp));
c
end;
fun get_exn_of_num tag =
if tag >= Array.length (!tag_exn_table)
then unknown_exn_name
else Array.sub(!tag_exn_table, tag)
;
fun defineGlobalExceptionAlias (q, (q', stamp')) =
let val tag = get_num_of_exn (q', stamp') in
Hasht.insert (#num_tbl (!exn_tag_table)) (q, 0) tag
end;
*)
fun intOfTag (CONtag(n,_)) = n
(* | intOfTag (EXNtag(id, stamp)) = fatalError "intOfTag" (* ps: get_num_of_exn(id, stamp) *) *)
;
(* The C primitives *)
val c_prim_table = ref (new_numtable 0 : string numtable);
(* cvr: 144 merge
fun set_c_primitives prim_vect =
(c_prim_table := new_numtable 31;
for (fn i => ignore
(enter_in_numtable (!c_prim_table) (Vector.sub(prim_vect, i))))
0 (Vector.length prim_vect - 1))
;
*)
fun set_c_primitives prim_vect =
(c_prim_table := new_numtable 67;
Vector.app (ignore o enter_in_numtable (!c_prim_table)) prim_vect)
;
fun get_num_of_prim name =
find_in_numtable (!c_prim_table) name
handle Subscript =>
(msgIBlock 0;
errPrompt "Unavailable C primitive: ";
msgString name; msgEOL();
msgEBlock();
raise Toplevel)
;
fun exportPublicNames uname excRenList valRenList =
((* ps: List.app defineGlobalExceptionAlias excRenList; *)
List.app
(fn (id, stamp) =>
defineGlobalValueAlias
({ qual=uname, id=[id] }, 0)
({ qual=uname, id=[id] }, stamp))
valRenList)
;
(* Initialization *)
(* ps:
val normalizeExnName = fn
{qual="sys", id=["Break"]} => {qual="General", id=["Interrupt"]}
| {qual="sys", id=["Sys_error"]} => {qual="General", id=["SysErr"]}
| {qual="exc", id=["Not_found"]} => {qual="General", id=["Subscript"]}
| {qual="io", id=["End_of_file"]} => {qual="General", id=["Size"]}
| {qual="exc", id=["Out_of_memory"]} => {qual="General", id=["Out_of_memory"]}
| {qual="exc", id=["Invalid_argument"]} =>
{qual="General", id=["Invalid_argument"]}
| {qual="exc", id=["Failure"]} => {qual="General", id=["Fail"]}
| {qual="graphics", id=["Graphic_failure"]} =>
{qual="General", id=["Graphic_failure"]}
| {qual="general", id=["Exception"]} => {qual="General", id=["(Exception)"]}
| {qual="general", id=[id]} => {qual="General", id=[id]}
| qualid => qualid
;
*)
fun reset_linker_tables () =
(
global_table := new_numtable 263;
literal_table := [];
List.app
(fn {qual, id} =>
ignore( get_slot_for_defined_variable
(* ps: ({qual="(global)", id=[id]}, 0) *)
({qual=qual, id=[id]}, 0) ))
Predef.predef_variables;
(* ps: exn_tag_table := new_numtable 31;
tag_exn_table := Array.array(50, unknown_exn_name);
List.app
(fn ({qual,id}, stamp) =>
ignore(get_num_of_exn (normalizeExnName {qual=qual,id = [id]}, 0)))
Predef.predef_exn;
*)
set_c_primitives Prim_c.primitives_table
);
fun save_linker_tables outstream =
(
output_binary_int outstream (! (#num_cnt(!global_table)))
(* cvr: removed
output_value outstream (!exn_tag_table);
output_value outstream (!tag_exn_table)
*)
(* cvr: added: *)
(* ps: ; output_value outstream (toShortExnTagTable(!exn_tag_table));
output_value outstream (toShortTagExnTable(!tag_exn_table))
(* cvr: *) *)
);
(* To read linker tables from the executable file *)
fun load_linker_tables () =
( let
val is = open_in_bin (Vector.sub(Miscsys.command_line, 0))
(* The code, data, symb, and debug indexes are located 20 bytes
before the end of the bytecode file. *)
val () = seek_in is (in_stream_length is - 20)
val size_code = input_binary_int is
val size_data = input_binary_int is
val size_symb = input_binary_int is
val size_debug = input_binary_int is
in
seek_in is (in_stream_length is - 20 - size_debug - size_symb);
(* We don't need information about the internals *)
(* of Moscow ML system! *)
global_table := new_numtable 263;
#num_cnt (!global_table) := input_binary_int is
end
) handle _ => fatalError "Unable to read linker tables from bytecode"
;
(* Initialization *)
prim_val available_primitives : unit -> string Vector.vector
= 1 "available_primitives";
fun init_linker_tables () =
(
load_linker_tables();
(* Hasht.clear (#num_tbl (!global_table)); *)
appFrom
(fn slot => fn {qual,id} =>
Hasht.insert (#num_tbl (!global_table)) ({qual=qual,id=[id]}, 0) slot)
0 Predef.predef_variables;
literal_table := [];
set_c_primitives (available_primitives())
);
(* added -- 07Sep95 e *)
fun protect_linker_tables fct =
let val saved_global_table = !global_table
and saved_literal_table = !literal_table
and saved_c_prim_table = !c_prim_table
in
(fct();
global_table := saved_global_table;
literal_table := saved_literal_table;
c_prim_table := saved_c_prim_table
)
handle x =>
(global_table := saved_global_table;
literal_table := saved_literal_table;
c_prim_table := saved_c_prim_table;
raise x)
end
end;