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).

backend/native/run.ml

@@ -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;

driver/dune

@@ -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)

driver/ocaml.prims

+Stdlib.Buffer
+Stdlib.Bytes
+Stdlib.Char
+Stdlib.Complex
+Stdlib.Digest
+Stdlib.Filename
+Stdlib.Float
+Stdlib.Int32
+Stdlib.Int64
+Stdlib.Random
+Stdlib.String
+Stdlib.Sys

ocamliface/mlcompat_407.ml

@@ -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

ocamliface/mlcompat_408_9.ml

@@ -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

ocamliface/mlcompat_410.ml

@@ -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

ocamliface/mlcompat_411_12.ml

@@ -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

ocamliface/mlstub.real.ml

@@ -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;

ocamliface/mltypes.real.ml

@@ -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

ocamliface/mltypes.real.mli

@@ -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 *)