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

Fix the generation of OCaml external bindings and add support for Seq.t type.

parent ea416eb4
......@@ -853,12 +853,29 @@ let cduce2ocaml_fun farg fres = function
| Abstraction (_, f) -> (fun x -> fres (f (farg x)))
| _ -> assert false
let apply f arg = match f with
| Abstraction (_,f) -> f arg
| _ -> assert false
| Abstraction (_,f) -> f arg
| _ -> assert false
let rec ocaml2cduce_seq felm f =
ocaml2cduce_fun (fun _ -> ()) (fun v ->
match v with
Seq.Nil -> nil
|Seq.Cons (a, b) ->
pair (felm a) (ocaml2cduce_seq felm b)
) f
let rec cduce2ocaml_seq felm seq =
fun () ->
match apply seq nil with
Atom a when a = Sequence.nil_atom -> Seq.Nil
| Pair {fst = x; snd= y; concat=false; _} ->
Seq.Cons (felm x, cduce2ocaml_seq felm y)
| _ -> assert false
type pools = Ns.Uri.value array * Ns.Label.value array
type pools = Ns.Uri.value array * Ns.Label.value array
let extract_all () =
Ns.Uri.extract (),
......
......@@ -143,6 +143,9 @@ val cduce2ocaml_int64 : t -> int64
val ocaml2cduce_fun: (t -> 'a) -> ('b -> t) -> ('a -> 'b) -> t
val cduce2ocaml_fun: ('a -> t) -> (t -> 'b) -> t -> ('a -> 'b)
val ocaml2cduce_seq : ('a -> t) -> 'a Seq.t -> t
val cduce2ocaml_seq : (t -> 'a) -> t -> 'a Seq.t
val print_utf8: U.t -> unit
......
......@@ -17,7 +17,7 @@ let lookup_value li env =
Ocaml_common.Env.lookup_value li env
let lookup_module li env =
Ocaml_common.Env.lookup_module ~load:false li env
Ocaml_common.Env.lookup_module ~load:true li env
let load_path () =
Ocaml_common.Config.load_path := Ocaml_common.Config.standard_library :: !Cduce_loc.obj_path
......
......@@ -17,7 +17,7 @@ let lookup_value li env =
Ocaml_common.Env.lookup_value li env
let lookup_module li env =
Ocaml_common.Env.lookup_module ~load:false li env
Ocaml_common.Env.lookup_module ~load:true li env
let load_path =
let once = ref false in
......
......@@ -16,15 +16,22 @@ let lookup_value li env =
Ocaml_common.Env.find_value_by_name li env
let lookup_module li env =
fst (Ocaml_common.Env.find_module_by_name 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 =
let once = ref false in
let add_dir s =
Ocaml_common.Load_path.add_dir s
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
List.iter add_dir (List.rev !Cduce_loc.obj_path);
add_dir Ocaml_common.Config.standard_library
end
let find_in_path file =
......
......@@ -18,8 +18,12 @@ let lookup_value li env =
Ocaml_common.Env.find_value_by_name li env
let lookup_module li env =
fst (Ocaml_common.Env.find_module_by_name 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 =
let once = ref false in
function () ->
......
......@@ -75,6 +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)
| Var i -> Types.descr !vars.(i)
| _ -> assert false
......@@ -89,8 +90,8 @@ and variant = function
(Types.cons (atom (Ocaml_common.Ident.name lab)) :: List.map typ [ o ])
| lab, c, Some o ->
Types.tuple
( Types.cons (atom (Ocaml_common.Ident.name lab))
:: List.map typ (c @ [ o ]) )
(Types.cons (atom (Ocaml_common.Ident.name lab))
:: List.map typ (c @ [ o ]))
| lab, c, None ->
Types.tuple
(Types.cons (atom (Ocaml_common.Ident.name lab)) :: List.map typ c)
......@@ -395,6 +396,8 @@ and to_cd_descr e = function
ML.(
sapply "Cduce_core.Value.sequence_rev"
[ sapply "Stdlib.List.rev_map" [ var (to_cd_fun t); e ] ])
| Builtin ("Stdlib.Seq.t", [ t ]) ->
ML.(sapply "Cduce_core.Value.ocaml2cduce_seq" [ var (to_cd_fun t); e ])
| Builtin ("array", [ t ]) ->
ML.(
sapply "Cduce_core.Value.sequence_rev"
......@@ -620,6 +623,9 @@ and to_ml_descr e = function
| Builtin ("option", [ t ]) ->
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 ]
| Var _ -> e
| _ -> assert false
......@@ -638,7 +644,7 @@ let global_transl () =
IntHash.add don hd.uid ();
let p = ML.pat_var (fun_name hd) in
let e = ML.(fun_ "x" (to_descr (var "x") hd.def)) in
defs := ML.bind p e :: !defs );
defs := ML.bind p e :: !defs);
loop ()
and loop () =
match (!to_cd_gen, !to_ml_gen) with
......@@ -678,7 +684,7 @@ let check_value ty_env c_env (s, caml_t, t) =
Expected CDuce type:@[%a@]@\n\
Inferred type:@[%a@]@." s print_ocaml caml_t Types.Print.print et
Types.Print.print vt;
exit 1 );
exit 1);
(* Generate stub code *)
let x = mk_var () in
......@@ -736,8 +742,7 @@ let stub binary name ty_env c_env exts values mk prolog =
pat_var "slots";
pat_var "run";
])
(sapply "Cduce_core.Librarian.ocaml_stub"
[ str raw ]);
(sapply "Cduce_core.Librarian.ocaml_stub" [ str raw ]);
];
Str.value rec_ g;
Str.eval (sapply "set_externals" [ Exp.array exts ]);
......@@ -804,7 +809,7 @@ let register b s args =
if b then (
let i = List.length !exts in
exts := (s, t) :: !exts;
i )
i)
else 0
in
vars := Array.of_list args;
......@@ -856,19 +861,19 @@ let gen_wrapper vals =
let make_wrapper binary fn =
let ic = open_in fn in
let v = ref [] in
( try
while true do
let s = input_line ic in
if s <> "" then
match s.[0] with
| 'A' .. 'Z' -> v := s :: !v
| '#' -> ()
| _ ->
failwith
"Error in primitive file: names must start with a capitalized \
letter"
done
with End_of_file -> () );
(try
while true do
let s = input_line ic in
if s <> "" then
match s.[0] with
| 'A' .. 'Z' -> v := s :: !v
| '#' -> ()
| _ ->
failwith
"Error in primitive file: names must start with a capitalized \
letter"
done
with End_of_file -> ());
let s = gen_wrapper !v in
let epilogue =
let open Ast_helper in
......
......@@ -9,11 +9,15 @@ exception PolyAbstract of string
let env_initial =
try
Mlcompat.Mltypes.load_path ();
Ocaml.Typemod.initial_env
~loc:(Ocaml.Location.in_file "Ocaml/Cduce interface")
~safe_string:(Ocaml.Config.safe_string || not !Ocaml.Clflags.unsafe_string)
~initially_opened_module:None ~open_implicit_modules:[]
with _e -> failwith "here"
with
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
......@@ -62,7 +66,7 @@ let rec print_slot ppf slot =
if IntMap.mem slot.uid !printed then Format.fprintf ppf "X%i" slot.uid
else (
printed := IntMap.add slot.uid () !printed;
Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def )
Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def)
else print_def ppf slot.def
and print_def ppf = function
......@@ -139,6 +143,7 @@ let builtins =
[
"list";
"Stdlib.ref";
"Stdlib.Seq.t";
"unit";
"array";
"Big_int.big_int";
......@@ -168,14 +173,14 @@ let rec unfold_constr env p args =
if StringSet.mem pn builtins then (
let slot = new_slot () in
slot.def <- Builtin (pn, args);
slot )
slot)
else
let args_id = List.map (fun t -> t.uid) args in
let k = (pn, args_id) in
try Hashtbl.find constr_table k
with Not_found ->
if StringSet.mem pn env.constrs then
failwith "Polymorphic recursion forbidden";
failwith ("Polymorphic recursion forbidden : " ^ pn);
let slot = new_slot () in
slot.recurs <- 1;
Hashtbl.add constr_table k slot;
......@@ -206,7 +211,7 @@ let rec unfold_constr env p args =
in
slot.def <-
( match (decl.type_kind, decl.type_manifest) with
(match (decl.type_kind, decl.type_manifest) with
| Type_variant cstrs, _ ->
let cstrs =
(* TODO: Check this solution *)
......@@ -238,8 +243,8 @@ let rec unfold_constr env p args =
Record (prefix, f, true)
| Type_abstract, Some t -> Link (unfold env t)
| Type_abstract, None -> (
match args with [] -> Abstract pn | _l -> raise (PolyAbstract pn) )
| Type_open, _ -> failwith "unsupported open type" );
match args with [] -> Abstract pn | _l -> raise (PolyAbstract pn))
| Type_open, _ -> failwith "unsupported open type");
slot
and unfold env ty =
......@@ -247,13 +252,13 @@ and unfold env ty =
let env = { env with seen = IntSet.add ty.id env.seen } in
let slot = new_slot () in
slot.def <-
( match ty.desc with
(match ty.desc with
| 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 ->
| Ttuple tyl -> Tuple (List.map (unfold env) tyl)
| Tvariant rd ->
let fields =
List.fold_left
(fun accu (lab, f) ->
......@@ -272,9 +277,9 @@ and unfold env ty =
PVariant fields
| 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" );
with Not_found -> Var (get_var ty.id))
| Tconstr (p, args, _) -> Link (unfold_constr env p args)
| _ -> failwith "Unsupported feature");
slot
let unfold ty =
......@@ -319,9 +324,9 @@ let values_of_sig name sg =
match id.[0] with
| 'a' .. 'z' | '_' -> (
let n = name ^ "." ^ id in
try (n, fst (find_value n)) :: accu with PolyAbstract _ -> accu )
try (n, fst (find_value n)) :: accu with PolyAbstract _ -> accu)
| _ -> accu
(* operator *) )
(* operator *))
| _ -> accu)
[] sg
......@@ -330,17 +335,13 @@ let load_module name =
let li = Mlcompat.longident_parse name in
ocaml_env := env_initial;
let path = Mlcompat.Mltypes.lookup_module li env_initial in
let mty = Ocaml.Env.find_modtype_expansion path env_initial in
match mty with
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))
(*
let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
let sg = Env.read_signature name filename in
values_of_sig sg
*)
in loop path
let load_module name =
try load_module name
......@@ -354,11 +355,8 @@ let load_module name =
let build_type_decl id t rs =
match Ocaml.Printtyp.tree_of_type_declaration id t rs with
Outcometree.Osig_type (otdecl, ors) ->
Ast_helper.Str.type_
| _ -> assert false
| Outcometree.Osig_type (otdecl, ors) -> Ast_helper.Str.type_
| _ -> assert false
let read_cmi name =
Mlcompat.Mltypes.load_path ();
......@@ -399,4 +397,4 @@ let read_cmi name =
in
raise (Loc.Generic s)
let print_ocaml = Ocaml.Printtyp.type_expr
\ No newline at end of file
let print_ocaml = Ocaml.Printtyp.type_expr
......@@ -34,17 +34,24 @@ let protect f g =
g ();
raise e
let cduce_compile_rule base =
let cduce_prog ext =
if ext then "cduce_external"
else "cduce"
let cduce_compile_rule ?(ext=false) base =
let cduce = cduce_prog ext in
let cflags = base ^ ".cflags" in
let cdo = base ^ ".cdo" in
let cd = base ^ ".cd" in
let cf = if Sys.file_exists cflags then "%%{read:" ^ cflags ^ "}" else "" in
Format.printf
"(rule (deps %s) (target %s)\n\
\ (action (ignore-outputs (with-accepted-exit-codes 0 (run cduce --compile %s %%{deps})))))\n"
cd cdo cf
\ (action (ignore-outputs (with-accepted-exit-codes 0 (run %s --compile %s %%{deps})))))\n"
cd cdo cduce cf
let cduce_run_rule base kind =
let cduce_run_rule ?(ext=false) base kind =
let cduce = cduce_prog ext in
let rflags = base ^ ".rflags" in
let cdo = base ^ ".cdo" in
let out = base ^ ".out" in
......@@ -56,21 +63,21 @@ let cduce_run_rule base kind =
in
Format.printf
"(rule (deps %s) (target %s)\n\
\ (action (%s %%{target} (with-accepted-exit-codes %s (run cduce --run \
\ (action (%s %%{target} (with-accepted-exit-codes %s (run %s --run \
%s %%{deps})))%s))\n"
cdo out write_output code rf close
cdo out write_output code cduce rf close
let diff_rule base =
let exp = base ^ ".exp" in
let out = base ^ ".out" in
Format.printf "(rule (alias %s) (action (diff %s %s)))\n" base exp out
let gen_cduce_test kind acc f =
let gen_cduce_test ?(ext=false) kind acc f =
if check_file f ".cd" then begin
let base = Filename.remove_extension f in
Format.printf "; begin: %s\n" f;
cduce_compile_rule base;
cduce_run_rule base kind;
cduce_compile_rule ~ext base;
cduce_run_rule base ~ext kind;
diff_rule base;
Format.printf "; end: %s\n\n" f;
......
......@@ -167,3 +167,14 @@ let any_xml, _any_xml_seq, any_xml_content =
(elt_d, seq_d, any_xml_content)
let any_xml_with_tag t = Types.xml (Types.cons (Types.atom t)) any_xml_content
let seq_type t =
let s = Types.make () in
let s_def =
Types.arrow (Types.cons nil)
(Types.cons (Types.cup nil
(Types.times t s)))
in
Types.define s s_def;
s_def
\ No newline at end of file
......@@ -77,3 +77,5 @@ val float_abs : Types.Abstract.abs
val any_xml : Types.t
val any_xml_with_tag : Atoms.t -> Types.t
val seq_type : Types.Node.t -> Types.t
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