Commit 420e2189 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Fix an uncaught exception with OCaml 4.11.2 when translating a polymorphic type.

parent d1c59224
......@@ -10,7 +10,7 @@
((:standard version)
\
ocaml_obj_compat_407
ocaml_obj_compat_410))
ocaml_obj_compat_409))
(preprocess
(pps sedlex.ppx)))
......@@ -20,15 +20,15 @@
(action
(copy %{deps} %{target}))
(enabled_if
(< %{ocaml_version} 4.10)))
(< %{ocaml_version} 4.09)))
(rule
(deps runtime/ocaml_obj_compat_410.ml)
(deps runtime/ocaml_obj_compat_409.ml)
(target ocaml_obj_compat.ml)
(action
(copy %{deps} %{target}))
(enabled_if
(>= %{ocaml_version} 4.10)))
(>= %{ocaml_version} 4.09)))
(rule
(target version.ml)
......
......@@ -8,8 +8,8 @@ let () =
4 :: 7 :: _ -> "407"
| 4 :: (8|9) :: _ -> "408_9"
| 4 :: 10 :: _ -> "410"
| 4 :: 11 :: _ -> "411"
| _ -> "411"
| 4 :: (11|12) :: _ -> "411_12"
| _ -> "411_12"
in Jbuild_plugin.V1.send (Printf.sprintf {|
(library
(name cduce_ocamliface)
......@@ -18,7 +18,7 @@ let () =
(modules
(:standard
\
("mlcompat_407" mlcompat_408_9 mlcompat_410 mlcompat_411)))
("mlcompat_407" mlcompat_408_9 mlcompat_410 mlcompat_411_12)))
(flags (-open Cduce_types))
(libraries
cduce-types
......
......@@ -3,45 +3,43 @@ open Cduce_core
let longident_parse = Ocaml_common.Longident.parse
module Mlstub =
struct
module Mlstub = struct
let noloc id = id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk l)
end
module Mltypes =
struct
let lookup_value li env =
Ocaml_common.Env.lookup_value li env
module Mltypes = struct
open Ocaml_common
let get_path_from_mty_alias = function
| Types.Mty_alias (_, p) -> p
| _ -> assert false
let lookup_value li env = Env.lookup_value li env
let lookup_module li env =
Ocaml_common.Env.lookup_module ~load:true li env
let lookup_module li env = Env.lookup_module ~load:true li env
let load_path () =
Ocaml_common.Config.load_path := Ocaml_common.Config.standard_library :: !Cduce_loc.obj_path
let find_in_path file =
Ocaml_common.Misc.find_in_path_uncap !Ocaml_common.Config.load_path file
let load_path () =
Config.load_path := Config.standard_library :: !Cduce_loc.obj_path
let get_path_from_pdot e =
match e with
Ocaml_common.Path.Pdot (p, _, _) -> p
| _ -> assert false
let find_in_path file = Misc.find_in_path_uncap !Config.load_path file
let is_sig_value_val_reg e =
match e with
Ocaml_common.Types.Sig_value (_, {val_type=_;val_kind=Val_reg}) -> true
| _ -> false
let get_path_from_pdot e =
match e with Path.Pdot (p, _, _) -> p | _ -> assert false
let get_id_t_from_sig_value e =
match e with
Ocaml_common.Types.Sig_value (id, {val_type=t;}) -> (id, t)
| _ -> assert false
let is_sig_value_val_reg e =
match e with
| Types.Sig_value (_, { val_type = _; val_kind = Val_reg }) -> true
| _ -> false
let get_sig_type e =
match e with
Ocaml_common.Types.Sig_type(id, t, rs) -> (id, t, rs)
| _ -> assert false
let get_id_t_from_sig_value e =
match e with
| Types.Sig_value (id, { val_type = t }) -> (id, t)
| _ -> assert false
let get_sig_type e =
match e with Types.Sig_type (id, t, rs) -> (id, t, rs) | _ -> assert false
end
......@@ -3,52 +3,53 @@ open Cduce_core
let longident_parse = Ocaml_common.Longident.parse
module Mlstub =
struct
let noloc id = id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
module Mlstub = struct
let noloc id = id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
end
module Mltypes =
struct
let lookup_value li env =
Ocaml_common.Env.lookup_value li env
module Mltypes = struct
open Ocaml_common
let lookup_module li env =
Ocaml_common.Env.lookup_module ~load:true li env
let get_path_from_mty_alias = function
| Types.Mty_alias p -> p
| _ -> assert false
let load_path =
let once = ref false in
function () ->
if !once then () else begin
once := true;
List.iter Ocaml_common.Load_path.add_dir (List.rev !Cduce_loc.obj_path);
Ocaml_common.Load_path.add_dir Ocaml_common.Config.standard_library
end
let find_in_path file =
Ocaml_common.Misc.find_in_path_uncap (Ocaml_common.Load_path.get_paths()) file
let get_path_from_pdot e =
match e with
Ocaml_common.Path.Pdot (p, _) -> p
| _ -> assert false
let is_sig_value_val_reg e =
match e with
Ocaml_common.Types.Sig_value (_, {val_type=_;val_kind=Val_reg}, _) -> true
| _ -> false
let get_id_t_from_sig_value e =
match e with
Ocaml_common.Types.Sig_value (id, {val_type=t;}, _) -> (id, t)
| _ -> assert false
let get_sig_type e =
match e with
Ocaml_common.Types.Sig_type(id, t, rs, _) -> (id, t, rs)
| _ -> assert false
let lookup_value li env = Env.lookup_value li env
let lookup_module li env = Env.lookup_module ~load:true li env
let load_path =
let once = ref false in
function
| () ->
if !once then ()
else begin
once := true;
List.iter Load_path.add_dir (List.rev !Cduce_loc.obj_path);
Load_path.add_dir Config.standard_library
end
let find_in_path file = Misc.find_in_path_uncap (Load_path.get_paths ()) file
let get_path_from_pdot e =
match e with Path.Pdot (p, _) -> p | _ -> assert false
let is_sig_value_val_reg e =
match e with
| Types.Sig_value (_, { val_type = _; val_kind = Val_reg }, _) -> true
| _ -> false
let get_id_t_from_sig_value e =
match e with
| Types.Sig_value (id, { val_type = t }, _) -> (id, t)
| _ -> assert false
let get_sig_type e =
match e with
| Types.Sig_type (id, t, rs, _) -> (id, t, rs)
| _ -> assert false
end
(* Compatibilty for OCaml 4.10 & 4.11 *)
open Cduce_core
let longident_parse = Ocaml_common.Longident.parse
module Mlstub =
struct
let noloc id = Some id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
module Mlstub = struct
let noloc id = Some id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
end
module Mltypes =
struct
let lookup_value li env =
Ocaml_common.Env.find_value_by_name li env
module Mltypes = struct
open Ocaml_common
let lookup_module li env =
let loc = Ocaml_common.Warnings.{ loc_start= Lexing.dummy_pos;
loc_end= Lexing.dummy_pos;
loc_ghost = true }
in
Ocaml_common.Env.lookup_module_path ~use:true ~load:true ~loc:loc li env
let get_path_from_mty_alias = function
| Types.Mty_alias p -> p
| _ -> assert false
let load_path =
let once = ref false in
let add_dir s =
Ocaml_common.Load_path.add_dir s
let lookup_value li env = Env.find_value_by_name li env
let lookup_module li env =
let loc =
Warnings.
{
loc_start = Lexing.dummy_pos;
loc_end = Lexing.dummy_pos;
loc_ghost = true;
}
in
function () ->
if !once then () else begin
once := true;
List.iter add_dir (List.rev !Cduce_loc.obj_path);
add_dir Ocaml_common.Config.standard_library
end
let find_in_path file =
Ocaml_common.Misc.find_in_path_uncap (Ocaml_common.Load_path.get_paths()) file
let get_path_from_pdot e =
match e with
Ocaml_common.Path.Pdot (p, _) -> p
| _ -> assert false
let is_sig_value_val_reg e =
match e with
Ocaml_common.Types.Sig_value (_, {val_type=_;val_kind=Val_reg; _}, _) -> true
| _ -> false
let get_id_t_from_sig_value e =
match e with
Ocaml_common.Types.Sig_value (id, {val_type=t; _}, _) -> (id, t)
| _ -> assert false
let get_sig_type e =
match e with
Ocaml_common.Types.Sig_type(id, t, rs, _) -> (id, t, rs)
| _ -> assert false
Env.lookup_module_path ~use:true ~load:true ~loc li env
let load_path =
let once = ref false in
let add_dir s = Load_path.add_dir s in
function
| () ->
if !once then ()
else begin
once := true;
List.iter add_dir (List.rev !Cduce_loc.obj_path);
add_dir Config.standard_library
end
let find_in_path file = Misc.find_in_path_uncap (Load_path.get_paths ()) file
let get_path_from_pdot e =
match e with Path.Pdot (p, _) -> p | _ -> assert false
let is_sig_value_val_reg e =
match e with
| Types.Sig_value (_, { val_type = _; val_kind = Val_reg; _ }, _) -> true
| _ -> false
let get_id_t_from_sig_value e =
match e with
| Types.Sig_value (id, { val_type = t; _ }, _) -> (id, t)
| _ -> assert false
let get_sig_type e =
match e with
| Types.Sig_type (id, t, rs, _) -> (id, t, rs)
| _ -> assert false
end
(* Compatibilty for OCaml 4.10 & 4.11 *)
(* Compatibilty for OCaml 4.11 & 4.12 *)
open Cduce_core
let longident_parse s = Ocaml_common.Parse.longident (Lexing.from_string s)
let longident_parse s =
let open Ocaml_common in
match String.index_opt s '.' with
| None -> Longident.Lident s
| _ -> Parse.longident (Lexing.from_string s)
module Mlstub = struct
let noloc id = Some id
module Mlstub =
struct
let noloc id = Some id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
end
module Mltypes =
struct
let lookup_value li env =
Ocaml_common.Env.find_value_by_name li env
let lookup_module li env =
let loc = Ocaml_common.Warnings.{ loc_start= Lexing.dummy_pos;
loc_end= Lexing.dummy_pos;
loc_ghost = true }
in
Ocaml_common.Env.lookup_module_path ~use:true ~load:true ~loc:loc li env
let load_path =
module Mltypes = struct
open Ocaml_common
let get_path_from_mty_alias = function
| Types.Mty_alias p -> p
| _ -> assert false
let lookup_value li env = Env.find_value_by_name li env
let lookup_module li env =
let loc =
Warnings.
{
loc_start = Lexing.dummy_pos;
loc_end = Lexing.dummy_pos;
loc_ghost = true;
}
in
Env.lookup_module_path ~use:true ~load:true ~loc li env
let is_mty_alias = function Types.Mty_alias _ -> true | _ -> false
let mty_get_path = function Types.Mty_alias p -> p | _ -> assert false
let load_path =
let once = ref false in
function () ->
if !once then () else begin
once := true;
List.iter Ocaml_common.Load_path.add_dir (List.rev !Cduce_loc.obj_path);
Ocaml_common.Load_path.add_dir Ocaml_common.Config.standard_library
end
let find_in_path file =
Ocaml_common.Misc.find_in_path_uncap (Ocaml_common.Load_path.get_paths()) file
let get_path_from_pdot e =
match e with
Ocaml_common.Path.Pdot (p, _) -> p
| _ -> assert false
let is_sig_value_val_reg e =
match e with
Ocaml_common.Types.Sig_value (_, {val_type=_;val_kind=Val_reg; _}, _) -> true
| _ -> false
let get_id_t_from_sig_value e =
match e with
Ocaml_common.Types.Sig_value (id, {val_type=t; _}, _) -> (id, t)
| _ -> assert false
let get_sig_type e =
match e with
Ocaml_common.Types.Sig_type(id, t, rs, _) -> (id, t, rs)
| _ -> assert false
function
| () ->
if !once then ()
else begin
once := true;
List.iter Load_path.add_dir (List.rev !Cduce_loc.obj_path);
Load_path.add_dir Config.standard_library
end
let find_in_path file = Misc.find_in_path_uncap (Load_path.get_paths ()) file
let get_path_from_pdot e =
match e with Path.Pdot (p, _) -> p | _ -> assert false
let is_sig_value_val_reg e =
match e with
| Types.Sig_value (_, { val_type = _; val_kind = Val_reg; _ }, _) -> true
| _ -> false
let get_id_t_from_sig_value e =
match e with
| Types.Sig_value (id, { val_type = t; _ }, _) -> (id, t)
| _ -> assert false
let get_sig_type e =
match e with
| Types.Sig_type (id, t, rs, _) -> (id, t, rs)
| _ -> assert false
end
(* Compatibilty for OCaml 4.11 & 4.12 *)
open Cduce_core
let longident_parse s = Ocaml_common.Parse.longident (Lexing.from_string s)
module Mlstub =
struct
let noloc id = Some id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
end
module Mltypes =
struct
open Ocaml_common
let get_path_from_mty_alias = function
| Types.Mty_alias p -> p
| _ -> assert false
let lookup_value li env =
Env.find_value_by_name li env
let lookup_module li env =
let loc = Warnings.{ loc_start= Lexing.dummy_pos;
loc_end= Lexing.dummy_pos;
loc_ghost = true }
in
Env.lookup_module_path ~use:true ~load:true ~loc:loc li env
let is_mty_alias = function Types.Mty_alias _ -> true | _ -> false
let mty_get_path = function Types.Mty_alias p -> p | _ -> assert false
let load_path =
let once = ref false in
function () ->
if !once then () else begin
once := true;
List.iter Load_path.add_dir (List.rev !Cduce_loc.obj_path);
Load_path.add_dir Config.standard_library
end
let find_in_path file =
Misc.find_in_path_uncap (Load_path.get_paths()) file
let get_path_from_pdot e =
match e with
Path.Pdot (p, _) -> p
| _ -> assert false
let is_sig_value_val_reg e =
match e with
Types.Sig_value (_, {val_type=_;val_kind=Val_reg; _}, _) -> true
| _ -> false
let get_id_t_from_sig_value e =
match e with
Types.Sig_value (id, {val_type=t; _}, _) -> (id, t)
| _ -> assert false
let get_sig_type e =
match e with
Types.Sig_type(id, t, rs, _) -> (id, t, rs)
| _ -> assert false
end
......@@ -75,7 +75,7 @@ and typ_descr = function
| Builtin ("Cduce_types.Atoms.V.t", []) -> Builtin_defs.atom
| Builtin ("unit", []) -> Sequence.nil_type
| Builtin ("option", [ t ]) -> Sequence.option (typ t)
| Builtin ("Stdlib.Seq.t", [t]) -> Builtin_defs.seq_type (typ t)
| Builtin ("Stdlib.Seq.t", [ t ]) -> Builtin_defs.seq_type (typ t)
| Var i -> Types.descr !vars.(i)
| _ -> assert false
......@@ -91,7 +91,7 @@ and variant = function
| lab, c, Some o ->
Types.tuple
(Types.cons (atom (Ocaml_common.Ident.name lab))
:: List.map typ (c @ [ o ]))
:: List.map typ (c @ [ o ]))
| lab, c, None ->
Types.tuple
(Types.cons (atom (Ocaml_common.Ident.name lab)) :: List.map typ c)
......@@ -624,8 +624,7 @@ and to_ml_descr e = function
ML.sapply "Cduce_core.Value.cduce2ocaml_option"
[ ML.var (to_ml_fun t); e ]
| Builtin ("Stdlib.Seq.t", [ t ]) ->
ML.sapply "Cduce_core.Value.cduce2ocaml_seq"
[ ML.var (to_ml_fun t); e ]
ML.sapply "Cduce_core.Value.cduce2ocaml_seq" [ ML.var (to_ml_fun t); e ]
| Var _ -> e
| _ -> assert false
......
......@@ -15,9 +15,9 @@ let env_initial =
~safe_string:(Ocaml.Config.safe_string || not !Ocaml.Clflags.unsafe_string)
~initially_opened_module:None ~open_implicit_modules:[]
with
Ocaml.Env.Error (err) ->
failwith @@ (Format.asprintf "%a" Ocaml.Env.report_error err)
| e -> failwith @@ "Cannot intialise OCaml environment"
| Ocaml.Env.Error err ->
failwith @@ Format.asprintf "%a" Ocaml.Env.report_error err
| e -> failwith @@ "Cannot intialise OCaml environment"
let ocaml_env = ref env_initial
......@@ -330,18 +330,23 @@ let values_of_sig name sg =
| _ -> accu)
[] sg
let find_value n = try find_value n with
PolyAbstract s -> unsupported ("polymorphic abstract type t")
let load_module name =
Mlcompat.Mltypes.load_path ();
let li = Mlcompat.longident_parse name in
ocaml_env := env_initial;
let path = Mlcompat.Mltypes.lookup_module li env_initial in
let rec loop p =
match (Ocaml.Env.find_module p env_initial).md_type with
| Ocaml.Types.Mty_signature sg -> values_of_sig name sg
| Ocaml.Types.Mty_alias p2 -> loop p2
| _ ->
raise (Loc.Generic (Printf.sprintf "Module %s is not a structure" name))
in loop path
match (Ocaml.Env.find_module p env_initial).md_type with
| Ocaml.Types.Mty_signature sg -> values_of_sig name sg
| Ocaml.Types.Mty_alias _ as alias ->
loop (Mlcompat.Mltypes.get_path_from_mty_alias alias)
| _ ->
raise (Loc.Generic (Printf.sprintf "Module %s is not a structure" name))
in
loop path
let load_module name =