Commit 25dec7e5 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Further improve the OCaml/CDuce interface. Fix several bugs for optional and

labelled arguments. All monorphic modules the OCaml standard library are
available with the Stdlib prefix (e.g. Stdlib.Sys.file_exists).
parent 25703954
......@@ -2,6 +2,8 @@ open Cduce_core
let () = Stats.gettimeofday := Unix.gettimeofday
let external_init = ref None
let out_dir = ref [] (* directory of the output file *)
let src = ref []
......@@ -205,7 +207,13 @@ let main () =
Cduce_loc.set_viewport (Html.create false);
let m = mode () in
(* May call Cduce_config.inhibit while parsing the command line *)
let () = Cduce_config.init_all () in
let () = match !external_init with
Some f when
List.exists (fun (n, _) -> n = "ocaml") (Cduce_config.descrs ())
-> f () (* calls Cduce_config.init_all ()*)
| _ -> Cduce_config.init_all ()
in
match m with
| `Toplevel args ->
Cduce_driver.set_argv args;
......
......@@ -6,6 +6,21 @@
(libraries cduce-types cduce.lib)
(modes byte native))
(executable
(name cduce_bootstrap)
(modules cduce_bootstrap)
(libraries cduce-types cduce.lib)
(modes byte native))
(rule
(deps ocaml.prims)
(target cduce.ml)
(action
(ignore-stderr
(with-stdout-to
%{target}
(run ./cduce_bootstrap.exe --topstub %{deps})))))
(executable
(name cduce_js_top)
(modules cduce_js_top)
......
Stdlib.Buffer
Stdlib.Bytes
Stdlib.Char
Stdlib.Complex
Stdlib.Digest
Stdlib.Filename
Stdlib.Float
Stdlib.Int32
Stdlib.Int64
Stdlib.Random
Stdlib.String
Stdlib.Sys
......@@ -42,4 +42,14 @@ module Mltypes = struct
let get_sig_type e =
match e with Types.Sig_type (id, t, rs) -> (id, t, rs) | _ -> assert false
let is_sig_value_deprecated e =
match e with
| Types.Sig_value (_, { val_attributes; _ }) ->
List.exists
(fun att ->
let txt = Asttypes.((fst att).txt) in
txt = "ocaml.deprecated" || txt = "deprecated")
val_attributes
| _ -> assert false
end
......@@ -52,4 +52,14 @@ module Mltypes = struct
match e with
| Types.Sig_type (id, t, rs, _) -> (id, t, rs)
| _ -> assert false
let is_sig_value_deprecated e =
match e with
| Types.Sig_value (_, { val_attributes; _ }, _) ->
List.exists
(fun att ->
let txt = Parsetree.(att.attr_name.txt) in
txt = "ocaml.deprecated" || txt = "deprecated")
val_attributes
| _ -> assert false
end
......@@ -62,4 +62,14 @@ module Mltypes = struct
match e with
| Types.Sig_type (id, t, rs, _) -> (id, t, rs)
| _ -> assert false
let is_sig_value_deprecated e =
match e with
| Types.Sig_value (_, { val_attributes; _ }, _) ->
List.exists
(fun att ->
let txt = Parsetree.(att.attr_name.txt) in
txt = "ocaml.deprecated" || txt = "deprecated")
val_attributes
| _ -> assert false
end
......@@ -33,9 +33,6 @@ let loc = Warnings.{ loc_start= Lexing.dummy_pos;
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 () ->
......@@ -68,4 +65,13 @@ let get_sig_type e =
Types.Sig_type(id, t, rs, _) -> (id, t, rs)
| _ -> assert false
let is_sig_value_deprecated e =
match e with
Types.Sig_value (_, { val_attributes ; _ }, _) ->
List.exists (fun att ->
let txt = Parsetree.(att.attr_name.txt) in
txt = "ocaml.deprecated" || txt = "deprecated"
) val_attributes
| _ -> assert false
end
......@@ -92,7 +92,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)
......@@ -205,6 +205,8 @@ module ML = struct
let pstr s = Pat.constant (Const.string s)
let assert_false = Exp.assert_ (constr "false" None)
let seq e1 e2 = Exp.sequence e1 e2
end
module CD = struct
......@@ -241,8 +243,6 @@ let gen_types = ref true
(* currently always off *)
module HashTypes = Hashtbl.Make (Types)
let registered_types = ref []
let nb_registered_types = ref 0
......@@ -293,7 +293,7 @@ let is_recursive (t : Mltypes.t) =
(* OCaml -> CDuce conversions *)
let to_cd_gen = ref []
let to_cd_hash = HashType.create 17
let to_cd_fun_name t = Printf.sprintf "to_cd_%i" t.uid
......@@ -307,13 +307,15 @@ let rec to_cd_fun t =
| Builtin ("Cduce_types.Encodings.Utf8.t", []) ->
"Value.ocaml2cduce_string_utf8"
| Builtin ("Cduce_types.Atoms.V.t", []) -> "Value.ocaml2cduce_atom"
| Link tt when t.recurs <= 0 -> to_cd_fun tt
| Link ({ def = (Link _ | Builtin (_, [])| Abstract _); _} as tt) -> to_cd_fun tt
| _ ->
to_cd_gen := t :: !to_cd_gen;
to_cd_fun_name t
| Link tt -> to_cd_fun tt
| _ -> (
try HashType.find to_cd_hash t
with Not_found ->
let n = to_cd_fun_name t in
HashType.add to_cd_hash t n;
n)
let to_ml_gen = ref []
let to_ml_hash = HashType.create 17
let to_ml_fun_name t = Printf.sprintf "to_ml_%i" t.uid
......@@ -328,12 +330,13 @@ let rec to_ml_fun t =
| Builtin ("Cduce_types.Encodings.Utf8.t", []) ->
"Value.cduce2ocaml_string_utf8"
| Builtin ("Cduce_types.Atoms.V.t", []) -> "Value.cduce2ocaml_atom"
| Link tt when t.recurs <= 0 -> to_ml_fun tt
| Link ({ def = (Link _ | Builtin (_, [])| Abstract _); _} as tt) -> to_ml_fun tt
| _ ->
Format.eprintf "Getting %a in to_ml_fun (%b)\n%!" Mltypes.print t (t.recurs > 0);
to_ml_gen := t :: !to_ml_gen;
to_ml_fun_name t
| Link tt -> to_ml_fun tt
| _ -> (
try HashType.find to_ml_hash t
with Not_found ->
let n = to_ml_fun_name t in
HashType.add to_ml_hash t n;
n)
let call_lab f l x =
if l = "" then ML.apply f [ (ML.no_label, x) ]
......@@ -346,7 +349,7 @@ let abstr_lab l x res =
if l = "" then ML.fun_ x res
else
let ll = String.sub l 1 (String.length l - 1) in
if l.[0] = '?' then ML.fun_l ll x res else ML.fun_o ll x res
if l.[0] = '?' then ML.fun_o ll x res else ML.fun_l ll x res
let rec to_cd e t =
(* Format.fprintf Format.err_formatter "to_cd %a [uid=%i; recurs=%i]@."
......@@ -363,7 +366,7 @@ and to_cd_descr e t =
let x = mk_var () in
let arg = to_ml (ML.var x) t in
let res = to_cd (call_lab y l arg) s in
let abs = abstr_lab l x res in
let abs = abstr_lab "" x res in
let iface =
if !gen_types then
let tt = register_type (Types.descr (typ t)) in
......@@ -408,7 +411,8 @@ and to_cd_descr e t =
(fun (lab, args, res) ->
let lab = Ocaml_common.Ident.name lab in
match (args, res) with
| [], None -> ML.(case (pconstr lab None) (CD.atom_ascii lab))
| [], None -> ML.(
case (pconstr (p ^ lab) None) (CD.atom_ascii lab))
| tl, Some o ->
let vars = mk_vars (tl @ [ o ]) in
ML.(
......@@ -656,16 +660,30 @@ and to_ml_descr e t =
and tuple_to_ml tl vars =
ML.tuple (List.map2 (fun t id -> to_ml (ML.var id) t) tl vars)
let to_ml_done = IntHash.create 13
let to_cd_done = IntHash.create 13
let global_transl () =
let defs = ref [] in
let gen_binding tbl to_descr =
let l = tbl |> HashType.to_seq |> List.of_seq in
HashType.clear tbl;
List.iter
(fun (t, fun_name) ->
let p = ML.pat_var fun_name in
let e = ML.(fun_ "x" (to_descr (var "x") t)) in
defs := ML.bind p e :: !defs)
l
in
while HashType.length to_cd_hash != 0 || HashType.length to_ml_hash != 0 do
gen_binding to_cd_hash to_cd_descr;
gen_binding to_ml_hash to_ml_descr
done;
!defs
(*
let defs = ref [] in
let rec aux hd tl gen don fun_name to_descr =
gen := tl;
if not (IntHash.mem don hd.uid) then (
IntHash.add don hd.uid ();
if not (HashType.mem don hd) then (
HashType.add don hd ();
let p = ML.pat_var (fun_name hd) in
let e = ML.(fun_ "x" (to_descr (var "x") hd)) in
defs := ML.bind p e :: !defs);
......@@ -678,7 +696,7 @@ let global_transl () =
in
loop ();
!defs
*)
(* Check type constraints and generate stub code *)
let err_ppf = Format.err_formatter
......@@ -853,17 +871,27 @@ let wrapper values =
List.rev_map
(fun (s, t) ->
let v = to_cd (ML.var s) t in
Str.eval ML.(sapply "Librarian.register_static_external" [ str_e s; v ]))
ML.(sapply "Librarian.register_static_external" [ str_e s; v ]))
values
in
let g = global_transl () in
ML.
[
Mlcompat.Mlstub.str_open (lid "Cduce_lib");
Str.eval (sapply "Cduce_config.init_all" [ unit ]);
Str.value rec_ g;
]
@ exts
let g =
match global_transl () with [] -> ML.[ bind (pany ()) unit ] | g -> g
in
ML.(
fun_unit
(seq
(sapply "Cduce_config.init_all" [ unit ])
(Exp.let_ rec_ g
(List.fold_left
(fun acc e -> seq e acc)
(Exp.setfield
(Exp.ident (lid "Cduce_loc.obj_path"))
(lid "contents")
(list_list
(List.map (fun p -> str p) !Cduce_core.Cduce_loc.obj_path)))
exts))))
(* Mlcompat.Mlstub.str_open (lid "Cduce_lib"); *)
let gen_wrapper vals =
try
......@@ -902,17 +930,16 @@ let make_wrapper binary fn =
let epilogue =
let open Ast_helper in
[
Mlcompat.Mlstub.str_open (ML.lid "Cduce_lib");
Str.eval
(Exp.setfield
(Exp.ident (ML.lid "Cduce_loc.obj_path"))
(ML.lid "contents")
(ML.list_list
(List.map (fun p -> ML.str p) !Cduce_core.Cduce_loc.obj_path)));
(Exp.ident (ML.lid "Cduce_lib.Run.external_init"))
(ML.lid "contents") (ML.some s));
Str.eval (ML.sapply "Cduce_lib.Run.main" [ ML.unit ]);
]
in
let structure = s @ epilogue in
let structure = epilogue in
if binary then begin
output_string stdout Config.ast_impl_magic_number;
output_value stdout fn;
......
......@@ -34,6 +34,11 @@ and def =
| Abstract of string
| Var of int
let for_all2 f l1 l2 = try List.for_all2 f l1 l2 with _ -> false
let for_opt f o1 o2 =
match (o1, o2) with Some v1, Some v2 -> f v1 v2 | _ -> false
module IntMap = Map.Make (struct
type t = int
......@@ -97,7 +102,66 @@ and print_alt ppf = function
and print_field ppf (lab, t) =
Format.fprintf ppf "%s:%a" (Ocaml.Ident.name lab) print_slot t
let print = print_slot
let print ppf t =
printed := IntMap.empty;
print_slot ppf t
let equal_type t1 t2 =
let visited = Hashtbl.create 17 in
let rec loop t1 t2 =
if t1 == t2 || t1.uid = t2.uid then true
else if Hashtbl.mem visited t1.uid then true
else
let () = Hashtbl.add visited t1.uid () in
loop_def t1 t2
and loop_def t1 t2 =
match (t1.def, t2.def) with
| Link tt1, Link tt2 -> loop tt1 tt2
| Link tt1, _ -> loop tt1 t2
| _, Link tt2 -> loop t1 tt2
| Arrow (s1, t1, u1), Arrow (s2, t2, u2) ->
s1 = s2 && loop t1 t2 && loop u1 u2
| Tuple tl1, Tuple tl2 -> for_all2 loop tl1 tl2
| PVariant l1, PVariant l2 ->
for_all2 (fun (s1, o1) (s2, o2) -> s1 = s2 && for_opt loop o1 o2) l1 l2
| Variant (s1, l1, b1), Variant (s2, l2, b2) ->
s1 = s2 && b1 = b2
&& for_all2
(fun (i1, ll1, o1) (i2, ll2, o2) ->
Ocaml.Ident.same i1 i2 && for_opt loop o1 o2
&& for_all2 loop ll1 ll2)
l1 l2
| Record (s1, f1, b1), Record (s2, f2, b2) ->
s1 = s2 && b1 = b2
&& for_all2
(fun (i1, t1) (i2, t2) -> Ocaml.Ident.same i1 i2 && loop t1 t2)
f1 f2
| Builtin (s1, l1), Builtin (s2, l2) -> s1 = s2 && for_all2 loop l1 l2
| Abstract s1, Abstract s2 -> s1 = s2
| Var i1, Var i2 -> i1 = i2
| _, _ -> false
in
loop t1 t2
module HashType = Hashtbl.Make (struct
type key = t
type t = key
let rec hash t =
match t.def with
| Link tt -> hash tt
| Arrow _ -> Hashtbl.hash "ARROW"
| Tuple _ -> Hashtbl.hash "TUPLE"
| Variant _ -> Hashtbl.hash "VARIANT"
| PVariant _ -> Hashtbl.hash "PVARIANT"
| Record _ -> Hashtbl.hash "RECORD"
| Builtin _ -> Hashtbl.hash "BUILTIN"
| Abstract s -> Hashtbl.hash "ABSTRACT"
| Var _ -> Hashtbl.hash "VAR"
let equal t1 t2 = equal_type t1 t2
end)
let counter = ref 0
......@@ -257,12 +321,14 @@ and unfold env ty =
let slot = new_slot () in
slot.def <-
(match ty.desc with
| Tarrow (_l, t1, t2, _) ->
| Tarrow (Optional _, _, t2, _) -> (unfold env t2).def
| Tarrow (l, t1, t2, _) ->
let t1 = unfold env t1 in
let t2 = unfold env t2 in
Arrow ("", t1, t2)
| Ttuple tyl -> Tuple (List.map (unfold env) tyl)
| Tvariant rd ->
Arrow ((match l with Labelled s -> "~" ^ s | _ -> ""), t1, t2)
| Ttuple tyl -> Tuple (List.map (unfold env) tyl)
| Tvariant rd ->
let fields =
List.fold_left
(fun accu (lab, f) ->
......@@ -279,11 +345,11 @@ and unfold env ty =
[] rd.row_fields
in
PVariant fields
| Tvar _s -> (
| Tvar _s -> (
try Link (IntMap.find ty.id env.vars)
with Not_found -> Var (get_var ty.id))
| Tconstr (p, args, _) -> Link (unfold_constr env p args)
| _ -> failwith "Unsupported feature");
| Tconstr (p, args, _) -> Link (unfold_constr env p args)
| _ -> failwith "Unsupported feature");
slot
let unfold ty =
......@@ -322,7 +388,8 @@ let values_of_sig name sg =
List.fold_left
(fun accu v ->
match v with
| Ocaml.Types.Sig_value _ -> (
| Ocaml.Types.Sig_value _ as s
when not (Mlcompat.Mltypes.is_sig_value_deprecated s) -> (
let id, _ = Mlcompat.Mltypes.get_id_t_from_sig_value v in
let id = Ocaml.Ident.name id in
match id.[0] with
......@@ -331,11 +398,12 @@ let values_of_sig name sg =
try (n, fst (find_value n)) :: accu with PolyAbstract _ -> accu)
| _ -> accu
(* operator *))
| _ -> accu)
| _ -> accu)
[] sg
let find_value n = try find_value n with
PolyAbstract s -> unsupported ("polymorphic abstract type t")
let find_value n =
try find_value n
with PolyAbstract s -> unsupported "polymorphic abstract type t"
let load_module name =
Mlcompat.Mltypes.load_path ();
......@@ -379,10 +447,12 @@ let read_cmi name =
(function
| Ocaml.Types.Sig_value _ as s
when Mlcompat.Mltypes.is_sig_value_val_reg s ->
let id, t = Mlcompat.Mltypes.get_id_t_from_sig_value s in
let unf, n = unfold t in
if n != 0 then unsupported "polymorphic value";
values := (Ocaml.Ident.name id, t, unf) :: !values
if not (Mlcompat.Mltypes.is_sig_value_deprecated s) then begin
let id, t = Mlcompat.Mltypes.get_id_t_from_sig_value s in
let unf, n = unfold t in
if n != 0 then unsupported "polymorphic value";
values := (Ocaml.Ident.name id, t, unf) :: !values
end
| Sig_type _ as s ->
let id, t, rs = Mlcompat.Mltypes.get_sig_type s in
Format.fprintf ppf "%a@." !Ocaml.Oprint.out_sig_item
......
......@@ -13,6 +13,8 @@ and def =
| Abstract of string
| Var of int
module HashType : Hashtbl.S with type key = t
val reg_uid : t -> unit
(* Load an external .cmi *)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment