Ekdohibs/camlboot
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

format: limit to 80 columns

Browse Source
This commit is contained in:
Gabriel Scherer 2019-05-31 14:56:37 +02:00 committed by Nathanaël Courant
parent 8c53e923b7
commit 92aafefa90
2 changed files with 209 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.ocamlformat
View File

@ -1,4 +1,5 @@
profile = janestreet profile = janestreet
margin = 80
break-infix-before-func = false break-infix-before-func = false
break-separators = after break-separators = after
parens-tuple = always parens-tuple = always

286
interp.ml
View File

@ -54,7 +54,8 @@ exception InternalException of value
let rec pp_print_value ff = function let rec pp_print_value ff = function
| Int n -> Format.fprintf ff "%d" n | Int n -> Format.fprintf ff "%d" n
| Int64 n -> Format.fprintf ff "%Ld" n | Int64 n -> Format.fprintf ff "%Ld" n
| Fun _ | Function _ | Prim _ | SeqOr | SeqAnd | Lz _ | Fun_with_extra_args _ -> | Fun _ | Function _ | Prim _ | SeqOr | SeqAnd | Lz _ | Fun_with_extra_args _
->
Format.fprintf ff "<function>" Format.fprintf ff "<function>"
| String s -> Format.fprintf ff "%S" (Bytes.to_string s) | String s -> Format.fprintf ff "%S" (Bytes.to_string s)
| Float f -> Format.fprintf ff "%f" f | Float f -> Format.fprintf ff "%f" f
@ -62,10 +63,13 @@ let rec pp_print_value ff = function
Format.fprintf Format.fprintf
ff ff
"(%a)" "(%a)"
(Format.pp_print_list ~pp_sep:(fun ff () -> Format.fprintf ff ", ") pp_print_value) (Format.pp_print_list
~pp_sep:(fun ff () -> Format.fprintf ff ", ")
pp_print_value)
l l
| Constructor (c, d, None) -> Format.fprintf ff "%s#%d" c d | Constructor (c, d, None) -> Format.fprintf ff "%s#%d" c d
| Constructor (c, d, Some v) -> Format.fprintf ff "%s#%d %a" c d pp_print_value v | Constructor (c, d, Some v) ->
Format.fprintf ff "%s#%d %a" c d pp_print_value v
| ModVal _ -> Format.fprintf ff "<module>" | ModVal _ -> Format.fprintf ff "<module>"
| InChannel _ -> Format.fprintf ff "<in_channel>" | InChannel _ -> Format.fprintf ff "<in_channel>"
| OutChannel _ -> Format.fprintf ff "<out_channel>" | OutChannel _ -> Format.fprintf ff "<out_channel>"
@ -77,12 +81,16 @@ let rec pp_print_value ff = function
Format.fprintf Format.fprintf
ff ff
"[|%a|]" "[|%a|]"
(Format.pp_print_list ~pp_sep:(fun ff () -> Format.fprintf ff "; ") pp_print_value) (Format.pp_print_list
~pp_sep:(fun ff () -> Format.fprintf ff "; ")
pp_print_value)
(Array.to_list a) (Array.to_list a)
let read_caml_int s = let read_caml_int s =
let c = ref 0L in let c = ref 0L in
let sign, init = if String.length s > 0 && s.[0] = '-' then (-1L, 1) else (1L, 0) in let sign, init =
if String.length s > 0 && s.[0] = '-' then (-1L, 1) else (1L, 0)
in
let base, init = let base, init =
if String.length s >= init + 2 && s.[init] = '0' if String.length s >= init + 2 && s.[init] = '0'
then then
@ -99,9 +107,13 @@ let read_caml_int s =
| '0' .. '9' as x -> | '0' .. '9' as x ->
c := Int64.(add (mul base !c) (of_int (int_of_char x - int_of_char '0'))) c := Int64.(add (mul base !c) (of_int (int_of_char x - int_of_char '0')))
| 'a' .. 'f' as x -> | 'a' .. 'f' as x ->
c := Int64.(add (mul base !c) (of_int (int_of_char x - int_of_char 'a' + 10))) c :=
Int64.(
add (mul base !c) (of_int (int_of_char x - int_of_char 'a' + 10)))
| 'A' .. 'F' as x -> | 'A' .. 'F' as x ->
c := Int64.(add (mul base !c) (of_int (int_of_char x - int_of_char 'A' + 10))) c :=
Int64.(
add (mul base !c) (of_int (int_of_char x - int_of_char 'A' + 10)))
| '_' -> () | '_' -> ()
| _ -> | _ ->
Format.eprintf "FIXME literal: %s@." s; Format.eprintf "FIXME literal: %s@." s;
@ -110,7 +122,8 @@ let read_caml_int s =
Int64.mul sign !c Int64.mul sign !c
let value_of_constant = function let value_of_constant = function
| Pconst_integer (s, (None | Some 'l')) -> Int (Int64.to_int (read_caml_int s)) | Pconst_integer (s, (None | Some 'l')) ->
Int (Int64.to_int (read_caml_int s))
| Pconst_integer (s, Some ('L' | 'n')) -> Int64 (read_caml_int s) | Pconst_integer (s, Some ('L' | 'n')) -> Int64 (read_caml_int s)
| Pconst_integer (s, Some c) -> | Pconst_integer (s, Some c) ->
Format.eprintf "Unsupported suffix %c@." c; Format.eprintf "Unsupported suffix %c@." c;
@ -141,7 +154,8 @@ let rec value_equal v1 v2 =
| Int64 n1, Int64 n2 -> n1 = n2 | Int64 n1, Int64 n2 -> n1 = n2
| Float f1, Float f2 -> f1 = f2 | Float f1, Float f2 -> f1 = f2
| String s1, String s2 -> s1 = s2 | String s1, String s2 -> s1 = s2
| Constructor (c1, d1, None), Constructor (c2, d2, None) -> d1 = d2 && c1 = c2 | Constructor (c1, d1, None), Constructor (c2, d2, None) ->
d1 = d2 && c1 = c2
| Constructor (c1, d1, Some v1), Constructor (c2, d2, Some v2) -> | Constructor (c1, d1, Some v1), Constructor (c2, d2, Some v2) ->
d1 = d2 && c1 = c2 && value_equal v1 v2 d1 = d2 && c1 = c2 && value_equal v1 v2
| Constructor _, Constructor _ -> false | Constructor _, Constructor _ -> false
@ -205,7 +219,11 @@ let rec value_compare v1 v2 =
| _ -> assert false) | _ -> assert false)
| Tuple l1, Tuple l2 -> | Tuple l1, Tuple l2 ->
assert (List.length l1 = List.length l2); assert (List.length l1 = List.length l2);
List.fold_left2 (fun cur x y -> if cur = 0 then value_compare x y else cur) 0 l1 l2 List.fold_left2
(fun cur x y -> if cur = 0 then value_compare x y else cur)
0
l1
l2
| Record r1, Record r2 -> | Record r1, Record r2 ->
let map1 = let map1 =
SMap.merge SMap.merge
@ -217,7 +235,10 @@ let rec value_compare v1 v2 =
r1 r1
r2 r2
in in
SMap.fold (fun _ (u, v) cur -> if cur = 0 then value_compare u v else cur) map1 0 SMap.fold
(fun _ (u, v) cur -> if cur = 0 then value_compare u v else cur)
map1
0
| _ -> assert false | _ -> assert false
let value_lt v1 v2 = value_compare v1 v2 < 0 let value_lt v1 v2 = value_compare v1 v2 < 0
@ -303,7 +324,7 @@ let env_get_constr ((_, _, constr_env) as env) { txt = lident; loc } =
if debug then Format.eprintf "Constructor not found in env: %s@." str; if debug then Format.eprintf "Constructor not found in env: %s@." str;
raise Not_found) raise Not_found)
| Longident.Ldot (ld, str) -> | Longident.Ldot (ld, str) ->
let md = env_get_module env { txt = ld; loc; } in let md = env_get_module env { txt = ld; loc } in
(match md with (match md with
| Functor _ -> failwith "Ldot tried to access functor" | Functor _ -> failwith "Ldot tried to access functor"
| Module (_, _, md) -> | Module (_, _, md) ->
@ -353,13 +374,14 @@ let rec seeded_hash_param meaningful total seed = function
| Constructor (c, _, v) -> Hashtbl.seeded_hash seed c | Constructor (c, _, v) -> Hashtbl.seeded_hash seed c
| Array a -> 0 | Array a -> 0
| Record r -> 0 | Record r -> 0
| Fun _ | Function _ | SeqOr | SeqAnd | InChannel _ | OutChannel _ | Prim _ | Lz _ | Fun _ | Function _ | SeqOr | SeqAnd | InChannel _ | OutChannel _ | Prim _
| ModVal _ | Fun_with_extra_args _ -> | Lz _ | ModVal _ | Fun_with_extra_args _ ->
assert false assert false
let prim1 f unwrap1 wrap = Prim (fun x -> wrap (f (unwrap1 x))) let prim1 f unwrap1 wrap = Prim (fun x -> wrap (f (unwrap1 x)))
let prim2 f unwrap1 unwrap2 wrap = Prim (fun x -> prim1 (f (unwrap1 x)) unwrap2 wrap) let prim2 f unwrap1 unwrap2 wrap =
Prim (fun x -> prim1 (f (unwrap1 x)) unwrap2 wrap)
let prim3 f unwrap1 unwrap2 unwrap3 wrap = let prim3 f unwrap1 unwrap2 unwrap3 wrap =
Prim (fun x -> prim2 (f (unwrap1 x)) unwrap2 unwrap3 wrap) Prim (fun x -> prim2 (f (unwrap1 x)) unwrap2 unwrap3 wrap)
@ -481,7 +503,8 @@ let rec wrap_list wrapf = function
let rec unwrap_list unwrapf = function let rec unwrap_list unwrapf = function
| Constructor ("[]", _, None) -> [] | Constructor ("[]", _, None) -> []
| Constructor ("::", _, Some (Tuple [ x; l ])) -> unwrapf x :: unwrap_list unwrapf l | Constructor ("::", _, Some (Tuple [ x; l ])) ->
unwrapf x :: unwrap_list unwrapf l
| _ -> assert false | _ -> assert false
let unwrap_marshal_flag = function let unwrap_marshal_flag = function
@ -490,7 +513,10 @@ let unwrap_marshal_flag = function
| Constructor ("Compat_32", _, None) -> Marshal.Compat_32 | Constructor ("Compat_32", _, None) -> Marshal.Compat_32
| _ -> assert false | _ -> assert false
external open_descriptor_out : int -> out_channel = "caml_ml_open_descriptor_out" external open_descriptor_out
: int ->
out_channel
= "caml_ml_open_descriptor_out"
external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
@ -501,7 +527,10 @@ external set_out_channel_name
unit unit
= "caml_ml_set_channel_name" = "caml_ml_set_channel_name"
external out_channels_list : unit -> out_channel list = "caml_ml_out_channels_list" external out_channels_list
: unit ->
out_channel list
= "caml_ml_out_channels_list"
external unsafe_output external unsafe_output
: out_channel -> : out_channel ->
@ -519,15 +548,30 @@ external unsafe_output_string
unit unit
= "caml_ml_output" = "caml_ml_output"
external set_in_channel_name : in_channel -> string -> unit = "caml_ml_set_channel_name" external set_in_channel_name
: in_channel ->
string ->
unit
= "caml_ml_set_channel_name"
external unsafe_input : in_channel -> bytes -> int -> int -> int = "caml_ml_input" external unsafe_input
: in_channel ->
bytes ->
int ->
int ->
int
= "caml_ml_input"
external format_int : string -> int -> string = "caml_format_int" external format_int : string -> int -> string = "caml_format_int"
external format_float : string -> float -> string = "caml_format_float" external format_float : string -> float -> string = "caml_format_float"
external random_seed : unit -> int array = "caml_sys_random_seed" external random_seed : unit -> int array = "caml_sys_random_seed"
external digest_unsafe_string : string -> int -> int -> string = "caml_md5_string" external digest_unsafe_string
: string ->
int ->
int ->
string
= "caml_md5_string"
external marshal_to_channel external marshal_to_channel
: out_channel -> : out_channel ->
@ -631,7 +675,8 @@ let unwrap_parser_input = function
| Constructor ("Token_read", _, None) -> Token_read | Constructor ("Token_read", _, None) -> Token_read
| Constructor ("Stacks_grown_1", _, None) -> Stacks_grown_1 | Constructor ("Stacks_grown_1", _, None) -> Stacks_grown_1
| Constructor ("Stacks_grown_2", _, None) -> Stacks_grown_2 | Constructor ("Stacks_grown_2", _, None) -> Stacks_grown_2
| Constructor ("Semantic_action_computed", _, None) -> Semantic_action_computed | Constructor ("Semantic_action_computed", _, None) ->
Semantic_action_computed
| Constructor ("Error_detected", _, None) -> Error_detected | Constructor ("Error_detected", _, None) -> Error_detected
| _ -> assert false | _ -> assert false
@ -657,8 +702,10 @@ let unwrap_parser_env = function
| Record r -> | Record r ->
{ s_stack = unwrap_array unwrap_int !(SMap.find "s_stack" r); { s_stack = unwrap_array unwrap_int !(SMap.find "s_stack" r);
v_stack = Obj.magic (unwrap_array_id !(SMap.find "v_stack" r)); v_stack = Obj.magic (unwrap_array_id !(SMap.find "v_stack" r));
symb_start_stack = unwrap_array unwrap_position !(SMap.find "symb_start_stack" r); symb_start_stack =
symb_end_stack = unwrap_array unwrap_position !(SMap.find "symb_end_stack" r); unwrap_array unwrap_position !(SMap.find "symb_start_stack" r);
symb_end_stack =
unwrap_array unwrap_position !(SMap.find "symb_end_stack" r);
stacksize = unwrap_int !(SMap.find "stacksize" r); stacksize = unwrap_int !(SMap.find "stacksize" r);
stackbase = unwrap_int !(SMap.find "stackbase" r); stackbase = unwrap_int !(SMap.find "stackbase" r);
curr_char = unwrap_int !(SMap.find "curr_char" r); curr_char = unwrap_int !(SMap.find "curr_char" r);
@ -679,7 +726,8 @@ let sync_parser_env pe = function
let open Parsing in let open Parsing in
SMap.find "s_stack" r := wrap_array wrap_int pe.s_stack; SMap.find "s_stack" r := wrap_array wrap_int pe.s_stack;
SMap.find "v_stack" r := wrap_array_id (Obj.magic pe.v_stack); SMap.find "v_stack" r := wrap_array_id (Obj.magic pe.v_stack);
SMap.find "symb_start_stack" r := wrap_array wrap_position pe.symb_start_stack; SMap.find "symb_start_stack" r
:= wrap_array wrap_position pe.symb_start_stack;
SMap.find "symb_end_stack" r := wrap_array wrap_position pe.symb_end_stack; SMap.find "symb_end_stack" r := wrap_array wrap_position pe.symb_end_stack;
SMap.find "stacksize" r := wrap_int pe.stacksize; SMap.find "stacksize" r := wrap_int pe.stacksize;
SMap.find "stackbase" r := wrap_int pe.stackbase; SMap.find "stackbase" r := wrap_int pe.stackbase;
@ -720,7 +768,9 @@ let unwrap_parse_tables syncenv = function
error_function = error_function =
(fun s -> (fun s ->
unwrap_unit unwrap_unit
(!apply_ref !(SMap.find "error_function" r) [ (Nolabel, wrap_string s) ])); (!apply_ref
!(SMap.find "error_function" r)
[ (Nolabel, wrap_string s) ]));
names_const = unwrap_string_unsafe !(SMap.find "names_const" r); names_const = unwrap_string_unsafe !(SMap.find "names_const" r);
names_block = unwrap_string_unsafe !(SMap.find "names_block" r) names_block = unwrap_string_unsafe !(SMap.find "names_block" r)
} }
@ -842,7 +892,8 @@ let parse_engine_prim =
let lex_engine_prim = prim3 lex_engine_wrapper id unwrap_int id wrap_int let lex_engine_prim = prim3 lex_engine_wrapper id unwrap_int id wrap_int
let new_lex_engine_prim = prim3 new_lex_engine_wrapper id unwrap_int id wrap_int let new_lex_engine_prim =
prim3 new_lex_engine_wrapper id unwrap_int id wrap_int
let initial_env = ref (empty_env : env) let initial_env = ref (empty_env : env)
let exn_id = ref 0 let exn_id = ref 0
@ -878,7 +929,8 @@ let _ = declare_builtin_constructor "()" 0
let prims = let prims =
[ ("%apply", Prim (fun vf -> Prim (fun v -> !apply_ref vf [ (Nolabel, v) ]))); [ ("%apply", Prim (fun vf -> Prim (fun v -> !apply_ref vf [ (Nolabel, v) ])));
("%revapply", Prim (fun v -> Prim (fun vf -> !apply_ref vf [ (Nolabel, v) ]))); ( "%revapply",
Prim (fun v -> Prim (fun vf -> !apply_ref vf [ (Nolabel, v) ])) );
("%raise", Prim (fun v -> raise (InternalException v))); ("%raise", Prim (fun v -> raise (InternalException v)));
("%reraise", Prim (fun v -> raise (InternalException v))); ("%reraise", Prim (fun v -> raise (InternalException v)));
("%raise_notrace", Prim (fun v -> raise (InternalException v))); ("%raise_notrace", Prim (fun v -> raise (InternalException v)));
@ -916,11 +968,19 @@ let prims =
("%noteq", prim2 ( != ) id id wrap_bool); ("%noteq", prim2 ( != ) id id wrap_bool);
("%identity", Prim (fun x -> x)); ("%identity", Prim (fun x -> x));
("caml_register_named_value", Prim (fun _ -> Prim (fun _ -> unit))); ("caml_register_named_value", Prim (fun _ -> Prim (fun _ -> unit)));
("caml_int64_float_of_bits", prim1 Int64.float_of_bits unwrap_int64 wrap_float); ( "caml_int64_float_of_bits",
("caml_ml_open_descriptor_out", prim1 open_descriptor_out unwrap_int wrap_out_channel); prim1 Int64.float_of_bits unwrap_int64 wrap_float );
("caml_ml_open_descriptor_in", prim1 open_descriptor_in unwrap_int wrap_in_channel); ( "caml_ml_open_descriptor_out",
prim1 open_descriptor_out unwrap_int wrap_out_channel );
( "caml_ml_open_descriptor_in",
prim1 open_descriptor_in unwrap_int wrap_in_channel );
( "caml_sys_open", ( "caml_sys_open",
prim3 open_desc unwrap_string (unwrap_list unwrap_open_flag) unwrap_int wrap_int ); prim3
open_desc
unwrap_string
(unwrap_list unwrap_open_flag)
unwrap_int
wrap_int );
( "caml_ml_set_channel_name", ( "caml_ml_set_channel_name",
prim2 prim2
(fun v s -> (fun v s ->
@ -942,8 +1002,13 @@ let prims =
( "caml_ml_out_channels_list", ( "caml_ml_out_channels_list",
prim1 out_channels_list unwrap_unit (wrap_list wrap_out_channel) ); prim1 out_channels_list unwrap_unit (wrap_list wrap_out_channel) );
( "caml_ml_output_bytes", ( "caml_ml_output_bytes",
prim4 unsafe_output unwrap_out_channel unwrap_bytes unwrap_int unwrap_int wrap_unit prim4
); unsafe_output
unwrap_out_channel
unwrap_bytes
unwrap_int
unwrap_int
wrap_unit );
( "caml_ml_output", ( "caml_ml_output",
prim4 prim4
unsafe_output_string unsafe_output_string
@ -954,13 +1019,21 @@ let prims =
wrap_unit ); wrap_unit );
( "caml_ml_output_int", ( "caml_ml_output_int",
prim2 output_binary_int unwrap_out_channel unwrap_int wrap_unit ); prim2 output_binary_int unwrap_out_channel unwrap_int wrap_unit );
("caml_ml_output_char", prim2 output_char unwrap_out_channel unwrap_char wrap_unit); ( "caml_ml_output_char",
prim2 output_char unwrap_out_channel unwrap_char wrap_unit );
("caml_ml_flush", prim1 flush unwrap_out_channel wrap_unit); ("caml_ml_flush", prim1 flush unwrap_out_channel wrap_unit);
("caml_ml_input_char", prim1 input_char unwrap_in_channel wrap_char); ("caml_ml_input_char", prim1 input_char unwrap_in_channel wrap_char);
("caml_ml_input_int", prim1 input_binary_int unwrap_in_channel wrap_int); ("caml_ml_input_int", prim1 input_binary_int unwrap_in_channel wrap_int);
("caml_ml_input_scan_line", prim1 input_scan_line unwrap_in_channel wrap_int); ( "caml_ml_input_scan_line",
prim1 input_scan_line unwrap_in_channel wrap_int );
( "caml_ml_input", ( "caml_ml_input",
prim4 unsafe_input unwrap_in_channel unwrap_bytes unwrap_int unwrap_int wrap_int ); prim4
unsafe_input
unwrap_in_channel
unwrap_bytes
unwrap_int
unwrap_int
wrap_int );
("caml_ml_seek_in", prim2 seek_in unwrap_in_channel unwrap_int wrap_unit); ("caml_ml_seek_in", prim2 seek_in unwrap_in_channel unwrap_int wrap_unit);
("caml_ml_pos_out", prim1 pos_out unwrap_out_channel wrap_int); ("caml_ml_pos_out", prim1 pos_out unwrap_out_channel wrap_int);
("caml_ml_pos_in", prim1 pos_in unwrap_in_channel wrap_int); ("caml_ml_pos_in", prim1 pos_in unwrap_in_channel wrap_int);
@ -1004,11 +1077,16 @@ let prims =
| _ -> assert false) ); | _ -> assert false) );
("%ignore", Prim (fun _ -> unit)); ("%ignore", Prim (fun _ -> unit));
("caml_format_int", prim2 format_int unwrap_string unwrap_int wrap_string); ("caml_format_int", prim2 format_int unwrap_string unwrap_int wrap_string);
("caml_format_float", prim2 format_float unwrap_string unwrap_float wrap_string); ( "caml_format_float",
prim2 format_float unwrap_string unwrap_float wrap_string );
("caml_int_of_string", prim1 int_of_string unwrap_string wrap_int); ("caml_int_of_string", prim1 int_of_string unwrap_string wrap_int);
( "caml_output_value", ( "caml_output_value",
prim3 marshal_to_channel unwrap_out_channel id (unwrap_list unwrap_unit) wrap_unit prim3
); marshal_to_channel
unwrap_out_channel
id
(unwrap_list unwrap_unit)
wrap_unit );
( "caml_output_value_to_buffer", ( "caml_output_value_to_buffer",
prim5 prim5
Marshal.to_buffer Marshal.to_buffer
@ -1025,7 +1103,9 @@ let prims =
("caml_new_lex_engine", new_lex_engine_prim); ("caml_new_lex_engine", new_lex_engine_prim);
(* Sys *) (* Sys *)
( "caml_sys_get_argv", ( "caml_sys_get_argv",
Prim (fun _ -> Tuple [ wrap_string ""; Array (Array.map wrap_string Sys.argv) ]) ); Prim
(fun _ ->
Tuple [ wrap_string ""; Array (Array.map wrap_string Sys.argv) ]) );
( "caml_sys_get_config", ( "caml_sys_get_config",
Prim (fun _ -> Tuple [ wrap_string "Unix"; Int 0; wrap_bool true ]) ); Prim (fun _ -> Tuple [ wrap_string "Unix"; Int 0; wrap_bool true ]) );
("%big_endian", Prim (fun _ -> wrap_bool Sys.big_endian)); ("%big_endian", Prim (fun _ -> wrap_bool Sys.big_endian));
@ -1036,7 +1116,8 @@ let prims =
("%ostype_win32", Prim (fun _ -> wrap_bool false)); ("%ostype_win32", Prim (fun _ -> wrap_bool false));
("%ostype_cygwin", Prim (fun _ -> wrap_bool false)); ("%ostype_cygwin", Prim (fun _ -> wrap_bool false));
( "%backend_type", ( "%backend_type",
Prim (fun _ -> Constructor ("Other", 0, Some (wrap_string "Interpreter"))) ); Prim (fun _ -> Constructor ("Other", 0, Some (wrap_string "Interpreter")))
);
("caml_sys_getenv", Prim (fun _ -> raise (InternalException not_found_exn))); ("caml_sys_getenv", Prim (fun _ -> raise (InternalException not_found_exn)));
("caml_sys_file_exists", prim1 Sys.file_exists unwrap_string wrap_bool); ("caml_sys_file_exists", prim1 Sys.file_exists unwrap_string wrap_bool);
("caml_sys_getcwd", prim1 Sys.getcwd unwrap_unit wrap_string); ("caml_sys_getcwd", prim1 Sys.getcwd unwrap_unit wrap_string);
@ -1045,16 +1126,25 @@ let prims =
(* Bytes *) (* Bytes *)
("caml_create_bytes", prim1 Bytes.create unwrap_int wrap_bytes); ("caml_create_bytes", prim1 Bytes.create unwrap_int wrap_bytes);
( "caml_fill_bytes", ( "caml_fill_bytes",
prim4 Bytes.unsafe_fill unwrap_bytes unwrap_int unwrap_int unwrap_char wrap_unit ); prim4
Bytes.unsafe_fill
unwrap_bytes
unwrap_int
unwrap_int
unwrap_char
wrap_unit );
("%bytes_to_string", Prim (fun v -> v)); ("%bytes_to_string", Prim (fun v -> v));
("%bytes_of_string", Prim (fun v -> v)); ("%bytes_of_string", Prim (fun v -> v));
("%string_length", prim1 Bytes.length unwrap_bytes wrap_int); ("%string_length", prim1 Bytes.length unwrap_bytes wrap_int);
("%bytes_length", prim1 Bytes.length unwrap_bytes wrap_int); ("%bytes_length", prim1 Bytes.length unwrap_bytes wrap_int);
("%string_safe_get", prim2 Bytes.get unwrap_bytes unwrap_int wrap_char); ("%string_safe_get", prim2 Bytes.get unwrap_bytes unwrap_int wrap_char);
("%string_unsafe_get", prim2 Bytes.unsafe_get unwrap_bytes unwrap_int wrap_char); ( "%string_unsafe_get",
prim2 Bytes.unsafe_get unwrap_bytes unwrap_int wrap_char );
("%bytes_safe_get", prim2 Bytes.get unwrap_bytes unwrap_int wrap_char); ("%bytes_safe_get", prim2 Bytes.get unwrap_bytes unwrap_int wrap_char);
("%bytes_unsafe_get", prim2 Bytes.unsafe_get unwrap_bytes unwrap_int wrap_char); ( "%bytes_unsafe_get",
("%bytes_safe_set", prim3 Bytes.set unwrap_bytes unwrap_int unwrap_char wrap_unit); prim2 Bytes.unsafe_get unwrap_bytes unwrap_int wrap_char );
( "%bytes_safe_set",
prim3 Bytes.set unwrap_bytes unwrap_int unwrap_char wrap_unit );
( "%bytes_unsafe_set", ( "%bytes_unsafe_set",
prim3 Bytes.unsafe_set unwrap_bytes unwrap_int unwrap_char wrap_unit ); prim3 Bytes.unsafe_set unwrap_bytes unwrap_int unwrap_char wrap_unit );
( "caml_blit_string", ( "caml_blit_string",
@ -1095,7 +1185,8 @@ let prims =
("%int64_or", prim2 Int64.logor unwrap_int64 unwrap_int64 wrap_int64); ("%int64_or", prim2 Int64.logor unwrap_int64 unwrap_int64 wrap_int64);
("%int64_xor", prim2 Int64.logxor unwrap_int64 unwrap_int64 wrap_int64); ("%int64_xor", prim2 Int64.logxor unwrap_int64 unwrap_int64 wrap_int64);
("%int64_lsl", prim2 Int64.shift_left unwrap_int64 unwrap_int wrap_int64); ("%int64_lsl", prim2 Int64.shift_left unwrap_int64 unwrap_int wrap_int64);
("%int64_lsr", prim2 Int64.shift_right_logical unwrap_int64 unwrap_int wrap_int64); ( "%int64_lsr",
prim2 Int64.shift_right_logical unwrap_int64 unwrap_int wrap_int64 );
("%int64_asr", prim2 Int64.shift_right unwrap_int64 unwrap_int wrap_int64); ("%int64_asr", prim2 Int64.shift_right unwrap_int64 unwrap_int wrap_int64);
("%int64_of_int", prim1 Int64.of_int unwrap_int wrap_int64); ("%int64_of_int", prim1 Int64.of_int unwrap_int wrap_int64);
("%int64_to_int", prim1 Int64.to_int unwrap_int64 wrap_int); ("%int64_to_int", prim1 Int64.to_int unwrap_int64 wrap_int);
@ -1113,9 +1204,12 @@ let prims =
("%nativeint_and", prim2 Int64.logand unwrap_int64 unwrap_int64 wrap_int64); ("%nativeint_and", prim2 Int64.logand unwrap_int64 unwrap_int64 wrap_int64);
("%nativeint_or", prim2 Int64.logor unwrap_int64 unwrap_int64 wrap_int64); ("%nativeint_or", prim2 Int64.logor unwrap_int64 unwrap_int64 wrap_int64);
("%nativeint_xor", prim2 Int64.logxor unwrap_int64 unwrap_int64 wrap_int64); ("%nativeint_xor", prim2 Int64.logxor unwrap_int64 unwrap_int64 wrap_int64);
("%nativeint_lsl", prim2 Int64.shift_left unwrap_int64 unwrap_int wrap_int64); ( "%nativeint_lsl",
("%nativeint_lsr", prim2 Int64.shift_right_logical unwrap_int64 unwrap_int wrap_int64); prim2 Int64.shift_left unwrap_int64 unwrap_int wrap_int64 );
("%nativeint_asr", prim2 Int64.shift_right unwrap_int64 unwrap_int wrap_int64); ( "%nativeint_lsr",
prim2 Int64.shift_right_logical unwrap_int64 unwrap_int wrap_int64 );
( "%nativeint_asr",
prim2 Int64.shift_right unwrap_int64 unwrap_int wrap_int64 );
("%nativeint_of_int", prim1 Int64.of_int unwrap_int wrap_int64); ("%nativeint_of_int", prim1 Int64.of_int unwrap_int wrap_int64);
("%nativeint_to_int", prim1 Int64.to_int unwrap_int64 wrap_int); ("%nativeint_to_int", prim1 Int64.to_int unwrap_int64 wrap_int);
("caml_nativeint_of_string", prim1 Int64.of_string unwrap_string wrap_int64); ("caml_nativeint_of_string", prim1 Int64.of_string unwrap_string wrap_int64);
@ -1127,7 +1221,8 @@ let prims =
("%array_safe_get", prim2 Array.get unwrap_array_id unwrap_int id); ("%array_safe_get", prim2 Array.get unwrap_array_id unwrap_int id);
("%array_unsafe_get", prim2 Array.unsafe_get unwrap_array_id unwrap_int id); ("%array_unsafe_get", prim2 Array.unsafe_get unwrap_array_id unwrap_int id);
("%array_safe_set", prim3 Array.set unwrap_array_id unwrap_int id wrap_unit); ("%array_safe_set", prim3 Array.set unwrap_array_id unwrap_int id wrap_unit);
("%array_unsafe_set", prim3 Array.unsafe_set unwrap_array_id unwrap_int id wrap_unit); ( "%array_unsafe_set",
prim3 Array.unsafe_set unwrap_array_id unwrap_int id wrap_unit );
( "caml_array_blit", ( "caml_array_blit",
prim5 prim5
Array.blit Array.blit
@ -1137,9 +1232,11 @@ let prims =
unwrap_int unwrap_int
unwrap_int unwrap_int
wrap_unit ); wrap_unit );
("caml_array_append", prim2 append_prim unwrap_array_id unwrap_array_id wrap_array_id); ( "caml_array_append",
prim2 append_prim unwrap_array_id unwrap_array_id wrap_array_id );
(* Hashtbl *) (* Hashtbl *)
("caml_hash", prim4 seeded_hash_param unwrap_int unwrap_int unwrap_int id wrap_int); ( "caml_hash",
prim4 seeded_hash_param unwrap_int unwrap_int unwrap_int id wrap_int );
(* TODO: records defined in different order... *) (* TODO: records defined in different order... *)
(* Weak *) (* Weak *)
@ -1149,9 +1246,11 @@ let prims =
unwrap_int unwrap_int
wrap_array_id ); wrap_array_id );
("caml_weak_get", prim2 (fun a n -> a.(n)) unwrap_array_id unwrap_int id); ("caml_weak_get", prim2 (fun a n -> a.(n)) unwrap_array_id unwrap_int id);
("caml_weak_get_copy", prim2 (fun a n -> a.(n)) unwrap_array_id unwrap_int id); ( "caml_weak_get_copy",
prim2 (fun a n -> a.(n)) unwrap_array_id unwrap_int id );
( "caml_weak_set", ( "caml_weak_set",
prim3 (fun a n v -> a.(n) <- v) unwrap_array_id unwrap_int id wrap_unit ); prim3 (fun a n v -> a.(n) <- v) unwrap_array_id unwrap_int id wrap_unit
);
( "caml_weak_check", ( "caml_weak_check",
prim2 prim2
(fun a n -> a.(n) <> Constructor ("None", 0, None)) (fun a n -> a.(n) <> Constructor ("None", 0, None))
@ -1168,11 +1267,18 @@ let prims =
unwrap_int unwrap_int
wrap_unit ); wrap_unit );
(* Random *) (* Random *)
("caml_sys_random_seed", prim1 random_seed unwrap_unit (wrap_array wrap_int)); ( "caml_sys_random_seed",
prim1 random_seed unwrap_unit (wrap_array wrap_int) );
(* Digest *) (* Digest *)
( "caml_md5_string", ( "caml_md5_string",
prim3 digest_unsafe_string unwrap_string unwrap_int unwrap_int wrap_string ); prim3
("caml_md5_chan", prim2 Digest.channel unwrap_in_channel unwrap_int wrap_string); digest_unsafe_string
unwrap_string
unwrap_int
unwrap_int
wrap_string );
( "caml_md5_chan",
prim2 Digest.channel unwrap_in_channel unwrap_int wrap_string );
(* Ugly *) (* Ugly *)
( "%obj_size", ( "%obj_size",
prim1 prim1
@ -1189,15 +1295,18 @@ let prims =
id ) id )
] ]
let prims = List.fold_left (fun env (name, v) -> SMap.add name v env) SMap.empty prims let prims =
List.fold_left (fun env (name, v) -> SMap.add name v env) SMap.empty prims
let rec expr_label_shape = function let rec expr_label_shape = function
| Pexp_fun (label, default, _, e) -> (label, default) :: expr_label_shape e.pexp_desc | Pexp_fun (label, default, _, e) ->
(label, default) :: expr_label_shape e.pexp_desc
| Pexp_function _ -> [ (Nolabel, None) ] | Pexp_function _ -> [ (Nolabel, None) ]
| _ -> [] | _ -> []
let fun_label_shape = function let fun_label_shape = function
| Fun (lab, default, _, e, _) -> (lab, default) :: expr_label_shape e.pexp_desc | Fun (lab, default, _, e, _) ->
(lab, default) :: expr_label_shape e.pexp_desc
| Function _ -> [ (Nolabel, None) ] | Function _ -> [ (Nolabel, None) ]
| Prim _ -> [ (Nolabel, None) ] | Prim _ -> [ (Nolabel, None) ]
| SeqOr | SeqAnd -> [ (Nolabel, None); (Nolabel, None) ] | SeqOr | SeqAnd -> [ (Nolabel, None); (Nolabel, None) ]
@ -1260,7 +1369,9 @@ let rec apply vf args =
eval_expr (pattern_bind !fenv p (eval_expr !fenv def)) e eval_expr (pattern_bind !fenv p (eval_expr !fenv def)) e
| _ -> assert false | _ -> assert false
in in
let unlabelled = List.map snd (List.filter (fun (lab, _) -> lab = Nolabel) args) in let unlabelled =
List.map snd (List.filter (fun (lab, _) -> lab = Nolabel) args)
in
let with_label = let with_label =
ref ref
(List.fold_left (List.fold_left
@ -1274,7 +1385,8 @@ let rec apply vf args =
let has_labelled = not (SMap.is_empty !with_label) in let has_labelled = not (SMap.is_empty !with_label) in
let rec apply_one vf arg = let rec apply_one vf arg =
match vf with match vf with
| Fun (Nolabel, default, p, e, fenv) -> eval_expr (pattern_bind !fenv p arg) e | Fun (Nolabel, default, p, e, fenv) ->
eval_expr (pattern_bind !fenv p arg) e
| Fun (((Labelled s | Optional s) as lab), default, p, e, fenv) -> | Fun (((Labelled s | Optional s) as lab), default, p, e, fenv) ->
if has_labelled if has_labelled
then then
@ -1291,14 +1403,17 @@ let rec apply vf args =
else eval_expr (pattern_bind !fenv p arg) e else eval_expr (pattern_bind !fenv p arg) e
| Function (cl, fenv) -> eval_match !fenv cl (Ok arg) | Function (cl, fenv) -> eval_match !fenv cl (Ok arg)
| Prim prim -> prim arg | Prim prim -> prim arg
| SeqOr -> if is_true arg then Prim (fun _ -> wrap_bool true) else Prim (fun x -> x) | SeqOr ->
| SeqAnd -> if is_true arg then Prim (fun x -> x) else Prim (fun _ -> wrap_bool false) if is_true arg then Prim (fun _ -> wrap_bool true) else Prim (fun x -> x)
| SeqAnd ->
if is_true arg then Prim (fun x -> x) else Prim (fun _ -> wrap_bool false)
| v -> | v ->
Format.eprintf "%a@." pp_print_value v; Format.eprintf "%a@." pp_print_value v;
assert false assert false
in in
if SMap.is_empty !with_label if SMap.is_empty !with_label
then (* Special case to get tail recursion *) then
(* Special case to get tail recursion *)
List.fold_left apply_one vf unlabelled List.fold_left apply_one vf unlabelled
else ( else (
let vf = List.fold_left apply_one vf unlabelled in let vf = List.fold_left apply_one vf unlabelled in
@ -1351,7 +1466,9 @@ and eval_expr env expr =
then ( then (
match f.pexp_desc with match f.pexp_desc with
| Pexp_ident lident -> | Pexp_ident lident ->
Format.eprintf "apply %s" (String.concat "." (Longident.flatten lident.txt)); Format.eprintf
"apply %s"
(String.concat "." (Longident.flatten lident.txt));
incr tracecur; incr tracecur;
if !tracecur > tracearg_from if !tracecur > tracearg_from
then then
@ -1364,7 +1481,8 @@ and eval_expr env expr =
Format.eprintf "@." Format.eprintf "@."
| _ -> ()); | _ -> ());
(match f.pexp_desc with (match f.pexp_desc with
| Pexp_ident lident when lident_name lident.txt = "yyparse" -> cur_env := env | Pexp_ident lident when lident_name lident.txt = "yyparse" ->
cur_env := env
| _ -> ()); | _ -> ());
(*Hack for parsing.c*) (*Hack for parsing.c*)
apply fc args) apply fc args)
@ -1414,7 +1532,8 @@ and eval_expr env expr =
| Pexp_try (e, cs) -> | Pexp_try (e, cs) ->
(try eval_expr env e (try eval_expr env e
with InternalException v -> with InternalException v ->
(try eval_match env cs (Ok v) with Match_fail -> raise (InternalException v))) (try eval_match env cs (Ok v)
with Match_fail -> raise (InternalException v)))
| Pexp_construct (c, e) -> | Pexp_construct (c, e) ->
let cn = lident_name c.txt in let cn = lident_name c.txt in
let d = env_get_constr env c in let d = env_get_constr env c in
@ -1470,7 +1589,8 @@ and eval_expr env expr =
let d = !exn_id in let d = !exn_id in
incr exn_id; incr exn_id;
env_set_constr name.txt d env env_set_constr name.txt d env
| Pext_rebind path -> env_set_constr name.txt (env_get_constr env path) env | Pext_rebind path ->
env_set_constr name.txt (env_get_constr env path) env
in in
eval_expr nenv e eval_expr nenv e
| Pexp_letmodule (name, me, e) -> | Pexp_letmodule (name, me, e) ->
@ -1669,7 +1789,8 @@ and eval_structitem init_ignored env it =
List.fold_left List.fold_left
(fun (u, v, env) cd -> (fun (u, v, env) cd ->
match cd.pcd_args with match cd.pcd_args with
| Pcstr_tuple [] -> (u + 1, v, env_set_constr cd.pcd_name.txt u env) | Pcstr_tuple [] ->
(u + 1, v, env_set_constr cd.pcd_name.txt u env)
| _ -> (u, v + 1, env_set_constr cd.pcd_name.txt v env)) | _ -> (u, v + 1, env_set_constr cd.pcd_name.txt v env))
(0, 0, env) (0, 0, env)
l l
@ -1717,7 +1838,8 @@ and eval_structitem init_ignored env it =
and eval_structure_ init_ignored env str = and eval_structure_ init_ignored env str =
match str with match str with
| [] -> env | [] -> env
| it :: str -> eval_structure_ init_ignored (eval_structitem init_ignored env it) str | it :: str ->
eval_structure_ init_ignored (eval_structitem init_ignored env it) str
and eval_structure init_ignored env str = and eval_structure init_ignored env str =
eval_structure_ init_ignored (prevent_export env) str eval_structure_ init_ignored (prevent_export env) str
@ -1802,7 +1924,9 @@ let stdlib_modules =
"camlinternalFormat.ml", "camlinternalFormat.ml",
fun env -> fun env ->
fmt_ebb_of_string_fct := fmt_ebb_of_string_fct :=
env_get_value env (Location.mknoloc (Longident.Lident "fmt_ebb_of_string")); env_get_value
env
(Location.mknoloc (Longident.Lident "fmt_ebb_of_string"));
env ); env );
("Printf", "printf.ml", z); ("Printf", "printf.ml", z);
("Format", "format.ml", z); ("Format", "format.ml", z);
@ -1840,13 +1964,17 @@ let stdlib_path =
path) path)
let stdlib_modules = let stdlib_modules =
List.map (fun (n, p, modifier) -> (n, stdlib_path ^ "/" ^ p, modifier)) stdlib_modules List.map
(fun (n, p, modifier) -> (n, stdlib_path ^ "/" ^ p, modifier))
stdlib_modules
let load_modules env modules = let load_modules env modules =
List.fold_left List.fold_left
(fun env (modname, modpath, modifier) -> (fun env (modname, modpath, modifier) ->
if debug then Format.eprintf "Loading %s from %s@." modname modpath; if debug then Format.eprintf "Loading %s from %s@." modname modpath;
let module_contents = modifier (eval_structure None env (parse modpath)) in let module_contents =
modifier (eval_structure None env (parse modpath))
in
env_set_module modname (make_module module_contents) env) env_set_module modname (make_module module_contents) env)
env env
modules modules
@ -1872,7 +2000,9 @@ let compiler_modules =
("Ccomp", "utils/ccomp.ml", z); ("Ccomp", "utils/ccomp.ml", z);
("Warnings", "utils/warnings.ml", z); ("Warnings", "utils/warnings.ml", z);
("Consistbl", "utils/consistbl.ml", z); ("Consistbl", "utils/consistbl.ml", z);
("Strongly_connected_components", "utils/strongly_connected_components.ml", z); ( "Strongly_connected_components",
"utils/strongly_connected_components.ml",
z );
("Build_path_prefix_map", "utils/build_path_prefix_map.ml", z); ("Build_path_prefix_map", "utils/build_path_prefix_map.ml", z);
("Targetint", "utils/targetint.ml", z); ("Targetint", "utils/targetint.ml", z);
(* Parsing *) (* Parsing *)
@ -1979,8 +2109,8 @@ let compiler_source_path =
| Some path -> path | Some path -> path
| None -> | None ->
failwith failwith
"Error: please set an OCAMLINTERP_SRC_PATH variable pointing to a checkout of the \ "Error: please set an OCAMLINTERP_SRC_PATH variable pointing to a \
OCaml compiler distribution sources" checkout of the OCaml compiler distribution sources"
let compiler_modules = let compiler_modules =
List.map List.map