Commit 8ad17987 authored by Julien Lopez's avatar Julien Lopez
Browse files

Fixes on ocaml interface (code and tests)

parent e0fb3c2c
......@@ -10,7 +10,7 @@ open Camlp4.PreCast
let _loc = Loc.ghost
module IntMap =
module IntMap =
Map.Make(struct type t = int let compare : t -> t -> int = compare end)
module IntHash =
......@@ -87,7 +87,7 @@ and typ_descr = function
| Builtin ("option", [t]) -> Sequence.option (typ t)
| Var i -> Types.descr (!vars).(i)
| _ -> assert false
and pvariant = function
| (lab, None) -> atom lab
| (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)
......@@ -114,9 +114,9 @@ let atom_ascii lab =
let label_ascii lab =
<:expr< Value.label_ascii $str: String.escaped lab$ >>
let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$) >>
let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$, Value.Mono) >>
let pmatch e l =
let pmatch e l =
<:expr< match $e$ with [ $list:l$ ] >>
let rec matches ine oute = function
......@@ -137,7 +137,7 @@ let protect e f =
| e ->
let x = mk_var () in
let r = f <:expr< $lid:x$ >> in
<:expr< let $lid:x$ = $e$ in $r$ >>
<:expr< let $lid:x$ = $e$ in $r$ >>
(* Registered types *)
......@@ -157,7 +157,7 @@ let register_type t =
let i = !nb_registered_types in
HashTypes.add registered_types t i;
incr nb_registered_types;
i
i
in
<:expr< types.($int:string_of_int n$) >>
......@@ -171,7 +171,7 @@ let get_registered_types () =
let to_cd_gen = ref []
let to_cd_fun_name t =
let to_cd_fun_name t =
Printf.sprintf "to_cd_%i" t.uid
let to_cd_fun t =
......@@ -189,10 +189,10 @@ let to_ml_fun t =
let rec tuple = function
| [v] -> v
| v::l -> <:expr< Value.Pair ($v$, $tuple l$) >>
| v::l -> <:expr< Value.Pair ($v$, $tuple l$, Value.Mono) >>
| [] -> assert false
let pat_tuple vars =
let pat_tuple vars =
let pl = List.map (fun id -> <:patt< $lid:id$ >>) vars in
<:patt< ($Ast.paCom_of_list pl$) >>
......@@ -200,16 +200,16 @@ let pat_tuple vars =
let call_lab f l x =
if l = "" then <:expr< $f$ $x$ >>
else
if l.[0] = '?' then
if l.[0] = '?' then
let l = String.sub l 1 (String.length l - 1) in
<:expr< $f$ (? $l$ : $x$) >>
else
else
<:expr< $f$ (~ $l$ : $x$) >>
let abstr_lab l x res =
if l = "" then <:expr< fun $lid:x$ -> $res$ >>
else
if l.[0] = '?' then
if l.[0] = '?' then
let l = String.sub l 1 (String.length l - 1) in
<:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
else
......@@ -221,13 +221,13 @@ let rec to_cd e t =
(* Format.fprintf Format.err_formatter "to_cd %a [uid=%i; recurs=%i]@."
Mltypes.print t t.uid t.recurs; *)
if t.recurs > 0 then <:expr< $lid:to_cd_fun t$ $e$ >>
else to_cd_descr e t.def
else to_cd_descr e t.def
and to_cd_descr e = function
| Link t -> to_cd e t
| Arrow (l,t,s) ->
| Arrow (l,t,s) ->
(* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
protect e
protect e
(fun y ->
let x = mk_var () in
let arg = to_ml <:expr< $lid:x$ >> t in
......@@ -239,33 +239,33 @@ and to_cd_descr e = function
let ss = register_type (Types.descr (typ s)) in
<:expr< Some [($tt$,$ss$)] >>
else <:expr< None >> in
<:expr< Value.Abstraction ($iface$,$abs$) >>
<:expr< Value.Abstraction ($iface$,$abs$, Value.Mono) >>
)
| Tuple tl ->
| Tuple tl ->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
let vars = mk_vars tl in
<:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
| PVariant l ->
(* match <...> with
| `A -> Value.atom_ascii "A"
(* match <...> with
| `A -> Value.atom_ascii "A"
| `B x -> Value.Pair (Value.atom_ascii "B",t(x))
*)
let cases =
let cases =
List.map
(function
(function
| (lab,None) -> <:match_case< `$lid:lab$ -> $atom_ascii lab$ >>
| (lab,Some t) -> <:match_case< `$lid:lab$ x ->
$pair (atom_ascii lab) (to_cd <:expr< x >> t)$ >>
) l in
pmatch e cases
| Variant (p,l,_) ->
(* match <...> with
| P.A -> Value.atom_ascii "A"
(* match <...> with
| P.A -> Value.atom_ascii "A"
| P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
*)
let cases =
let cases =
List.map
(function
(function
| (lab,[],None) ->
let pat = match lab.Caml_cduce.Ident.name with (* Stupid Camlp4 *)
| "true" -> <:patt< True >>
......@@ -287,7 +287,7 @@ and to_cd_descr e = function
(* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
protect e
(fun x ->
let l =
let l =
List.map
(fun (lab,t) ->
let lab = lab.Caml_cduce.Ident.name in
......@@ -306,14 +306,14 @@ and to_cd_descr e = function
| Builtin ("array",[t]) ->
<:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
| Builtin ("Pervasives.ref",[t]) ->
(* let x = <...> in
(* let x = <...> in
Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
protect e
protect e
(fun e ->
let y = mk_var () in
let tt = if !gen_types then
let tt = if !gen_types then
let t = register_type (Types.descr (typ t)) in
<:expr< Some $t$ >>
<:expr< Some $t$ >>
else
<:expr< None >> in
let get_x = <:expr< $e$.val >> in
......@@ -322,10 +322,10 @@ and to_cd_descr e = function
let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
<:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
)
| Builtin ("Big_int.big_int", []) ->
| Builtin ("Big_int.big_int", []) ->
<:expr< Value.ocaml2cduce_bigint $e$ >>
| Builtin ("Cduce_lib.Value.t", []) -> e
| Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
| Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
<:expr< Value.ocaml2cduce_string_utf8 $e$ >>
| Builtin ("Cduce_lib.Atoms.V.t", []) ->
<:expr< Value.ocaml2cduce_atom $e$ >>
......@@ -350,9 +350,9 @@ and to_ml (e : Ast.expr) (t : Mltypes.t) =
and to_ml_descr e = function
| Link t -> to_ml e t
| Arrow (l,t,s) ->
| Arrow (l,t,s) ->
(* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
protect e
protect e
(fun y ->
let x = mk_var () in
let arg = to_cd <:expr< $lid:x$ >> t in
......@@ -360,7 +360,7 @@ and to_ml_descr e = function
abstr_lab l x res
)
| Tuple tl ->
| Tuple tl ->
(* let (x1,r) = Value.get_pair <...> in
let (x2,r) = Value.get_pair r in
...
......@@ -370,21 +370,21 @@ and to_ml_descr e = function
let vars = mk_vars tl in
matches e <:expr< $tuple_to_ml tl vars$ >> vars
| PVariant l ->
(* match Value.get_variant <...> with
| "A",None -> `A
(* match Value.get_variant <...> with
| "A",None -> `A
| "B",Some x -> `B (t(x))
| _ -> assert false
*)
let cases =
List.map
(function
| (lab,None) ->
<:match_case<
let cases =
List.map
(function
| (lab,None) ->
<:match_case<
($str: String.escaped lab$, None) -> `$lid:lab$ >>
| (lab,Some t) ->
let x = mk_var () in
let ex = <:expr< $lid:x$ >> in
<:match_case<
<:match_case<
($str: String.escaped lab$, Some $lid:x$) ->
`$lid:lab$ $to_ml ex t$ >>
) l in
......@@ -393,14 +393,14 @@ and to_ml_descr e = function
| Variant (_,l,false) ->
failwith "Private Sum type"
| Variant (p,l,true) ->
(* match Value.get_variant <...> with
| "A",None -> P.A
| "B",Some x -> let (x1,r) = x in ...
(* match Value.get_variant <...> with
| "A",None -> P.A
| "B",Some x -> let (x1,r) = x in ...
*)
let cases =
List.map
(function
| (lab,[],None) ->
let cases =
List.map
(function
| (lab,[],None) ->
let lab = lab.Caml_cduce.Ident.name in
let pa = <:patt< ($str: String.escaped lab$, None) >>
and e = match lab with (* Stupid Camlp4 *)
......@@ -454,13 +454,13 @@ and to_ml_descr e = function
| Record (p,l,true) ->
(* let x = <...> in
{ P.l1 = t1(Value.get_field x "l1"); ... } *)
protect e
protect e
(fun x ->
let l =
let l =
List.map
(fun (lab,t) ->
let lab = lab.Caml_cduce.Ident.name in
let e =
let e =
to_ml <:expr< Value.get_field $x$ $label_ascii lab$ >> t in
<:rec_binding< $id: id (p^lab)$ = $e$ >>) l in
<:expr< {$list:l$} >>)
......@@ -480,10 +480,10 @@ and to_ml_descr e = function
let e = <:expr< Value.get_field $e$ $label_ascii "get"$ >> in
let e = <:expr< Eval.eval_apply $e$ Value.nil >> in
<:expr< Pervasives.ref $to_ml e t$ >>
| Builtin ("Big_int.big_int", []) ->
| Builtin ("Big_int.big_int", []) ->
<:expr< Value.cduce2ocaml_bigint $e$ >>
| Builtin ("Cduce_lib.Value.t", []) -> e
| Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
| Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
<:expr< Value.cduce2ocaml_string_utf8 $e$ >>
| Builtin ("Cduce_lib.Atoms.V.t", []) ->
<:expr< Value.cduce2ocaml_atom $e$ >>
......@@ -494,14 +494,14 @@ and to_ml_descr e = function
| _ -> assert false
and tuple_to_ml tl vars =
Ast.exCom_of_list
Ast.exCom_of_list
(List.map2 (fun t id -> to_ml <:expr< $lid:id$ >> t) tl vars)
let to_ml_done = IntHash.create 13
let to_cd_done = IntHash.create 13
let global_transl () =
let global_transl () =
let defs = ref [] in
let rec aux hd tl gen don fun_name to_descr =
gen := tl;
......@@ -529,7 +529,7 @@ let exts = ref []
let check_value ty_env c_env (s,caml_t,t) =
(* Find the type for the value in the CDuce module *)
let id = (Ns.empty, U.mk s) in
let vt =
let vt =
try Typer.find_value id ty_env
with Not_found ->
Format.fprintf err_ppf
......@@ -554,7 +554,7 @@ let check_value ty_env c_env (s,caml_t,t) =
Types.Print.print vt;
exit 1
);
(* Generate stub code *)
let x = mk_var () in
let slot = Compile.find_slot id c_env in
......@@ -587,20 +587,20 @@ let stub ty_env c_env exts values mk prolog =
let items_expr = List.map (fun (_,e,_) -> e) items in
let items_pat = List.map (fun (p,_,_) -> p) items in
let str_items =
<:str_item<
value $tup:Ast.paCom_of_list items_pat$ =
let str_items =
<:str_item<
value $tup:Ast.paCom_of_list items_pat$ =
let module C = struct
open Cduce_lib;
Cduce_config.init_all ();
value (types,set_externals,slots,run) =
value (types,set_externals,slots,run) =
Librarian.ocaml_stub $str:String.escaped raw$;
value rec $Ast.biAnd_of_list g$;
set_externals [|$Ast.exSem_of_list exts$|];
set_externals [|$Ast.exSem_of_list exts$|];
run ();
value $Ast.biAnd_of_list items_def$;
value $Ast.biAnd_of_list items_def$;
end in $tup:Ast.exCom_of_list items_expr$ >> in
print_endline prolog;
try Printers.OCaml.print_implem (cleaner # str_item str_items)
with exn -> Format.printf "@."; raise exn
......@@ -620,20 +620,20 @@ let stub_ml name ty_env c_env exts mk =
(* First, read the description of ML types for externals.
Don't forget to call reg_uid to avoid uid clashes...
Do that before reading the cmi. *)
let (prolog, values) =
let (prolog, values) =
try Mltypes.read_cmi name
with Not_found -> ("",[]) in
stub ty_env c_env exts values mk prolog
with Mltypes.Error s -> raise (Cduce_loc.Generic s)
let register b s args =
let register b s args =
try
let (t,n) = Mltypes.find_value s in
let m = List.length args in
if n <> m then
Cduce_loc.raise_generic
(Printf.sprintf
(Printf.sprintf
"Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
let i = if b then
let i = List.length !exts in
......@@ -641,12 +641,12 @@ let register b s args =
i
else
0 in
vars := Array.of_list args;
let cdt = Types.descr (typ t) in
vars := [| |];
i,cdt
with Not_found ->
with Not_found ->
Cduce_loc.raise_generic
(Printf.sprintf "Cannot resolve ocaml external %s" s)
......@@ -654,16 +654,16 @@ let register b s args =
let wrapper values =
gen_types := false;
let exts = List.rev_map
let exts = List.rev_map
(fun (s,t) ->
let v = to_cd <:expr< $lid:s$ >> t in
<:str_item<
<:str_item<
Librarian.register_static_external $str:String.escaped s$ $v$ >>)
values in
let g = global_transl () in
<:str_item<
open Cduce_lib;
<:str_item<
open Cduce_lib;
Cduce_config.init_all ();
value rec $Ast.biAnd_of_list g$;
$Ast.stSem_of_list exts$;
......@@ -675,7 +675,7 @@ let gen_wrapper vals =
(fun accu s ->
try (s,fst (Mltypes.find_value s)) :: accu
with Not_found ->
let vals =
let vals =
try Mltypes.load_module s
with Not_found ->
failwith ("Cannot resolve " ^ s)
......@@ -686,17 +686,17 @@ let gen_wrapper vals =
wrapper values
with Mltypes.Error s -> raise (Cduce_loc.Generic s)
let make_wrapper fn =
let make_wrapper fn =
let ic = open_in fn in
let v = ref [] in
(try while true do
(try while true do
let s = input_line ic in
if s <> "" then
match s.[0] with
| 'A'..'Z' -> v := s :: !v
| 'A'..'Z' -> v := s :: !v
| '#' -> ()
| _ -> failwith "Error in primitive file: names must start with a capitalized letter"
done
done
with End_of_file -> ());
let s = gen_wrapper !v in
Printers.OCaml.print_implem s;
......@@ -720,7 +720,7 @@ let to_cd_dyn = function
(fun (f : Obj.repr) ->
let f = (Obj.magic f : Obj.repr -> Obj.repr) in
Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
| Tuple tl ->
| Tuple tl ->
let fs = List.map to_cd_dyn tl in
(fun (x : Obj.repr) ->
let x = (Obj.magic x : Obj.repr array) in
......@@ -741,7 +741,7 @@ let register () =
Librarian.make_wrapper := make_wrapper
let () =
Cduce_config.register
"ocaml"
"OCaml interface"
Cduce_config.register
"ocaml"
"OCaml interface"
register
......@@ -52,11 +52,11 @@ let tests = "Misc" >:::
);
"pp" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test Misc.pp.1 failed" "(`C,3)" (Misc.pp (Misc.C(3)));
assert_equal ~msg:"Test Misc.pp.1 failed" "(`C,3,Mono)" (Misc.pp (Misc.C(3)));
assert_equal ~msg:"Test Misc.pp.2 failed"
"(`A,(`C,3))" (Misc.pp (Misc.A(Misc.C(3))));
"(`A,(`C,3,Mono),Mono)" (Misc.pp (Misc.A(Misc.C(3))));
assert_equal ~msg:"Test Misc.pp.3 failed"
"(`B,((`C,3),(`A,(`C,2))))" (Misc.pp (Misc.B(Misc.C(3),Misc.A(Misc.C(2)))));
"(`B,((`C,3,Mono),(`A,(`C,2,Mono),Mono),Mono),Mono)" (Misc.pp (Misc.B(Misc.C(3),Misc.A(Misc.C(2)))));
);
"find" >:: ( fun test_ctxt ->
......@@ -120,14 +120,14 @@ let tests = "Misc" >:::
let stack = Misc.Novalue() in
let stack = Misc.push stack p1 in
assert_equal ~msg:"Test Misc.stack.push1 failed"
"{ a=1.200000 b=0.300000 c=0.500000 }" (Misc.print_stack stack);
"{ a=1.200000 b=0.300000 c=0.500000 },Mono" (Misc.print_stack stack);
let stack = Misc.push stack p2 in
assert_equal ~msg:"Test Misc.stack.push2 failed"
"{ a=-0.200000 b=0.400000 c=0.700000 }{ a=1.200000 b=0.300000 c=0.500000 }"
"{ a=-0.200000 b=0.400000 c=0.700000 },Mono{ a=1.200000 b=0.300000 c=0.500000 },Mono"
(Misc.print_stack stack);
let stack = Misc.pop stack in
assert_equal ~msg:"Test Misc.stack.pop1 failed"
"{ a=1.200000 b=0.300000 c=0.500000 }" (Misc.print_stack stack);
"{ a=1.200000 b=0.300000 c=0.500000 },Mono" (Misc.print_stack stack);
let stack = Misc.pop stack in
assert_equal ~msg:"Test Misc.stack.pop2 failed" ""
(Misc.print_stack stack);
......
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