(* $Id: generate.ml 2195 2015-01-01 12:23:39Z gerd $
* ----------------------------------------------------------------------
*
*)
open Syntax;;
open Format;;
(* Common functions *)
let extract_type_info dl =
let typenames = Hashtbl.create 100 in
let typemap = Hashtbl.create 100 in
List.iter
(function
Typedef td ->
if not (Hashtbl.mem typenames td.decl_symbol.xdr_name) then begin
(* Only get the first type definition *)
Hashtbl.add
typenames
td.decl_symbol.xdr_name
td.decl_symbol.ocaml_name;
Hashtbl.add
typemap
td.decl_symbol.xdr_name
td.decl_type
end
| _ -> ()
)
dl;
(typenames,typemap)
;;
let rec get_type_from_map typemap t =
match t with
T_refer_to (_,n) ->
( try get_type_from_map typemap (Hashtbl.find typemap !n)
with
Not_found -> assert false
)
| t -> t
;;
let output_uint4_pattern f (sign,n) =
assert (not sign);
let n32 = Netnumber.logical_int32_of_uint4 n in
fprintf f "(%ldl)" n32
(*
let (n1,n2,n3,n4) = Netnumber.dest_uint4 n in
fprintf f "('\\%03d','\\%03d','\\%03d','\\%03d')"
(Char.code n1)
(Char.code n2)
(Char.code n3)
(Char.code n4);
*)
;;
let max_int_as_uint4 =
Netnumber.uint4_of_int32 0x3fff_ffffl (* assuming 32 bit system *)
let output_uint4 f (sign,n) =
assert (not sign);
if Netnumber.le_uint4 n max_int_as_uint4 then
fprintf f "(Netnumber.uint4_of_int (%d))" (Netnumber.int_of_uint4 n)
else
let n32 = Netnumber.logical_int32_of_uint4 n in
fprintf f "(Netnumber.logical_uint4_of_int32 (%ldl))" n32
;;
let int64_of_const (sign,n) =
let l = Netnumber.int64_of_uint4 n in
if sign then Int64.neg l else l
let output_int4_pattern f (sign,n) =
let n32_0 = Netnumber.int32_of_uint4 n in
let n32 = if sign then Int32.neg n32_0 else n32_0 in
fprintf f "(%ldl)" n32
(*
let plus1 (a,b,c,d) =
if d < 255 then
(a,b,c,d+1)
else
if c < 255 then
(a,b,c+1,0)
else
if b < 255 then
(a,b+1,0,0)
else
if a < 255 then
(a+1,0,0,0)
else
(0,0,0,0)
in
let neg (a,b,c,d) =
plus1 (255-a, 255-b, 255-c, 255-d)
in
let (n1,n2,n3,n4) = Netnumber.dest_uint4 n in
let (m1,m2,m3,m4) =
if sign then
neg (Char.code n1, Char.code n2, Char.code n3, Char.code n4)
else
(Char.code n1, Char.code n2, Char.code n3, Char.code n4)
in
fprintf f "('\\%03d','\\%03d','\\%03d','\\%03d')"
m1 m2 m3 m4
*)
;;
let output_int4 f (sign,n) =
if Netnumber.le_uint4 n max_int_as_uint4 then
let k0 = Netnumber.int_of_uint4 n in
let k = if sign then -k0 else k0 in
fprintf f "(Netnumber.int4_of_int (%d))" k
else
let k0 = Netnumber.int32_of_uint4 n in
let k = if sign then Int32.neg k0 else k0 in
fprintf f "(Netnumber.int4_of_int32 (%ldl))" k
;;
let strip_enum_list l =
(* Remove double enums, sort enums *)
let constants = ref [] in
let rec strip l =
match l with
(id, c) :: l' ->
let c' = constant !c in
if List.mem c' !constants then
strip l'
else begin
constants := c' :: !constants;
(id, c) :: strip l'
end
| [] -> []
in
let cmp (id1,c1) (id2,c2) =
let (sign1,v1) = constant !c1 in
let (sign2,v2) = constant !c2 in
match (sign1,sign2) with
(false,false) ->
compare (Netnumber.int32_of_uint4 v1) (Netnumber.int32_of_uint4 v2)
| (true,true) ->
-(compare (Netnumber.int32_of_uint4 v1) (Netnumber.int32_of_uint4 v2))
| (false, true) ->
1
| (true, false) ->
-1
in
List.sort cmp (strip l)
;;
let n0 = constant_of_string "0";;
let n1 = constant_of_string "1";;
let enum_type t =
match t with
T_enum l -> strip_enum_list l
| T_bool ->
[ mk_mapped_id "FALSE" "False", ref(Constant n0);
mk_mapped_id "TRUE" "True", ref(Constant n1);
]
| _ ->
assert false
;;
let values_of_enum_type t =
match t with
T_enum l ->
List.map (fun (_,c) -> !c) (strip_enum_list l)
| T_bool ->
[ Constant n0; Constant n1 ]
| _ ->
assert false
;;
let get_union_discriminator_type typemap u =
(* gets and normalizes the descr type *)
let t1 = get_type_from_map typemap u.discriminant.decl_type in
match t1 with
| T_int _ | T_uint _ ->
t1
| T_bool ->
T_enum(enum_type T_bool)
| T_enum l ->
(* apply mangling *)
T_enum(mk_enum ~remap:true u.mangling l)
| _ ->
assert false
;;
(**********************************************************************)
(* Output constant definitions *)
(**********************************************************************)
let output_consts (mli:formatter) (f:formatter) (dl:xdr_def list) =
let output_signed_const id c =
(* MLI: *)
fprintf mli "val %s : Netnumber.int4;;@\n" id.ocaml_name;
(* ML: *)
fprintf f "let %s = " id.ocaml_name;
output_int4 f c;
fprintf f ";;@\n"
in
let output_unsigned_const id c =
(* MLI: *)
fprintf mli "val %s : Netnumber.uint4;;@\n" id.ocaml_name;
(* ML: *)
fprintf f "let %s = " id.ocaml_name;
output_uint4 f c;
fprintf f ";;@\n"
in
let rec output_type t = (
(* that's only about the enum constants inside t *)
match t with
| T_option t' -> output_type t'
| T_array_fixed(_,t') -> output_type t'
| T_array(_,t') -> output_type t'
| T_array_unlimited t'-> output_type t'
| T_enum l -> List.iter
(fun (id,c) ->
output_signed_const id (constant !c)
)
(strip_enum_list l)
| T_struct(_,td) -> List.iter output_type_decl td
| T_union u -> output_type_decl (u.discriminant);
List.iter (fun (_,_,td) ->
output_type_decl td) u.cases;
(match u.default with
Some td -> output_type_decl td
| None -> ()
)
| _ -> ()
)
and output_type_decl td =
output_type td.decl_type
and check_program prog =
List.iter (check_version prog) prog.prog_def
and check_version prog vers =
List.iter (check_procedure prog vers) vers.version_def
and check_procedure prog vers proc =
List.iter output_type proc.proc_params;
output_type proc.proc_result
in
fprintf f "@[<v>";
fprintf mli "@[<v>";
List.iter
(function
Typedef td ->
output_type_decl td
| Progdef prog ->
check_program prog
| Constdef(id, (sign,c)) ->
if sign then
output_signed_const id (sign,c)
else
output_unsigned_const id (sign,c)
)
dl;
fprintf f "@]";
fprintf mli "@]"
;;
(**********************************************************************)
(* Output O'Caml type declarations *)
(**********************************************************************)
let output_type_declarations (f:formatter) (dl:xdr_def list) =
let typenames, typemap = extract_type_info dl in
(* typenames: maps xdr_name to ocaml_name *)
(* typemap: maps xdr_name to bound type *)
let anontype = ref 0 in
let deferred = Queue.create() in
let firstdecl = ref true in
let begin_decl() =
if !firstdecl then
fprintf f "type "
else
fprintf f "and ";
firstdecl := false
in
let get_type t = get_type_from_map typemap t in
let get_type_of_decl td = get_type td.decl_type in
let rec output_type t = (
match t with
T_opaque_fixed _
| T_opaque _
| T_opaque_unlimited
| T_string _
| T_string_unlimited ->
fprintf f "string"
| T_mstring(_,_)
| T_mstring_unlimited _ ->
fprintf f "Netxdr_mstring.mstring"
| T_option t' ->
fprintf f "@[<hv 2>";
output_type t';
fprintf f "@ option@]"
| T_array_fixed(_,t') ->
fprintf f "@[<hv 2>";
output_type t';
fprintf f "@ array@]"
| T_array(_,t') ->
fprintf f "@[<hv 2>";
output_type t';
fprintf f "@ array@]"
| T_array_unlimited t' ->
fprintf f "@[<hv 2>";
output_type t';
fprintf f "@ array@]"
| T_int v ->
(match v with
Abstract-> fprintf f "Netnumber.int4"
| INT32 -> fprintf f "int32"
| INT64 -> fprintf f "int64"
| Unboxed -> fprintf f "int"
)
| T_uint v ->
(match v with
Abstract-> fprintf f "Netnumber.uint4"
| INT32 -> fprintf f "int32"
| INT64 -> fprintf f "int64"
| Unboxed -> fprintf f "int"
)
| T_hyper v ->
(match v with
Abstract-> fprintf f "Netnumber.int8"
| INT64 -> fprintf f "int64"
| Unboxed -> fprintf f "int"
| _ -> assert false
)
| T_uhyper v ->
(match v with
Abstract-> fprintf f "Netnumber.uint8"
| INT64 -> fprintf f "int64"
| Unboxed -> fprintf f "int"
| _ -> assert false
)
| T_double
| T_float ->
fprintf f "float"
| T_bool ->
fprintf f "bool"
| T_void ->
fprintf f "unit"
| T_refer_to (_,s) ->
let n =
try Hashtbl.find typenames !s
with Not_found -> assert false
in
fprintf f "%s" n
| T_enum _ ->
fprintf f "Netnumber.int4"
| T_struct tdl ->
let n = "_t" ^ string_of_int !anontype in
incr anontype;
Queue.add (n,t) deferred;
fprintf f "%s" n
| T_union u ->
let discr_type = get_union_discriminator_type typemap u in
let make_tag c =
let (sign,absval) = constant c in
match discr_type with
(T_int _|T_uint _) ->
(if sign then "__" else "_") ^ string_of_uint4 absval
| T_enum l ->
( try
let id,_ =
List.find
(fun (id,n) -> constant !n = (sign,absval))
l
in
id.ocaml_name
with
Not_found -> assert false
)
| _ ->
assert false
in
let output_tag c om td =
let tag =
match om with
None -> make_tag c
| Some om_tag -> om_tag
in
if get_type_of_decl td = T_void then
fprintf f "@,| `%s " tag
else begin
fprintf f "@,| `%s of (" tag;
output_type td.decl_type;
fprintf f ") "
end
in
fprintf f "@[<hv>[ ";
List.iter (fun (c,om,td) -> output_tag !c om td) u.cases;
( match u.default with
None -> () (* TODO: Check! *)
| Some td ->
(* If the discriminant is countable, the missing cases are
* enumerated here. Otherwise, a "default" tag is generated.
*)
if match discr_type with T_int _ | T_uint _ -> true
| _ -> false
then begin
(* The default case is represented by a default tag *)
let tag = "default" in
fprintf f "@,| `%s of (" tag;
if get_type_of_decl td = T_void then
output_type u.discriminant.decl_type
else begin
fprintf f "(";
output_type u.discriminant.decl_type;
fprintf f ") * (";
output_type td.decl_type;
fprintf f ")";
end;
fprintf f ") ";
end
else begin
(* Iterate over all possible values of the discriminant: *)
let l = values_of_enum_type discr_type in
List.iter
(fun n ->
(* Find out the missing cases: *)
if not (List.exists (fun (c,_,_) -> !c = n)
u.cases) then begin
(* n is missing! *)
output_tag n None td
end
)
l
end
);
fprintf f "@,]@]"
)
and output_declaration n t = (
fprintf f "@[<hov 5>";
begin_decl();
fprintf f "%s = @\n" n;
(match t with
T_struct(opts,tdl) ->
if List.mem `Tuple opts then (
fprintf f "@[<hov>( ";
let first = ref true in
List.iter
(fun td' ->
if td'.decl_symbol.xdr_name <> "" then (
if not !first then fprintf f "@;* ";
first := false;
output_type td'.decl_type;
)
(* else: td' is a void component *)
)
tdl;
fprintf f " )@]"
) else (
( try
let p =
List.find (function `Equals _ -> true | _ -> false) opts in
match p with
| `Equals s -> fprintf f "%s =@\n" s
| _ -> assert false
with Not_found -> ()
);
fprintf f "@[<hov>{ ";
List.iter
(fun td' ->
if td'.decl_symbol.xdr_name <> "" then begin
fprintf f
"@\n mutable %s : @[<b 4>@,"
td'.decl_symbol.ocaml_name;
output_type td'.decl_type;
fprintf f "@];";
end
(* else: td' is a void component *)
)
tdl;
fprintf f "@\n}@]";
)
| t ->
output_type t);
fprintf f "@]@\n";
)
and output_tuple_declaration n args = (
fprintf f "@[<hov 6>";
begin_decl();
fprintf f "%s = @\n" n;
fprintf f "(@[<hv> ";
let isfirst = ref true in
List.iter
(fun arg ->
if not !isfirst then fprintf f " *@ ";
isfirst := false;
output_type arg;
)
args;
fprintf f " )@]";
fprintf f "@]@\n";
)
and check_program prog =
List.iter (check_version prog) prog.prog_def
and check_version prog vers =
List.iter (check_procedure prog vers) vers.version_def
and check_procedure prog vers proc =
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
( match proc.proc_params with
[] -> assert false
| [arg] ->
output_declaration
("t_" ^ pvp ^ "'arg")
arg
| args ->
output_tuple_declaration
("t_" ^ pvp ^ "'arg")
args
);
output_declaration
("t_" ^ pvp ^ "'res")
proc.proc_result
and output_deferred_structs() = (
try
while true do
let (n,t) = Queue.take deferred in
output_declaration n t
done
with
Queue.Empty -> ()
)
in
fprintf f "@[<v>";
List.iter
(function
Typedef td ->
output_declaration td.decl_symbol.ocaml_name td.decl_type
| Progdef prog ->
check_program prog
| _ ->
())
dl;
output_deferred_structs();
if not !firstdecl then fprintf f ";;@\n";
fprintf f "@]";
(* Now output exceptions for all named types: *)
if !Options.enable_direct then (
fprintf f "@[<v>";
firstdecl := true;
List.iter
(function
Typedef td ->
let n = td.decl_symbol.ocaml_name in
fprintf f "@[<hov 6>exception X_%s of %s@]@\n" n n;
firstdecl := false
| _ ->
())
dl;
if not !firstdecl then fprintf f ";;@\n";
fprintf f "@]";
)
;;
(**********************************************************************)
(* Output XDR type definition *)
(**********************************************************************)
let output_xdr_type (mli:formatter) (f:formatter) (dl:xdr_def list) =
let typenames, typemap = extract_type_info dl in
(* typenames: maps xdr_name to ocaml_name *)
(* typemap: maps xdr_name to bound type *)
let get_type t = get_type_from_map typemap t in
let get_type_of_decl td = get_type td.decl_type in
let generated_types = ref [] in
let rec output_type rectypes direct t = (
match t with
T_opaque_fixed n ->
fprintf f "@[<hv 2>Netxdr.X_opaque_fixed@ ";
output_uint4 f (constant !n);
fprintf f "@]";
| T_opaque n ->
fprintf f "@[<hv 2>Netxdr.X_opaque@ ";
output_uint4 f (constant !n);
fprintf f "@]";
| T_opaque_unlimited ->
fprintf f "Netxdr.x_opaque_max"
| T_string n ->
fprintf f "@[<hv 2>Netxdr.X_string@ ";
output_uint4 f (constant !n);
fprintf f "@]";
| T_string_unlimited ->
fprintf f "Netxdr.x_string_max"
| T_mstring(name,n) ->
fprintf f "@[<hv 2>Netxdr.X_mstring(@,";
fprintf f "%S" name;
fprintf f ",@ ";
output_uint4 f (constant !n);
fprintf f ")@]";
| T_mstring_unlimited name ->
fprintf f "(Netxdr.x_mstring_max %S)" name
| T_option t' ->
fprintf f "@[<hv 2>Netxdr.x_optional@ (";
output_type rectypes false t';
fprintf f ")@]";
| T_array_fixed(n,t') ->
fprintf f "@[<hv 2>Netxdr.X_array_fixed(@,";
output_type rectypes false t';
fprintf f ",@ ";
output_uint4 f (constant !n);
fprintf f ")@]";
| T_array(n,t') ->
fprintf f "@[<hv 2>Netxdr.X_array(@,";
output_type rectypes false t';
fprintf f ",@ ";
output_uint4 f (constant !n);
fprintf f ")@]";
| T_array_unlimited t' ->
fprintf f "@[<hv>Netxdr.x_array_max@ (";
output_type rectypes false t';
fprintf f ")@]";
| T_int _ ->
fprintf f "Netxdr.X_int"
| T_uint _ ->
fprintf f "Netxdr.X_uint"
| T_hyper _ ->
fprintf f "Netxdr.X_hyper"
| T_uhyper _ ->
fprintf f "Netxdr.X_uhyper"
| T_double ->
fprintf f "Netxdr.X_double"
| T_float ->
fprintf f "Netxdr.X_float"
| T_bool ->
fprintf f "Netxdr.x_bool"
| T_void ->
fprintf f "Netxdr.X_void"
| T_refer_to (_,s) ->
if List.mem !s !generated_types then begin
(* There was already a complete definition for this type *)
let n =
try Hashtbl.find typenames !s
with Not_found -> assert false
in
fprintf f "xdrt_%s" n
end
else if List.mem !s rectypes then begin
(* There was already the beginning of a definition for this type: *)
fprintf f "Netxdr.X_refer \"%s\"" !s
end
else begin
let t' = get_type t in
fprintf f "@[<hv 2>Netxdr.X_rec(\"%s\",@ " !s;
if direct then
fprintf f "@[<hv 2>Netxdr.X_direct(";
output_type (!s :: rectypes) false t';
if direct then
fprintf f ",@ _read_%s,@ _write_%s,@ _size_%s)@]" !s !s !s;
fprintf f ")@]";
end
| T_enum l ->
fprintf f "@[<hv 2>Netxdr.X_enum@ [@ ";
List.iter
(fun (id,c) ->
fprintf f " (\"%s\", " id.xdr_name;
output_int4 f (constant !c);
fprintf f ");@ ";
)
(strip_enum_list l);
fprintf f "]@]";
| T_struct(_,tdl) ->
fprintf f "@[<hv 2>Netxdr.X_struct@ @[<hv>[@ ";
List.iter
(fun d ->
if d.decl_type <> T_void then begin
fprintf f " @[<hv 2>(\"%s\",@ (" d.decl_symbol.xdr_name;
output_type rectypes false d.decl_type;
fprintf f "));@]@ ";
end
)
tdl;
fprintf f "]@]@]";
| T_union u ->
let discr_type = get_union_discriminator_type typemap u in
let is_union_over_int =
match discr_type with T_int _ | T_uint _ -> true | _ -> false in
if is_union_over_int then begin
(* Unions of integers *)
let constr, printint =
match discr_type with
T_int _ -> "Netxdr.X_union_over_int", output_int4
| T_uint _ -> "Netxdr.X_union_over_uint", output_uint4
| _ -> assert false
in
fprintf f "@[<hv 2>";
fprintf f "%s(" constr;
fprintf f "@[<hv>[@ ";
List.iter
(fun (c, _, d) ->
fprintf f " @[<hv 2>";
printint f (constant !c);
fprintf f ",@ (";
output_type rectypes false d.decl_type;
fprintf f ");@]@ ";
)
u.cases;
fprintf f "],@ ";
begin match u.default with
None ->
fprintf f "None"
| Some d ->
fprintf f "Some(";
output_type rectypes false d.decl_type;
fprintf f ")"
end;
fprintf f ")@]@]";
end
else begin
(* Unions of enumerators (and bools) *)
fprintf f "@[<hv 2>";
fprintf f "Netxdr.X_union_over_enum(@,(";
output_type rectypes false discr_type;
fprintf f "),@ [@ ";
let l = enum_type discr_type in
List.iter
(fun (c, _, d) ->
let name, _ =
try
List.find
(fun (id, c') -> !c' = !c)
l
with Not_found -> assert false
in
fprintf f " @[<hv 2>\"%s\"" name.xdr_name;
fprintf f ",@ (";
output_type rectypes false d.decl_type;
fprintf f ");@]@ ";
)
u.cases;
fprintf f "],@ ";
begin match u.default with
None ->
fprintf f "None"
| Some d ->
fprintf f "Some(";
output_type rectypes false d.decl_type;
fprintf f ")"
end;
fprintf f ")@]@]";
end
)
and output_xdr_declaration n direct t =
(* MLI: *)
fprintf mli "val %s : Netxdr.xdr_type_term;;@\n" n;
(* ML: *)
fprintf f "@[<hv 2>let %s =@ " n;
(* fprintf f "@[<hv 2>Netxdr.validate_xdr_type@ ("; *)
output_type [] direct t;
(* fprintf f ")@]"; *)
fprintf f "@]@\n;;@\n"
and output_xdr_tuple_declaration n tl =
(* MLI: *)
fprintf mli "val %s : Netxdr.xdr_type_term;;@\n" n;
(* ML: *)
fprintf f "@[<hv 2>let %s =@ " n;
(* fprintf f "@[<hv 2>Netxdr.validate_xdr_type@ ("; *)
fprintf f "@[<hv 2>Netxdr.X_struct@ @[<hv>[@ ";
let k = ref 0 in
List.iter
(fun t ->
fprintf f " (\"%s\", " (string_of_int !k);
output_type [] false t;
fprintf f ");@ ";
incr k;
)
tl;
fprintf f "]@]@]";
(* fprintf f ")@]"; *)
fprintf f "@]@\n;;@\n";
and check_program prog =
List.iter (check_version prog) prog.prog_def
and check_version prog vers =
List.iter (check_procedure prog vers) vers.version_def
and check_procedure prog vers proc =
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
( match proc.proc_params with
[] -> assert false
| [arg] ->
output_xdr_declaration
("xdrt_" ^ pvp ^ "'arg")
false
arg
| args ->
output_xdr_tuple_declaration
("xdrt_" ^ pvp ^ "'arg")
args
);
output_xdr_declaration
("xdrt_" ^ pvp ^ "'res")
false
proc.proc_result
in
fprintf mli "@[<v>";
fprintf f "@[<v>";
List.iter
(function
Typedef td ->
output_xdr_declaration
("xdrt_" ^ td.decl_symbol.ocaml_name)
(!Options.enable_direct && td.decl_direct)
(T_refer_to (R_any, ref td.decl_symbol.xdr_name));
generated_types := td.decl_symbol.xdr_name :: !generated_types
| Progdef prog ->
check_program prog
| _ ->
())
dl;
fprintf mli "@]";
fprintf f "@]"
;;
(**********************************************************************)
(* Get min size *)
(**********************************************************************)
(* Simplified so far. Look also into Netxdr.calc_min_size *)
let calc_min_size dl =
let (typenames,typemap) = extract_type_info dl in
let visiting = Hashtbl.create 15 in
let visited = Hashtbl.create 15 in
fun t ->
let ( ++ ) x y =
(* pre: x >= 0 && y >= 0 *)
let s = x + y in
if s < 0 then (* can only happen on 32 bit platforms *)
failwith "Minimum size of type exceeds limit";
s in
let rec calc t =
match t with
T_int _ -> 4
| T_uint _ -> 4
| T_hyper _ -> 8
| T_uhyper _ -> 8
| T_float -> 4
| T_double -> 8
| T_void -> 0
| T_bool -> 4
| T_enum _ -> 4
| T_opaque_fixed c ->
let nL = int64_of_const (constant !c) in
if nL=0L then 0
else Int64.to_int(Int64.succ (Int64.div (Int64.pred nL) 4L))
| T_opaque _ -> 4
| T_opaque_unlimited -> 4
| T_string _ -> 4
| T_string_unlimited -> 4
| T_mstring _ -> 4
| T_mstring_unlimited _ -> 4
| T_option t' -> 4
| T_array_fixed (c,t') ->
let size = calc t' in
if size = 0 then
failwith "Array elements must not have length 0";
let nL = int64_of_const(constant !c) in
let n_max = max_int / size in
if nL > Int64.of_int n_max then
failwith "Minimum size of type exceeds limit";
let iL = Int64.of_int size in
Int64.to_int (Int64.mul nL iL)
| T_array (_,t')
| T_array_unlimited t' ->
let size = calc t' in
if size = 0 then
failwith "Array elements must not have length 0";
4
| T_struct(_,s) ->
List.fold_left
(fun acc td ->
acc ++ calc td.decl_type
)
0
s
| T_union u ->
let l =
( match u.default with
| None -> []
| Some d -> [d]
) @ (List.map (fun (_,_,d) -> d) u.cases) in
assert(l <> []);
4 ++
(List.fold_left
(fun acc d ->
min acc (calc d.decl_type)
)
(calc (List.hd l).decl_type)
(List.tl l)
)
| T_refer_to (_,r) ->
( try
Hashtbl.find visited !r
with
| Not_found ->
if Hashtbl.mem visiting !r then
0
else (
Hashtbl.add visiting !r ();
let t =
try Hashtbl.find typemap !r
with Not_found -> assert false in
let size = calc t in
Hashtbl.add visited !r size;
Hashtbl.remove visiting !r;
size
)
)
in
calc t
(**********************************************************************)
(* Helpers for ints *)
(**********************************************************************)
let conversion_custom_int_of_netnumber t =
match t with
| T_int Abstract -> ""
| T_int INT32 -> "Netnumber.int32_of_int4"
| T_int INT64 -> "Netnumber.int64_of_int4"
| T_int Unboxed -> "Netnumber.int_of_int4"
| T_uint Abstract -> ""
| T_uint INT32 -> "Netnumber.logical_int32_of_uint4"
| T_uint INT64 -> "Netnumber.int64_of_uint4"
| T_uint Unboxed -> "Netnumber.int_of_uint4"
| T_hyper Abstract -> ""
| T_hyper INT32 -> assert false
| T_hyper INT64 -> "Netnumber.int64_of_int8"
| T_hyper Unboxed -> "Netnumber.int_of_int8"
| T_uhyper Abstract -> ""
| T_uhyper INT32 -> assert false
| T_uhyper INT64 -> "Netnumber.logical_int64_of_uint8"
| T_uhyper Unboxed -> "Netnumber.int_of_uint8"
| _ -> assert false
let conversion_netnumber_of_custom_int t =
match t with
| T_int Abstract -> ""
| T_int INT32 -> "Netnumber.int4_of_int32"
| T_int INT64 -> "Netnumber.int4_of_int64"
| T_int Unboxed -> "Netnumber.int4_of_int"
| T_uint Abstract -> ""
| T_uint INT32 -> "Netnumber.logical_uint4_of_int32"
| T_uint INT64 -> "Netnumber.uint4_of_int64"
| T_uint Unboxed -> "Netnumber.uint4_of_int"
| T_hyper Abstract -> ""
| T_hyper INT32 -> assert false
| T_hyper INT64 -> "Netnumber.int8_of_int64"
| T_hyper Unboxed -> "Netnumber.int8_of_int"
| T_uhyper Abstract -> ""
| T_uhyper INT32 -> assert false
| T_uhyper INT64 -> "Netnumber.logical_uint8_of_int64"
| T_uhyper Unboxed -> "Netnumber.uint8_of_int"
| _ -> assert false
let name_of_int t =
match t with
| T_int _ -> "int"
| T_uint _ -> "uint"
| T_hyper _ -> "hyper"
| T_uhyper _ -> "uhyper"
| _ -> assert false
let xv_name_of_int t =
match t with
| T_int _ -> "XV_int"
| T_uint _ -> "XV_uint"
| T_hyper _ -> "XV_hyper"
| T_uhyper _ -> "XV_uhyper"
| _ -> assert false
let netnumber_name_of_int t =
match t with
| T_int _ -> "int4"
| T_uint _ -> "uint4"
| T_hyper _ -> "int8"
| T_uhyper _ -> "uint8"
| _ -> assert false
let size_of_int t =
match t with
| T_int _ -> 4
| T_uint _ -> 4
| T_hyper _ -> 8
| T_uhyper _ -> 8
| _ -> assert false
let output_any_int f t (sign,n) = (* hyper, uhyper not needed *)
match t with
| T_int _ -> output_int4 f (sign,n)
| T_uint _ -> output_uint4 f (sign,n)
| _ -> assert false
let conversion_int32_of_discr discr_type =
match discr_type with
| T_int _ -> "Netnumber.int32_of_int4"
| T_uint _ -> "Netnumber.logical_int32_of_uint4"
| _ -> assert false
(**********************************************************************)
(* Generators for unions *)
(**********************************************************************)
let have_enum_default_with_arg u get_type_of_decl =
let discr_type = get_type_of_decl u.discriminant in
match discr_type with
| T_int _ | T_uint _ -> false
| T_enum _ | T_bool ->
( match u.default with
| None ->
false
| Some d ->
get_type_of_decl d <> T_void
)
| _ -> assert false
let output_match_union_by_cases f u discr_type var get_type_of_decl
f_case f_default f_let =
(* Outputs a "match" statement over the Ocaml variants. The variable var
is matched. For every variant of var the function f_case is called:
f_case k (sign,n) decl have_x is_default
with
- k: the k-th case (for unions over enums: the k-th enum variant)
- (sign,n): the corresponding XDR value
- decl: the xdr_decl of this case
- have_x: whether there is a generated "x" variable
- is_default: whether this is a default case (only for enum unions)
At this moment, a branch like
| `tag -> OR
| `tag x ->
has already been generated.
For unions over ints/uints, the function f_default can be called
for the default case. It is called as
f_default decl have_x
At this moment, a branch like
| `default(discriminant,x) -> OR
| `default(discriminant) -> OR
has already been generated.
The function f_let can be used to generate "let v = ... in ..."
statements.
*)
match discr_type with
| T_int _ | T_uint _ ->
fprintf f "@[<v 2>";
fprintf f "( ";
f_let();
fprintf f "match %s with" var;
let k = ref 0 in
List.iter
(fun (c,om,d) ->
let (sign,n) = constant !c in
let tag =
match om with
None ->
(if sign then "__" else "_") ^ string_of_uint4 n
| Some om_tag -> om_tag
in
fprintf f "@ @[<hv 6>| `%s " tag;
let have_x = get_type_of_decl d <> T_void in
if have_x then fprintf f "x ";
fprintf f "->@ ";
f_case !k (sign,n) d have_x false;
fprintf f "@]";
incr k;
)
u.cases;
( match u.default with
| None ->
()
| Some d ->
fprintf f "@ @[<hv 6>| ";
if get_type_of_decl d <> T_void then (
fprintf f "`default(discriminant,x) ->@ ";
f_default d true
)
else (
fprintf f "`default discriminant ->@ ";
f_default d false
);
fprintf f "@]";
);
fprintf f "@]@ )";
| T_enum _
| T_bool ->
fprintf f "( @[<v>";
f_let();
fprintf f "match %s with" var;
let l = enum_type discr_type in
let k = ref 0 in
List.iter
(fun (id,c) ->
let (sign,n) = constant !c in
let om, d_opt, d_is_default =
try
let _, om, d =
(List.find
(fun (c',_,d') -> !c' = !c)
u.cases
)
in
om, Some d, false
with Not_found -> None, u.default, true in
match d_opt with
| Some d ->
let tag =
match om with
| None -> id.ocaml_name
| Some om_tag -> om_tag in
fprintf f "@ @[<hv 6>";
fprintf f "| `%s " tag;
let have_x = get_type_of_decl d <> T_void in
if have_x then fprintf f "x ";
fprintf f "->@ ";
f_case !k (sign,n) d have_x d_is_default;
fprintf f "@]";
incr k
| None ->
incr k
)
l;
fprintf f "@]@ )"
| _ ->
assert false
let output_match_union_by_number f u discr_type var by_k get_type_of_decl
f_case f_default f_let f_coerce =
match discr_type with
| T_int _ | T_uint _ ->
fprintf f "@[<v 2>( ";
f_let();
fprintf f "match %s with" var;
let printint_pattern =
match discr_type with
| T_int _ -> output_int4_pattern
| T_uint _ -> output_uint4_pattern
| _ -> assert false in
let k = ref 0 in
List.iter
(fun (c, om, d) ->
let (sign,n) = constant !c in
let tag =
match om with
None ->
(if sign then "__" else "_") ^ string_of_uint4 n
| Some om_tag -> om_tag in
fprintf f "@ @[<hv 4>";
fprintf f "| ";
if by_k then
fprintf f "%d" !k
else
printint_pattern f (sign,n);
fprintf f " ->@ ";
f_case !k (sign,n) tag d false;
fprintf f "@]";
incr k
)
u.cases;
( match u.default with
| None ->
fprintf f
"@ | _ -> Netxdr.raise_xdr_format_undefined_descriminator()"
| Some d ->
fprintf f "@ @[<hv 4>";
fprintf f "| discriminant ->@ ";
f_default d;
fprintf f "@]"
);
f_coerce();
fprintf f "@]@ )"
| T_enum _
| T_bool ->
fprintf f "@[<v 2>( ";
f_let();
fprintf f "match %s with" var;
let l = enum_type discr_type in
let k = ref 0 in
List.iter
(fun (id,c) ->
let (sign,n) = constant !c in
let om, d_opt, d_is_default =
try
let _, om, d =
(List.find
(fun (c',_,d') -> !c' = !c)
u.cases
)
in
om, Some d, false
with Not_found -> None, u.default, true in
match d_opt with
| Some d ->
let tag =
match om with
| None -> id.ocaml_name
| Some om_tag -> om_tag in
fprintf f "@ @[<hv 6>";
fprintf f "| ";
if by_k then
fprintf f "%d" !k
else
output_int4_pattern f (sign,n);
fprintf f " ->@ ";
f_case !k (sign,n) tag d d_is_default;
fprintf f "@]";
incr k
| None ->
incr k
)
l;
fprintf f
"@ | _ -> Netxdr.raise_xdr_format_undefined_descriminator()";
f_coerce();
fprintf f "@]@ )"
| _ ->
assert false
let output_coerce_pattern f u discr_type get_type_of_decl =
(* outputs a type pattern to which values of [u] can be coerced to *)
match discr_type with
| T_int _ | T_uint _ ->
fprintf f "@[<hv>[";
List.iter
(fun (c, om, d) ->
let (sign,n) = constant !c in
let tag =
match om with
| None ->
(if sign then "__" else "_") ^ string_of_uint4 n
| Some om_tag -> om_tag
in
fprintf f "@ | `%s" tag;
if get_type_of_decl d <> T_void then
fprintf f " of _";
)
u.cases;
begin match u.default with
None ->
()
| Some d ->
fprintf f "@ | `default of ";
if get_type_of_decl d <> T_void then
fprintf f "(_ * _)"
else
fprintf f "_"
end;
fprintf f "@ ]@]"
| T_enum _
| T_bool ->
fprintf f "@[<hv>[";
let l = enum_type discr_type in
List.iter
(fun (id, c) ->
( try
let _, om, d =
(List.find
(fun (c',_,d') -> !c' = !c)
u.cases
)
in
let tag = match om with
| None -> id.ocaml_name
| Some om_tag -> om_tag
in
fprintf f "@ | `%s" tag;
if get_type_of_decl d <> T_void then
fprintf f " of _";
with
Not_found ->
match u.default with
| None -> ()
| Some d ->
fprintf f "@ | `%s" id.ocaml_name;
if get_type_of_decl d <> T_void then
fprintf f " of _"
)
)
l;
fprintf f "@ ]@]"
| _ ->
assert false
(**********************************************************************)
(* Output conversion functions *)
(**********************************************************************)
let proj_pattern var p q =
let l1 =
Array.init q (fun i -> if i=p then var else "_") in
String.concat "," (Array.to_list l1)
let output_conversions (mli:formatter) (f:formatter) (dl:xdr_def list) =
(* Names of conversions:
* - For every named type t there are two conversion functions:
* _to_<t> : value -> t
* _of_<t> : t -> value
* - For every procedure argument and procedure result, there are
* such functions, too:
* _to_<prog>'<vers>'<proc>'arg
* _to_<prog>'<vers>'<proc>'res
* _of_<prog>'<vers>'<proc>'arg
* _of_<prog>'<vers>'<proc>'res
* Here, <prog>, <vers>, and <proc> are the names of the program, the
* version, and the procedure, resp. The character ' is used as
* delimiter
*
* Helpers for direct mapping (not exported, and only for certain t):
* - _size_<t> : t -> int
* computes the byte size of the XDR representation for t
* - _write_<t> : t -> string -> int -> unit
* writes the XDR representation to a string at a position
*)
let typenames, typemap = extract_type_info dl in
(* typenames: maps xdr_name to ocaml_name *)
(* typemap: maps xdr_name to bound type *)
let get_type t = get_type_from_map typemap t in
let get_type_of_decl td = get_type td.decl_type in
let min_size = calc_min_size dl in
let generate_direct_case direct_opt =
match direct_opt with
| None -> ()
| Some n ->
fprintf f "| Netxdr.XV_direct(X_%s x, _) -> x@ " n in
let generate_dest direct_opt var regname regconv =
fprintf f "@[<hv 2>( match %s with@ " var;
fprintf f "| Netxdr.%s x -> %sx@ "
regname (if regconv <> "" then regconv ^ " " else "");
generate_direct_case direct_opt;
fprintf f "| _ -> raise Netxdr.Dest_failure";
fprintf f "@]@ )" in
let rec output_toconv_for_type (var:string) (t:xdr_type) direct_opt = (
(* Generates an expression that converts the xdr_value variable var
* into the O'Caml value corresponding to t
*)
fprintf f "@[<hv>";
( match t with
| T_void ->
fprintf f "()"
| T_opaque_fixed _
| T_opaque _
| T_opaque_unlimited ->
generate_dest direct_opt var "XV_opaque" ""
| T_string _
| T_string_unlimited ->
generate_dest direct_opt var "XV_string" ""
| T_mstring(_,_)
| T_mstring_unlimited _ ->
generate_dest direct_opt var "XV_mstring" ""
| T_option t' ->
fprintf f "@[<hv>";
fprintf f "( match %s with@ " var;
fprintf f "| Netxdr.XV_union_over_enum_fast (0, _) -> None@ ";
fprintf f "@[<hv 4>| Netxdr.XV_union_over_enum_fast (1, x) ->@ Some ";
output_toconv_for_type "x" t' None;
fprintf f "@]";
fprintf f "@ ";
generate_direct_case direct_opt;
fprintf f "| _ -> raise Netxdr.Dest_failure@]@ )";
| T_array_fixed(_,t') ->
output_toconv_for_array var t' direct_opt
| T_array(_,t') ->
output_toconv_for_array var t' direct_opt
| T_array_unlimited t' ->
output_toconv_for_array var t' direct_opt
| T_int _
| T_uint _
| T_hyper _
| T_uhyper _ ->
let xv_name = xv_name_of_int t in
let conv = conversion_custom_int_of_netnumber t in
generate_dest direct_opt var xv_name conv
| T_double ->
generate_dest direct_opt var "XV_double" "Netnumber.float_of_fp8"
| T_float ->
generate_dest direct_opt var "XV_float" "Netnumber.float_of_fp4"
| T_bool ->
generate_dest direct_opt var "XV_enum_fast" "(fun b -> b=1)"
| T_refer_to (_,n) ->
let ocaml_n =
try Hashtbl.find typenames !n
with Not_found -> assert false
in
fprintf f "(_to_%s %s)" ocaml_n var
| T_enum l ->
fprintf f "@[<hv 2>";
fprintf f "( match %s with@ " var;
let k = ref 0 in
List.iter
(fun (id,c) ->
fprintf f "@[<hv>";
fprintf f "| Netxdr.XV_enum_fast %d ->@;<1 4>" !k;
output_int4 f (constant !c);
fprintf f "@]";
fprintf f "@ ";
incr k
)
(strip_enum_list l);
generate_direct_case direct_opt;
fprintf f "| _ -> raise Netxdr.Dest_failure@ ";
fprintf f "@]@ )";
| T_struct(opts,tl) when List.mem `Tuple opts ->
fprintf f "@[<hv 2>";
fprintf f "( let f s =@ ";
fprintf f " @[<hv>( @[<hv>";
let isfirst = ref true in
let k = ref 0 in
List.iter
(fun d ->
if d.decl_type <> T_void then begin
if not !isfirst then fprintf f ",@ ";
isfirst:= false;
fprintf f "@[<hv>";
fprintf f "(fun x -> ";
output_toconv_for_type "x" d.decl_type None;
fprintf f ")@ s.(%d)" !k;
fprintf f "@]";
incr k
end
)
tl;
fprintf f "@]@ )@] in@ ";
generate_dest direct_opt var "XV_struct_fast" "f";
fprintf f "@]@ )"
| T_struct(_,tl) ->
fprintf f "@[<hv 2>";
fprintf f "( let f s =@ ";
fprintf f " @[<hv>{ @[<hv>";
let isfirst = ref true in
let k = ref 0 in
List.iter
(fun d ->
if d.decl_type <> T_void then begin
if not !isfirst then fprintf f "@ ";
isfirst:= false;
let ocaml_n = d.decl_symbol.ocaml_name in
(* let xdr_n = d.decl_symbol.xdr_name in *)
fprintf f "%s = " ocaml_n;
fprintf f "@[<hv>";
fprintf f "(fun x -> ";
output_toconv_for_type "x" d.decl_type None;
fprintf f ")@ s.(%d)" !k;
fprintf f "@]";
fprintf f "; ";
incr k
end
)
tl;
fprintf f "@]@ }@] in@ ";
generate_dest direct_opt var "XV_struct_fast" "f";
fprintf f "@]@ )"
| T_union u ->
let check_direct = direct_opt <> None in
if check_direct then (
fprintf f "@[<hv 2>( match %s with@ " var;
generate_direct_case direct_opt;
fprintf f "| _ ->@ ";
);
let discr_type = get_union_discriminator_type typemap u in
let is_union_over_int =
match discr_type with T_int _ | T_uint _ -> true | _ -> false in
if is_union_over_int then begin
(* Unions of integers *)
output_match_union_by_number
f
u
discr_type
"discriminant"
false (* by_k *)
get_type_of_decl
(fun k (sign,n) tag d d_is_default ->
(* f_case *)
fprintf f "`%s " tag;
if get_type_of_decl d <> T_void then
output_toconv_for_type "x" d.decl_type None;
)
(fun d ->
(* f_default *)
let int_conversion =
conversion_custom_int_of_netnumber discr_type in
fprintf f "`default(@[<hv>%s discriminant0" int_conversion;
if get_type_of_decl d <> T_void then begin
fprintf f ",@ ";
output_toconv_for_type "x" d.decl_type None;
end;
fprintf f "@])";
)
(fun () ->
(* f_let *)
fprintf f "let discriminant0, x = %s %s in@ "
(match discr_type with
| T_int _ -> "Netxdr.dest_xv_union_over_int"
| T_uint _ -> "Netxdr.dest_xv_union_over_uint"
| _ -> assert false
)
var;
fprintf f "let discriminant = %s discriminant0 in@ "
(conversion_int32_of_discr discr_type)
)
(fun () ->
(* f_coerce *)
fprintf f "@ :> ";
output_coerce_pattern f u discr_type get_type_of_decl
)
end
else begin
(* Unions of enumerators (and bools) *)
let have_mkdefault =
have_enum_default_with_arg u get_type_of_decl in
output_match_union_by_number
f
u
discr_type
"k"
true (* by_k *)
get_type_of_decl
(fun k (sign,n) tag d d_is_default ->
(* f_case *)
fprintf f "`%s " tag;
if d_is_default then (
if have_mkdefault then
fprintf f "(mkdefault x)"
) else (
if get_type_of_decl d <> T_void then
output_toconv_for_type "x" d.decl_type None;
)
)
(fun d -> assert false)
(fun () ->
(* f_let *)
fprintf f
"let k, x = Netxdr.dest_xv_union_over_enum_fast %s in@ "
var;
( match u.default with
None ->
()
| Some d ->
if have_mkdefault then begin
fprintf f "let mkdefault x =@;<1 4>";
fprintf f "@[<hv>";
output_toconv_for_type "x" d.decl_type None;
fprintf f "@]";
fprintf f " in@ ";
end
)
)
(fun () ->
(* f_coerce *)
fprintf f "@ :> ";
output_coerce_pattern f u discr_type get_type_of_decl
)
end;
if check_direct then
fprintf f "@]@ )"
);
fprintf f "@]"
)
and output_toconv_for_array var t' direct_opt =
let t1 = get_type_from_map typemap t' in
fprintf f "@[<hv 2>";
fprintf f "( match %s with@ " var;
fprintf f "@[<hv 4>| Netxdr.XV_array x ->@ ";
fprintf f "@[<hv 2>Array.map@ ";
fprintf f "@[<hv 2>(fun x -> ";
output_toconv_for_type "x" t' None;
fprintf f ")@]@ x@]@]@ ";
( match t1 with
| T_string _
| T_string_unlimited ->
fprintf f "@[<hv 4>| Netxdr.XV_array_of_string_fast x ->@ ";
fprintf f "x@]@ ";
| _ -> ()
);
generate_direct_case direct_opt;
fprintf f "| _ -> raise Netxdr.Dest_failure";
fprintf f "@]@ )";
and output_toconv_for_tuple var tl =
fprintf f "@[<hv>";
fprintf f "(let s = Netxdr.dest_xv_struct_fast %s in@;<1 3>" var;
fprintf f "( @[<hv>";
let isfirst = ref true in
let n = ref 0 in
List.iter
(fun t ->
if not !isfirst then fprintf f ", @,";
isfirst:= false;
fprintf f "@[<hv>";
fprintf f "(fun x -> ";
output_toconv_for_type "x" t None;
fprintf f ")@ s.(%d)" !n;
fprintf f "@]";
incr n;
)
tl;
fprintf f "@]@;<0 3>))";
fprintf f "@]";
in
let firstdecl = ref true in
let begin_decl() =
if !firstdecl then
fprintf f "let rec "
else
fprintf f "and ";
firstdecl := false
in
let output_toconv_declaration n t tname direct =
(* MLI: *)
fprintf mli "val _to_%s : Netxdr.xdr_value -> %s;;@\n" n tname;
(* ML: *)
fprintf f "@[<hv>";
begin_decl();
fprintf f "_to_%s (x:Netxdr.xdr_value) : %s =@;<1 2>"
n
tname;
let direct_opt =
if !Options.enable_direct && direct then
Some tname
else
None in
output_toconv_for_type "x" t direct_opt;
fprintf f "@]@\n"
in
let output_toconv_tuple_declaration n tl tname =
(* MLI: *)
fprintf mli "val _to_%s : Netxdr.xdr_value -> %s;;@\n" n tname;
(* ML: *)
fprintf f "@[<hv>";
begin_decl();
fprintf f "_to_%s (x:Netxdr.xdr_value) : %s =@;<1 2>"
n
tname;
output_toconv_for_tuple "x" tl;
fprintf f "@]@\n"
in
let rec output_ofconv_for_type (name:string) (var:string) (t:xdr_type) =
(* Generates an expression converting the O'Caml value contained in the
* variable with name var to the corresponding XDR value
*)
fprintf f "@[<hv>";
( match t with
| T_void ->
fprintf f "Netxdr.XV_void"
| T_opaque_fixed _
| T_opaque _
| T_opaque_unlimited ->
fprintf f "(Netxdr.XV_opaque %s)" var
| T_string _
| T_string_unlimited ->
fprintf f "(Netxdr.XV_string %s)" var
| T_mstring(_,_)
| T_mstring_unlimited _ ->
fprintf f "(Netxdr.XV_mstring %s)" var
| T_option t' ->
fprintf f "@[<hv 2>";
fprintf f "( match %s with@ " var;
fprintf f "| None -> Netxdr.xv_none@ ";
fprintf f "| Some x -> @[<hv 2>Netxdr.xv_some@ ";
output_ofconv_for_type name "x" t';
fprintf f "@]@]@ )";
| T_array_fixed(_,t') ->
output_ofconv_for_array name var t'
| T_array(_,t') ->
output_ofconv_for_array name var t'
| T_array_unlimited t' ->
output_ofconv_for_array name var t'
| T_int _
| T_uint _
| T_hyper _
| T_uhyper _ ->
let xv_name = xv_name_of_int t in
let conv = conversion_netnumber_of_custom_int t in
fprintf f "(Netxdr.%s (%s %s))" xv_name conv var
| T_double ->
fprintf f "(Netxdr.XV_double (Netnumber.fp8_of_float %s))" var
| T_float ->
fprintf f "(Netxdr.XV_float (Netnumber.fp4_of_float %s))" var
| T_bool ->
fprintf f "(if %s then Netxdr.xv_true else Netxdr.xv_false)" var
| T_refer_to (_,n) ->
let ocaml_n =
try Hashtbl.find typenames !n
with Not_found -> assert false
in
fprintf f "(_of_%s %s)" ocaml_n var
| T_enum l ->
fprintf f "@[<hv>";
fprintf f "(match Netnumber.int32_of_int4 %s with@ " var;
let k = ref 0 in
List.iter
(fun (id,c) ->
fprintf f "@[<hv>";
fprintf f "| ";
output_int4_pattern f (constant !c);
fprintf f "@ -> Netxdr.XV_enum_fast %d" !k;
fprintf f "@]";
fprintf f "@ ";
incr k;
)
(strip_enum_list l);
fprintf f "| _ -> failwith \"RPC/XDR error: invalid enum value for type `%s'\"@ " name;
fprintf f ")";
fprintf f "@]";
| T_struct(opts,tdl) when List.mem `Tuple opts ->
let tdl =
Array.to_list
(Array.mapi
(fun i d -> (i,d))
(Array.of_list
(List.filter (fun d -> d.decl_type <> T_void) tdl))
) in
fprintf f "@[<hv>(@[<hv 1>";
fprintf f " let (%s) = %s in@;"
(String.concat ","
(List.map (fun (i,_) -> sprintf "x%d" i) tdl))
var;
List.iter
(fun (i,d) ->
let v = sprintf "x%d" i in
fprintf f "let %s = " v;
output_ofconv_for_type name v d.decl_type;
fprintf f " in@;"
)
tdl;
fprintf f "Netxdr.XV_struct_fast@ ";
fprintf f "[| %s |]"
(String.concat ";"
(List.map (fun (i,_) -> sprintf "x%d" i) tdl));
fprintf f "@])@]"
| T_struct(_,tdl) ->
fprintf f "@[<hv>(@[<hv 2>Netxdr.XV_struct_fast@ ";
fprintf f "[|@ ";
List.iter
(fun d ->
if d.decl_type <> T_void then begin
let ocaml_n = d.decl_symbol.ocaml_name in
let _xdr_n = d.decl_symbol.xdr_name in
fprintf f " @[<hv 2>(";
fprintf f "let x = %s.%s in@ " var ocaml_n;
output_ofconv_for_type name "x" d.decl_type;
fprintf f ")@];@ ";
end
)
tdl;
fprintf f "|]@])@]"
| T_union u ->
let discr_type = get_union_discriminator_type typemap u in
let have_mkdefault =
have_enum_default_with_arg u get_type_of_decl in
output_match_union_by_cases
f
u
discr_type
var
get_type_of_decl
(fun k (sign,n) d have_x is_default ->
(* f_case *)
match discr_type with
| T_int _ | T_uint _ ->
fprintf f "Netxdr.XV_union_over_%s(@[<hv>"
(name_of_int discr_type);
output_any_int f discr_type (sign,n);
fprintf f ",@ ";
if have_x then
output_ofconv_for_type name "x" d.decl_type
else
fprintf f "Netxdr.XV_void";
fprintf f "@])";
| _ ->
fprintf f "@[<hv 2>Netxdr.XV_union_over_enum_fast@ (%d," k;
if is_default then (
if have_x then (
assert(have_mkdefault);
fprintf f "(mkdefault x)"
)
else
fprintf f "Netxdr.XV_void"
)
else (
if have_x then
output_ofconv_for_type name "x" d.decl_type
else
fprintf f "Netxdr.XV_void"
);
fprintf f ")@]"
)
(fun d have_x ->
(* f_default *)
let constr =
sprintf
"Netxdr.XV_union_over_%s"
(name_of_int discr_type) in
let int_conversion =
conversion_netnumber_of_custom_int discr_type in
if have_x then (
fprintf f "let x = ";
output_ofconv_for_type name "x" d.decl_type;
fprintf f " in@ ";
fprintf f "%s(%s discriminant, x)@]"
constr int_conversion;
) else
fprintf f "%s(%s discriminant, Netxdr.XV_void)@]"
constr int_conversion
)
(fun () ->
(* f_let *)
if have_mkdefault then (
match u.default with
| None -> assert false
| Some d ->
fprintf f "let mkdefault x =@;<1 2>";
fprintf f "@[<hv>";
output_ofconv_for_type name "x" d.decl_type;
fprintf f "@]";
fprintf f " in@ ";
)
)
);
fprintf f "@]"
and output_ofconv_for_array name var t' =
let t1 = get_type_from_map typemap t' in
match t1 with
| T_string _
| T_string_unlimited ->
fprintf f "@[<hv 2>(Netxdr.XV_array_of_string_fast %s)@]" var
| _ ->
fprintf f "@[<hv 2>Netxdr.XV_array@ ";
fprintf f "@[<hv 2>(Array.map@ ";
fprintf f "(fun x -> ";
output_ofconv_for_type name "x" t';
fprintf f ")@ %s)@]@]" var
and output_ofconv_for_tuple name var tl =
fprintf f "@[<hv 1>";
fprintf f "(let (";
let n = ref 0 in
let isfirst = ref true in
List.iter
(fun t ->
if not !isfirst then fprintf f ", ";
isfirst := false;
fprintf f "x%d" !n;
incr n
)
tl;
fprintf f ") = %s in@ " var;
fprintf f "@[<hv 2>Netxdr.XV_struct_fast@ [|@ ";
n := 0;
List.iter
(fun t ->
fprintf f " @[<hv 2>(";
output_ofconv_for_type name ("x" ^ string_of_int !n) t;
fprintf f ");@]@ ";
incr n
)
tl;
fprintf f "|]@]@ )@]"
in
let rec output_sizefn_for_type (name:string) (tname:string) (t:xdr_type) =
(* Generates a function returning the packed size *)
fprintf f "@[<hv 2>";
begin_decl();
fprintf f "_sizeexpr_%s (x:%s) : int =@ "
name
tname;
output_sizeexpr_for_type name (calc_sizefn_for_type name t);
fprintf f "@]@\n";
fprintf f "@[<hv 2>";
begin_decl();
fprintf f "_size_%s (x:exn) : int =@ " name;
fprintf f "match x with@ ";
fprintf f "| X_%s y -> _sizeexpr_%s y@ " tname name;
fprintf f "| _ -> raise Netxdr.Dest_failure";
fprintf f "@]@\n"
and output_sizeexpr_for_type name calcexpr =
match calcexpr with
| `Size_const n ->
fprintf f "%Ld" n
| `Size_fun name ->
fprintf f "(%s x)" name
| `Size_opt(n,calcexpr1) ->
fprintf f "@[<hv 2>(match x with@ ";
fprintf f "| None -> %Ld@ " n;
fprintf f "| Some x ->@[<hv 2>@ ";
output_sizeexpr_for_type
name
(calc_sizefn_for_struct [`None,`Size_const n; `None,calcexpr1]);
fprintf f "@])@]"
| `Size_struct l ->
fprintf f "@[<hv 2>(";
let first = ref true in
List.iter
(fun (component,calcexpr1) ->
if not !first then
fprintf f " +!@ ";
first := false;
match component with
| `None ->
output_sizeexpr_for_type name calcexpr1
| `Field fname ->
fprintf f "@[<hv 2>( let x = x.%s in@ " fname;
output_sizeexpr_for_type name calcexpr1;
fprintf f "@])"
| `Proj(p,q) ->
fprintf f "@[<hv 2>( let (%s) = x in@ "
(proj_pattern "x" p q);
output_sizeexpr_for_type name calcexpr1;
fprintf f "@])"
)
l;
fprintf f ")@]"
| `Size_array (n_head,cond,calcexpr1) ->
( match cond with
| None -> ()
| Some (`Fixed n) ->
fprintf f "@[<hv 2>( ";
fprintf f "if Array.length x <> %d then@ " n;
fprintf f
" raise(Netxdr.Xdr_failure \"array length mismatch\");@ ";
| Some (`Limit n) ->
fprintf f "@[<hv 2>( ";
fprintf f "if Array.length x > %d then@ " n;
fprintf f
" raise(Netxdr.Xdr_failure \"array length mismatch\");@ ";
);
( match calcexpr1 with
| `Size_const n ->
fprintf f "(%Ld *! Array.length x +! %Ld)" n n_head
| _ ->
fprintf f "@[<hv 2>(Array.fold_left@ ";
fprintf f "@[<hv 2>(fun s x ->@ ";
fprintf f "s +! ";
output_sizeexpr_for_type name calcexpr1;
fprintf f "@]@ )@ ";
fprintf f "%Ld@ " n_head;
fprintf f "x";
fprintf f "@]@ )"
);
( match cond with
| None -> ()
| Some _ ->
fprintf f "@]@ )"
)
| `Size_union(u,sizeexpr_cases,sizeexpr_default) ->
let discr_type = get_union_discriminator_type typemap u in
let have_mkdefault =
have_enum_default_with_arg u get_type_of_decl in
fprintf f "@[<hv 2>( 4 +!@ ";
output_match_union_by_cases
f
u
discr_type
"x"
get_type_of_decl
(fun k (sign,n) d have_x is_default -> (* f_case *)
if have_x then (
if is_default && have_mkdefault then
fprintf f "mkdefault x"
else
let sizeexpr = List.nth sizeexpr_cases k in
output_sizeexpr_for_type name sizeexpr
)
else
fprintf f "0"
)
(fun d have_x -> (* f_default *)
if have_x then
match sizeexpr_default with
| None -> assert false
| Some sizeexpr ->
output_sizeexpr_for_type name sizeexpr
else
fprintf f "0"
)
(fun () -> (* f_let *)
if have_mkdefault then (
match sizeexpr_default with
| None -> assert false
| Some sizeexpr ->
fprintf f "let mkdefault x =@;<1 2>";
fprintf f "@[<hv>";
output_sizeexpr_for_type name sizeexpr;
fprintf f "@]";
fprintf f " in@ ";
)
);
fprintf f "@]@ )";
and calc_sizefn_for_type (name:string) (t:xdr_type) = (
match t with
| T_void ->
`Size_const 0L
| T_opaque_fixed n ->
(* no size check here - this is done in writefn *)
let nL = int64_of_const (constant !n) in
`Size_const
(if nL=0L then 0L else
Int64.mul (Int64.succ(Int64.div (Int64.pred nL) 4L)) 4L)
| T_opaque n
| T_string n ->
`Size_fun
(sprintf
"(Netxdr.sizefn_string (Netnumber.logical_uint4_of_int32 (%ldl)))"
(Int64.to_int32 (int64_of_const (constant !n)))
)
| T_opaque_unlimited
| T_string_unlimited ->
`Size_fun
"(Netxdr.sizefn_string (Netnumber.logical_uint4_of_int32 (-1l)))"
| T_option t' ->
`Size_opt(4L, calc_sizefn_for_type name t')
| T_int _ | T_uint _ | T_float | T_bool | T_enum _ ->
`Size_const 4L
| T_hyper _ | T_uhyper _ | T_double ->
`Size_const 8L
| T_struct(opts,tdl) when List.mem `Tuple opts ->
let tdl_a =
Array.of_list
(List.filter
(fun d -> d.decl_type <> T_void)
tdl
) in
calc_sizefn_for_struct
(Array.to_list
(Array.mapi
(fun i d ->
let component = `Proj(i, Array.length tdl_a) in
(component, calc_sizefn_for_type name d.decl_type)
)
tdl_a
)
)
| T_struct(_,tdl) ->
calc_sizefn_for_struct
(List.map
(fun d ->
let fname = d.decl_symbol.ocaml_name in
(`Field fname, calc_sizefn_for_type name d.decl_type)
)
(List.filter
(fun d -> d.decl_type <> T_void)
tdl
)
)
| T_refer_to (_,refname) ->
let ocaml_name =
try Hashtbl.find typenames !refname
with Not_found -> assert false in
`Size_fun
(sprintf "_sizeexpr_%s" ocaml_name)
| T_array_fixed(c,t') ->
let n = Int64.to_int(int64_of_const (constant !c)) in
`Size_array(0L, Some(`Fixed n), calc_sizefn_for_type name t')
| T_array(c,t') ->
let nL = int64_of_const (constant !c) in
if nL >= Int64.of_int Sys.max_array_length then
`Size_array(4L, None, calc_sizefn_for_type name t')
else
let n = Int64.to_int nL in
`Size_array(4L, Some(`Limit n), calc_sizefn_for_type name t')
| T_array_unlimited t' ->
`Size_array(4L, None, calc_sizefn_for_type name t')
| T_union u ->
let sizeexpr_cases =
List.map
(fun (_,_,td) -> calc_sizefn_for_type name td.decl_type)
u.cases in
let sizeexpr_default =
match u.default with
| None -> None
| Some td -> Some(calc_sizefn_for_type name td.decl_type) in
`Size_union(u, sizeexpr_cases, sizeexpr_default)
| T_mstring(_,_)
| T_mstring_unlimited _ ->
failwith "output_sizefn_for_type"
)
and calc_sizefn_for_struct l1 =
let n_const =
List.fold_left
Int64.add
0L
(List.map
(function
| (_, `Size_const n) -> n
| _ -> 0L
)
l1
) in
let l_other =
List.flatten
(List.map
(function
| (_, `Size_const _) -> []
| x -> [x]
)
l1
) in
let l2 =
(if n_const > 0L then [`None, `Size_const n_const] else []) @ l_other in
match l2 with
| [] -> `Size_const 0L
| [`None, x] -> x
| _ -> `Size_struct l2
in
let rec output_writefn_for_type (name:string) (tname:string) (t:xdr_type) =
(* Generates a function writing directly *)
fprintf f "@[<hv 2>";
begin_decl();
fprintf f "_writeexpr_%s (x:%s) s p : unit =@ " name tname;
output_writeexpr_for_type name t;
fprintf f "()";
fprintf f "@]@\n";
fprintf f "@[<hv 2>";
begin_decl();
fprintf f "_write_%s (x:exn) s p : unit =@ " name;
fprintf f "match x with@ ";
fprintf f "| X_%s y -> _writeexpr_%s y s p@ " tname name;
fprintf f "| _ -> raise Netxdr.Dest_failure";
fprintf f "@]@\n"
and output_writeexpr_for_type name t =
match t with
| T_void ->
()
| T_opaque_fixed c ->
let (_, n_uint4) = constant !c in
let n =
try Netnumber.int_of_uint4 n_uint4
with _ -> assert false in (* already checked in Syntax *)
fprintf f
"Netxdr.write_string_fixed %d x s p;@ "
n
| T_opaque _
| T_opaque_unlimited
| T_string _
| T_string_unlimited ->
(* The size constraint has already been checked by sizefn *)
fprintf f "Netxdr.write_string x s p;@ ";
| T_option t' ->
fprintf f "@[<hv>( match x with@ ";
fprintf f "| @[<hv 2>None ->@ ";
fprintf f "Netnumber.BE.write_int4_unsafe s !p \
(Netnumber.int4_of_int 0);@ ";
fprintf f "p := !p + 4";
fprintf f "@]@ ";
fprintf f "| @[<hv 2>Some x ->@ ";
fprintf f "Netnumber.BE.write_int4_unsafe s !p \
(Netnumber.int4_of_int 1);@ ";
fprintf f "p := !p + 4;@ ";
output_writeexpr_for_type name t';
fprintf f "()";
fprintf f "@]@ )";
fprintf f "@];@ ";
| T_int _
| T_uint _
| T_hyper _
| T_uhyper _ ->
fprintf f "Netnumber.BE.write_%s_unsafe s !p (%s x)"
(netnumber_name_of_int t)
(conversion_netnumber_of_custom_int t);
fprintf f ";@ ";
fprintf f "p := !p + %d;@ " (size_of_int t)
| T_float ->
fprintf f
"Netnumber.BE.write_fp4 s !p (Netnumber.fp4_of_float x);@ ";
fprintf f "p := !p + 4;@ "
| T_double ->
fprintf f
"Netnumber.BE.write_fp8 s !p (Netnumber.fp8_of_float x);@ ";
fprintf f "p := !p + 8;@ "
| T_bool ->
fprintf f "Netnumber.BE.write_int4_unsafe s !p ";
fprintf f "(Netnumber.int4_of_int (if x then 1 else 0));@ ";
fprintf f "p := !p + 4;@ "
| T_enum e ->
let e = strip_enum_list e in
let cases =
String.concat "; "
(List.map
(fun (_,c) ->
Int64.to_string (int64_of_const (constant !c)) ^ "l"
)
e
) in
fprintf f
"@[<hv 2>if not(List.mem (Netnumber.int32_of_int4 x) [ %s ]) \
then@ " cases;
fprintf f "raise(Netxdr.Xdr_failure \"invalid enum\");@]@ ";
fprintf f "Netnumber.BE.write_int4_unsafe s !p x;@ ";
fprintf f "p := !p + 4;@ "
| T_struct(opts,tdl) when List.mem `Tuple opts ->
let n = List.length tdl in
let p = ref 0 in
List.iter
(fun d ->
if d.decl_type <> T_void then (
fprintf f "@[<hov 2>( let (%s) = x in@ "
(proj_pattern "x" !p n);
output_writeexpr_for_type name d.decl_type;
fprintf f "()@]@ );@ ";
incr p;
)
)
tdl
| T_struct(_,tdl) ->
List.iter
(fun d ->
if d.decl_type <> T_void then (
fprintf f "@[<hov 2>( let x = x.%s in@ "
d.decl_symbol.ocaml_name;
output_writeexpr_for_type name d.decl_type;
fprintf f "()@]@ );@ ";
)
)
tdl
| T_refer_to (_,refname) ->
let ocaml_name =
try Hashtbl.find typenames !refname
with Not_found -> assert false in
fprintf f "_writeexpr_%s x s p;@ " ocaml_name
| T_array_fixed(_,t')
| T_array(_,t')
| T_array_unlimited t' ->
(* The size constraints have already been checked by _size *)
( match t with
| T_array(_,t')
| T_array_unlimited t' ->
fprintf f "Netnumber.BE.write_uint4_unsafe s !p@ ";
fprintf f " (Netnumber.uint4_of_int (Array.length x));@ ";
fprintf f "p := !p + 4;@ "
| _ -> ()
);
fprintf f "@[<hv 2>Array.iter@ ";
fprintf f "@[<hv 2>(fun x ->@ ";
output_writeexpr_for_type name t';
fprintf f "()@]@ ";
fprintf f ")@ x@];@ "
| T_union u ->
let discr_type = get_union_discriminator_type typemap u in
let have_mkdefault =
have_enum_default_with_arg u get_type_of_decl in
output_match_union_by_cases
f
u
discr_type
"x"
get_type_of_decl
(fun k (sign,n) d have_x is_default -> (* f_case *)
( match discr_type with
| T_int _ | T_enum _ | T_bool ->
fprintf f "Netnumber.BE.write_int4_unsafe s !p ";
output_int4 f (sign,n);
fprintf f ";@ ";
fprintf f "p := !p + 4;@ ";
| T_uint _ ->
fprintf f "Netnumber.BE.write_uint4_unsafe s !p ";
output_uint4 f (sign,n);
fprintf f ";@ ";
fprintf f "p := !p + 4;@ ";
| _ ->
assert false
);
if have_x then (
if is_default then
fprintf f "mkdefault x"
else (
output_writeexpr_for_type name d.decl_type;
fprintf f "()"
)
) else
fprintf f "()"
)
(fun d have_x -> (* f_default *)
fprintf f "let d = %s discriminant in@ "
(conversion_netnumber_of_custom_int discr_type);
fprintf f
"Netnumber.BE.write_%s_unsafe s !p d"
(netnumber_name_of_int discr_type);
fprintf f ";@ ";
fprintf f "p := !p + 4;@ ";
if have_x then (
output_writeexpr_for_type name d.decl_type;
fprintf f "()"
)
)
(fun () -> (* f_let *)
if have_mkdefault then (
match u.default with
| None -> assert false
| Some d ->
fprintf f "let mkdefault x =@;<1 2>";
fprintf f "@[<hv>";
output_writeexpr_for_type name d.decl_type;
fprintf f "@]";
fprintf f " in@ ";
)
);
fprintf f ";@ "
| T_mstring(_,_)
| T_mstring_unlimited _ ->
failwith "output_writefn_for_type"
in
let rec output_readfn_for_type (name:string) (tname:string) (t:xdr_type) =
(* Generates a function reading directly *)
fprintf f "@[<hv 2>";
begin_decl();
fprintf f "_readexpr_%s s p p_end =@ " name;
output_readexpr_for_type name t;
fprintf f "@]@\n";
fprintf f "@[<hv 2>";
begin_decl();
fprintf f "_read_%s s p p_end : exn =@ " name;
fprintf f "X_%s(_readexpr_%s s p p_end)" tname name;
fprintf f "@]@\n"
and output_readexpr_for_type name t =
match t with
| T_void ->
fprintf f "()"
| T_opaque_fixed c ->
let (_, n_uint4) = constant !c in
let n =
try Netnumber.int_of_uint4 n_uint4
with _ -> assert false in (* already checked in Syntax *)
fprintf f
"Netxdr.read_string_fixed %d s p p_end@ "
n
| T_opaque n
| T_string n ->
let n32 =
Int64.to_int32 (int64_of_const (constant !n)) in
fprintf f "Netxdr.read_string (Netnumber.logical_uint4_of_int32 (%ldl)) \
s p p_end@ " n32
| T_opaque_unlimited
| T_string_unlimited ->
fprintf f "Netxdr.read_string Netnumber.max_uint4 s p p_end@ ";
| T_option t' ->
fprintf f "( @[<hv>";
fprintf f "if !p > p_end-4 then raise Netnumber.Out_of_range;@ ";
fprintf f "let d = Netnumber.BE.read_int4_unsafe s !p in@ ";
fprintf f "p := !p + 4;@ ";
fprintf f "match Netnumber.int_of_int4 d with@ ";
fprintf f "| 0 -> None@ ";
fprintf f "@[<hv 2>| 1 ->@ ";
fprintf f "@[<hv 2>Some(@ ";
output_readexpr_for_type name t';
fprintf f ")@]@]@ ";
fprintf f "| _ -> raise Netxdr.Dest_failure";
fprintf f "@]@ )";
| T_int _
| T_uint _
| T_hyper _
| T_uhyper _ ->
let s = size_of_int t in
fprintf f "( @[<hv>";
fprintf f "if !p > p_end-%d then raise Netnumber.Out_of_range;@ " s;
fprintf f "let x = Netnumber.BE.read_%s_unsafe s !p in@ "
(netnumber_name_of_int t);
fprintf f "p := !p + %d;@ " s;
fprintf f "(%s x)" (conversion_custom_int_of_netnumber t);
fprintf f "@]@ )"
| T_float ->
fprintf f "( @[<hv>";
fprintf f "if !p > p_end-4 then raise Netnumber.Out_of_range;@ ";
fprintf f "let x = Netnumber.BE.read_fp4 s !p in@ ";
fprintf f "p := !p + 4;@ ";
fprintf f "Netnumber.float_of_fp4 x";
fprintf f "@]@ )"
| T_double ->
fprintf f "( @[<hv>";
fprintf f "if !p > p_end-8 then raise Netnumber.Out_of_range;@ ";
fprintf f "let x = Netnumber.BE.read_fp8 s !p in@ ";
fprintf f "p := !p + 8;@ ";
fprintf f "Netnumber.float_of_fp8 x";
fprintf f "@]@ )"
| T_bool ->
fprintf f "( @[<hv>";
fprintf f "if !p > p_end-4 then raise Netnumber.Out_of_range;@ ";
fprintf f "let x = Netnumber.BE.read_int4_unsafe s !p in@ ";
fprintf f "p := !p + 4;@ ";
fprintf f "(Netnumber.int_of_int4 x = 1)";
fprintf f "@]@ )"
| T_enum e ->
let e = strip_enum_list e in
let cases =
String.concat "; "
(List.map
(fun (_,c) ->
Int64.to_string (int64_of_const (constant !c)) ^ "l"
)
e
) in
fprintf f "( @[<hv>";
fprintf f "if !p > p_end-4 then raise Netnumber.Out_of_range;@ ";
fprintf f "let x = Netnumber.BE.read_int4_unsafe s !p in@ ";
fprintf f "p := !p + 4;@ ";
fprintf f
"@[<hv 2>if not(List.mem (Netnumber.int32_of_int4 x) [ %s ]) \
then@ " cases;
fprintf f "raise(Netxdr.Xdr_format \"invalid enum\");@]@ ";
fprintf f "x";
fprintf f "@]@ )"
| T_struct(opts,tdl) ->
fprintf f "( @[<hv>";
let i = ref 0 in
List.iter
(fun d ->
if d.decl_type <> T_void then (
fprintf f "@[<hv 2>let x%d =@ " !i;
output_readexpr_for_type name d.decl_type;
fprintf f " in@]@ ";
incr i;
)
)
tdl;
if List.mem `Tuple opts then (
let s =
String.concat ","
(Array.to_list
(Array.map
(fun j -> sprintf "x%d" j)
(Array.init !i (fun j -> j))
)
) in
fprintf f "(%s)" s
)
else (
i := 0;
fprintf f "{ @[<hv>";
List.iter
(fun d ->
if d.decl_type <> T_void then (
fprintf f "@ %s = x%d;" d.decl_symbol.ocaml_name !i;
incr i;
)
)
tdl;
fprintf f "@]@ }";
);
fprintf f "@]@ )"
| T_refer_to (_,refname) ->
let ocaml_name =
try Hashtbl.find typenames !refname
with Not_found -> assert false in
fprintf f "( _readexpr_%s s p p_end)" ocaml_name
| T_array_fixed(c,t') ->
let nL = int64_of_const (constant !c) in
let n = Int64.to_int nL in
output_readexpr_for_array name (Some (`Fixed n)) t'
| T_array(c,t') ->
let nL = int64_of_const (constant !c) in
if nL >= Int64.of_int Sys.max_array_length then
output_readexpr_for_array name None t'
else
let n = Int64.to_int nL in
output_readexpr_for_array name (Some (`Limit n)) t'
| T_array_unlimited t' ->
output_readexpr_for_array name None t'
| T_union u ->
let discr_type = get_union_discriminator_type typemap u in
let int_name =
match discr_type with
| T_int _ | T_enum _ | T_bool -> "int4"
| T_uint _ -> "uint4"
| _ -> assert false in
fprintf f "( @[<hv>";
fprintf f "if !p > p_end-4 then raise Netnumber.Out_of_range;@ ";
fprintf f "let d0 = Netnumber.BE.read_%s_unsafe s !p in@ " int_name;
fprintf f "p := !p + 4;@ ";
let have_mkdefault =
have_enum_default_with_arg u get_type_of_decl in
output_match_union_by_number
f
u
discr_type
"d"
false (* by_k *)
get_type_of_decl
(fun k (sign,n) tag d d_is_default -> (* f_case *)
let have_x = get_type_of_decl d <> T_void in
if have_x then (
fprintf f "@[<hv 2>let x =@ ";
if d_is_default && have_mkdefault then
fprintf f "(mkdefault())"
else
output_readexpr_for_type name d.decl_type;
fprintf f " in@]@ ";
);
fprintf f "`%s%s"
tag (if have_x then " x" else "");
)
(fun d -> (* f_default *)
let int_conversion =
conversion_custom_int_of_netnumber discr_type in
let have_x = get_type_of_decl d <> T_void in
if have_x then (
fprintf f "@[<hv 2>let x =@ ";
output_readexpr_for_type name d.decl_type;
fprintf f " in@]@ ";
);
fprintf f "`default(@[<hv>%s d0" int_conversion;
if have_x then
fprintf f ",@ x";
fprintf f "@])";
)
(fun () -> (* f_let *)
fprintf f "let d = %s d0 in@ "
(match discr_type with
| T_int _ | T_enum _ | T_bool -> "Netnumber.int32_of_int4"
| T_uint _ -> "Netnumber.logical_int32_of_uint4"
| _ -> assert false
);
if have_mkdefault then (
match u.default with
| None -> assert false
| Some d ->
fprintf f "let mkdefault x =@;<1 2>";
fprintf f "@[<hv>";
output_readexpr_for_type name d.decl_type;
fprintf f "@]";
fprintf f " in@ ";
)
)
(fun () -> (* f_coerce *)
fprintf f "@ :> ";
output_coerce_pattern f u discr_type get_type_of_decl
);
fprintf f "@]@ )"
| T_mstring(_,_)
| T_mstring_unlimited _ ->
failwith "output_readexpr_for_type"
and output_readexpr_for_array name cond t_elem =
let ms = min_size t_elem in
fprintf f "( @[<hv>";
( match cond with
| None
| Some (`Limit _) ->
fprintf f "if !p > p_end-4 then raise Netnumber.Out_of_range;@ ";
fprintf f "let ulen = Netnumber.BE.read_uint4_unsafe s !p in@ ";
fprintf f "p := !p + 4;@ ";
fprintf f "let len =@ ";
fprintf f " try Netnumber.int_of_uint4 ulen@ ";
fprintf f " with _ -> Netxdr.raise_xdr_format_maximum_length() in@ ";
( match cond with
| Some (`Limit n) ->
fprintf f "if len > %d then@ " n;
fprintf f " Netxdr.raise_xdr_format_maximum_length();@ "
| _ -> ()
)
| Some (`Fixed n) ->
fprintf f "let len = %d in@ " n;
);
fprintf f "let m = (p_end - !p) / %d in@ " ms;
fprintf f "if len > m then@ ";
fprintf f " Netxdr.raise_xdr_format_too_short();@ ";
fprintf f "Array.init@ ";
fprintf f " len@ ";
fprintf f "@[<hv 4> (fun _ ->@ ";
output_readexpr_for_type name t_elem;
fprintf f ")@]@]@ )"
in
let permit_direct t =
(* For which type we permit the generation of XV_direct values.
We don't do this for all "atomic" types, so only a few types remain.
Note that we nevertheless need to generate the "_size" and "_write"
functions for those types that are suppressed here!
*)
match t with
| T_struct _ -> true
| T_option _ -> true
| T_array _ | T_array_fixed _ | T_array_unlimited _ -> true
| T_union _ -> true
| _ -> false in
let output_ofconv_declaration n t tname direct =
(* MLI: *)
fprintf mli "val _of_%s : %s -> Netxdr.xdr_value;;@\n" n tname;
(* ML: *)
fprintf f "@[<hv>";
begin_decl();
fprintf f "_of_%s (x:%s) : Netxdr.xdr_value =@;<1 2>"
n
tname;
if !Options.enable_direct && direct && permit_direct t then (
fprintf f
"@[<hv>Netxdr.XV_direct(X_%s x, _sizeexpr_%s x)@]" tname n
)
else
output_ofconv_for_type n "x" t;
fprintf f "@]@\n"
in
let output_ofconv_tuple_declaration n tl tname =
(* MLI: *)
fprintf mli "val _of_%s : %s -> Netxdr.xdr_value;;@\n" n tname;
(* ML: *)
fprintf f "@[<hv>";
begin_decl();
fprintf f "_of_%s (x:%s) : Netxdr.xdr_value =@;<1 2>"
n
tname;
output_ofconv_for_tuple n "x" tl;
fprintf f "@]@\n"
in
let rec check_program prog =
List.iter (check_version prog) prog.prog_def
and check_version prog vers =
List.iter (check_procedure prog vers) vers.version_def
and check_procedure prog vers proc =
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
( match proc.proc_params with
[] -> assert false
| [arg] ->
output_toconv_declaration
(pvp ^ "'arg")
arg
("t_" ^ pvp ^ "'arg")
false;
output_ofconv_declaration
(pvp ^ "'arg")
arg
("t_" ^ pvp ^ "'arg")
false;
| args ->
output_toconv_tuple_declaration
(pvp ^ "'arg")
args
("t_" ^ pvp ^ "'arg");
output_ofconv_tuple_declaration
(pvp ^ "'arg")
args
("t_" ^ pvp ^ "'arg")
);
output_toconv_declaration
(pvp ^ "'res")
proc.proc_result
("t_" ^ pvp ^ "'res")
false;
output_ofconv_declaration
(pvp ^ "'res")
proc.proc_result
("t_" ^ pvp ^ "'res")
false;
in
fprintf mli "@[<v>";
fprintf f "@[<v>";
fprintf f "let ( +! ) = Netxdr.safe_add@\n";
fprintf f "let ( *! ) = Netxdr.safe_mul@\n;;@\n";
List.iter
(function
Typedef td ->
output_toconv_declaration
td.decl_symbol.ocaml_name
td.decl_type
td.decl_symbol.ocaml_name
td.decl_direct;
output_ofconv_declaration
td.decl_symbol.ocaml_name
td.decl_type
td.decl_symbol.ocaml_name
td.decl_direct;
if !Options.enable_direct && td.decl_direct then (
output_sizefn_for_type
td.decl_symbol.ocaml_name
td.decl_symbol.ocaml_name
td.decl_type;
output_writefn_for_type
td.decl_symbol.ocaml_name
td.decl_symbol.ocaml_name
td.decl_type;
output_readfn_for_type
td.decl_symbol.ocaml_name
td.decl_symbol.ocaml_name
td.decl_type;
)
| Progdef prog ->
check_program prog
| _ ->
())
dl;
if not !firstdecl then fprintf f ";;@\n";
fprintf mli "@]";
fprintf f "@]"
;;
(**********************************************************************)
(* Output program definitions *)
(**********************************************************************)
let output_progdefs (mli:formatter) (f:formatter) (dl:xdr_def list) =
let rec check_program prog =
List.iter (check_version prog) prog.prog_def
and check_version prog vers =
let pv =
prog.prog_symbol.ocaml_name ^ "'" ^ vers.version_symbol.ocaml_name in
(* MLI: *)
fprintf mli "val program_%s : Rpc_program.t;;@\n" pv;
(* ML: *)
fprintf f "@[<hv 2>let program_%s =@ " pv;
fprintf f "@[<hv 2>Rpc_program.create@ ";
output_uint4 f (false, prog.prog_number);
fprintf f "@ ";
output_uint4 f (false, vers.version_number);
fprintf f "@ ";
fprintf f "(Netxdr.validate_xdr_type_system [])@ ";
fprintf f "@[<hv 2>[";
List.iter (declare_procedure prog vers) vers.version_def;
fprintf f "@]@ ]";
fprintf f "@]@]@\n;;@\n";
and declare_procedure prog vers proc =
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf f "@ @[<hv 2>";
fprintf f "\"%s\",@ (" proc.proc_symbol.xdr_name;
output_uint4 f (false, proc.proc_number);
fprintf f ",@ xdrt_%s'arg,@ xdrt_%s'res);" pvp pvp;
fprintf f "@]";
in
fprintf mli "@[<v>";
fprintf f "@[<v>";
List.iter
(function
| Progdef prog ->
check_program prog
| _ ->
())
dl;
fprintf mli "@]@\n";
fprintf f "@]@\n"
;;
(**********************************************************************)
(* Output clients *)
(**********************************************************************)
let output_client (mli:formatter) (f:formatter) (dl:xdr_def list)
only_functor
auxname =
let rec check_program prog =
(* Make functor: *)
(* MLI: *)
fprintf mli "@[<v>";
fprintf mli "@[<v 2>module Make'%s(U'C:Rpc_client_pre.USE_CLIENT) : sig@ "
prog.prog_symbol.ocaml_name;
(* ML: *)
fprintf f "@[<v>";
fprintf f "@[<v 2>module Make'%s(U'C:Rpc_client_pre.USE_CLIENT) = struct@ "
prog.prog_symbol.ocaml_name;
(* Both: *)
List.iter (check_version `Make prog) prog.prog_def;
(* MLI: *)
fprintf mli "@]@ ";
fprintf mli "end@ ";
fprintf mli "@]@\n";
(* ML: *)
fprintf f "@]@ ";
fprintf f "end@ ";
fprintf f "@]@\n";
(* Mapping with U'C=Rpc_client: *)
if not only_functor then (
(* MLI: *)
fprintf mli "@[<v>";
fprintf mli "@[<v 2>module %s : sig@ "
prog.prog_symbol.ocaml_name;
(* ML: *)
fprintf f "@[<v>";
fprintf f "@[<v 2>module %s = struct@ "
prog.prog_symbol.ocaml_name;
(* Both: *)
List.iter (check_version `Client prog) prog.prog_def;
(* MLI: *)
fprintf mli "@]@ ";
fprintf mli "end@ ";
fprintf mli "@]@\n";
(* ML: *)
fprintf f "@]@ ";
fprintf f "end@ ";
fprintf f "@]@\n";
)
and check_version inst prog vers =
let pv =
prog.prog_symbol.ocaml_name ^ "'" ^ vers.version_symbol.ocaml_name in
(* MLI: *)
fprintf mli "@[<v>";
fprintf mli "@[<v 2>module %s : sig" vers.version_symbol.ocaml_name;
fprintf mli "@ ";
fprintf mli "open %s@ " auxname;
( match inst with
| `Client ->
fprintf mli "type t = Rpc_client.t@ ";
fprintf mli "val @[<hv 4>create_client :@ ?esys:Unixqueue.event_system ->@ ?program_number:Netnumber.uint4 -> @ ?version_number:Netnumber.uint4 -> @ Rpc_client.connector ->@ Rpc.protocol ->@ Rpc_client.t@]";
fprintf mli "@ ";
fprintf mli "val @[<hv 4>create_portmapped_client :@ ?esys:Unixqueue.event_system ->@ ?program_number:Netnumber.uint4 -> @ ?version_number:Netnumber.uint4 -> @ string ->@ Rpc.protocol ->@ Rpc_client.t@]";
fprintf mli "@ ";
fprintf mli "val @[<hv 4>create_client2 :@ ?esys:Unixqueue.event_system ->@ ?program_number:Netnumber.uint4 -> @ ?version_number:Netnumber.uint4 -> @ Rpc_client.mode2 ->@ Rpc_client.t@]";
fprintf mli "@ ";
| `Make ->
fprintf mli "type t = U'C.t@ ";
);
fprintf mli "val _program : Rpc_program.t@ ";
(* ML: *)
fprintf f "@[<v>";
fprintf f "@[<v 2>module %s = struct@ " vers.version_symbol.ocaml_name;
( match inst with
| `Client ->
(* Ocaml doesn't like: Make'<prog>(Rpc_client).<vers> *)
fprintf f "module M'0 = Make'%s(Rpc_client)@ "
prog.prog_symbol.ocaml_name ;
fprintf f "include M'0.%s@ "
vers.version_symbol.ocaml_name;
fprintf f "open %s@ " auxname;
fprintf f "let _program = program_%s@ " pv;
fprintf f "@ ";
fprintf f "@[<hv 2>let create_client@ ";
fprintf f "?(esys = Unixqueue.create_unix_event_system())@ ";
fprintf f "?program_number@ ";
fprintf f "?version_number@ ";
fprintf f "connector@ ";
fprintf f "protocol =@ ";
fprintf f " Rpc_client.create ?program_number ?version_number esys connector protocol _program";
fprintf f "@]";
fprintf f "@ @ ";
fprintf f "@[<hv 2>let create_portmapped_client ?esys ?program_number ?version_number host protocol =@ ";
fprintf f "create_client ?esys ?program_number ?version_number (Rpc_client.Portmapped host) protocol";
fprintf f "@]";
fprintf f "@ @ ";
fprintf f "@[<hv 2>let create_client2@ ";
fprintf f "?(esys = Unixqueue.create_unix_event_system())@ ";
fprintf f "?program_number@ ";
fprintf f "?version_number@ ";
fprintf f "mode2 =@ ";
fprintf f " Rpc_client.create2 ?program_number ?version_number mode2 _program esys";
fprintf f "@]";
fprintf f "@ ";
| `Make ->
fprintf f "open %s@ " auxname;
fprintf f "let _program = program_%s@ " pv;
fprintf f "type t = U'C.t@ ";
fprintf f "@ ";
);
(* Both: *)
List.iter (define_procedure inst prog vers) vers.version_def;
(* MLI: *)
fprintf mli "@]@ end@ @]";
(* ML: *)
fprintf f "@]@ ";
fprintf f "end@ ";
fprintf f "@]";
and define_procedure inst prog vers proc =
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
let cm =
match inst with
| `Client -> "Rpc_client"
| `Make -> "U'C" in
(* MLI: *)
fprintf mli "val @[<hv 4>%s :@ %s.t ->@ %s ->@ %s@]@ "
proc.proc_symbol.ocaml_name
cm
("t_" ^ pvp ^ "'arg")
("t_" ^ pvp ^ "'res");
fprintf mli "val @[<hv 4>%s'async :@ %s.t ->@ %s ->@ ((unit -> %s) -> unit) ->@ unit@]@ "
proc.proc_symbol.ocaml_name
cm
("t_" ^ pvp ^ "'arg")
("t_" ^ pvp ^ "'res");
(* ML: *)
( match inst with
| `Client ->
()
| `Make ->
fprintf f "@[<hv 2>";
fprintf f "let %s client arg =@ " proc.proc_symbol.ocaml_name;
(* fprintf f "assert(Rpc_client.program client == _program);@ "; *)
fprintf f "_to_%s'res (U'C.unbound_sync_call client _program \"%s\" (_of_%s'arg arg))"
pvp proc.proc_symbol.xdr_name pvp;
fprintf f "@]@ @ ";
fprintf f "@[<hv 2>";
fprintf f "let %s'async client arg pass_reply =@ " proc.proc_symbol.ocaml_name;
(* fprintf f "assert(Rpc_client.program client == _program);@ "; *)
fprintf f "U'C.unbound_async_call client _program \"%s\" (_of_%s'arg arg)@ "
proc.proc_symbol.xdr_name pvp;
fprintf f " (fun g -> pass_reply (fun () -> _to_%s'res (g())))@ " pvp;
fprintf f "@]@ @ "
)
in
fprintf mli "@[<v>";
fprintf f "@[<v>";
List.iter
(function
| Progdef prog ->
check_program prog
| _ ->
())
dl;
fprintf mli "@]@\n";
fprintf f "@]@\n"
;;
(**********************************************************************)
(* Output servers *)
(**********************************************************************)
type style =
[ `Create | `Create2 ]
let output_server (style:style)
(mli:formatter) (f:formatter) (dl:xdr_def list) auxname =
let rec check_program prog =
(* MLI: *)
fprintf mli "@[<v>";
fprintf mli "@[<v 2>module %s : sig@ " prog.prog_symbol.ocaml_name;
(* ML: *)
fprintf f "@[<v>";
fprintf f "@[<v 2>module %s = struct@ " prog.prog_symbol.ocaml_name;
(* Both: *)
List.iter (check_version prog) prog.prog_def;
(* MLI: *)
fprintf mli "@]@ ";
fprintf mli "end@ ";
fprintf mli "@]@\n";
(* ML: *)
fprintf f "@]@ ";
fprintf f "end@ ";
fprintf f "@]";
and check_version prog vers =
match style with
| `Create -> check_version1 prog vers
| `Create2 -> check_version2 prog vers
and check_version1 prog vers =
let pv =
prog.prog_symbol.ocaml_name ^ "'" ^ vers.version_symbol.ocaml_name in
(* MLI: *)
fprintf mli "@[<v>";
fprintf mli "@[<v 2>module %s : sig" vers.version_symbol.ocaml_name;
fprintf mli "@ ";
fprintf mli "open %s@ " auxname;
fprintf mli "val @[<hv 4>create_server :@ ?limit:int ->@ ?program_number:Netnumber.uint4 ->@ ?version_number:Netnumber.uint4 ->@ ";
(* ML: *)
fprintf f "@[<v>";
fprintf f "@[<v 2>module %s = struct@ " vers.version_symbol.ocaml_name;
fprintf f "open %s@ " auxname;
fprintf f "let _program = program_%s@ " pv;
fprintf f "@ ";
fprintf f "@[<hv 2>let create_server@ ";
fprintf f "?(limit = 20)@ ";
fprintf f "?program_number@ ";
fprintf f "?version_number@ ";
(* Both: *)
List.iter
(fun proc ->
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf mli "proc_%s : (@[<hv>t_%s'arg ->@ t_%s'res@]) ->@ "
proc.proc_symbol.ocaml_name
pvp
pvp;
fprintf f "~proc_%s@ " proc.proc_symbol.ocaml_name)
vers.version_def;
(* MLI: *)
fprintf mli "Rpc_server.connector ->@ ";
fprintf mli "Rpc.protocol ->@ ";
fprintf mli "Rpc.mode ->@ ";
fprintf mli "Unixqueue.event_system ->@ ";
fprintf mli "Rpc_server.t@]@ ";
(* ML: *)
fprintf f "connector@ ";
fprintf f "protocol@ ";
fprintf f "mode@ ";
fprintf f "esys@ ";
fprintf f "=@ ";
fprintf f " @[<hv 2>";
fprintf f "Rpc_server.create@ ?program_number ?version_number esys connector protocol mode _program@ ";
fprintf f " @[<hv 2>[";
List.iter
(fun proc ->
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf f "@ (Rpc_server.Sync { @[<v>Rpc_server.sync_name = \"%s\";@ "
proc.proc_symbol.xdr_name;
fprintf f "Rpc_server.sync_proc = (fun x -> _of_%s'res (proc_%s (_to_%s'arg x)))@]});"
pvp proc.proc_symbol.ocaml_name pvp;
)
vers.version_def;
fprintf f "@]@ ]@ ";
fprintf f " limit@]@]";
fprintf f "@ @ ";
(* MLI: *)
fprintf mli "val @[<hv 4>create_async_server :@ ?limit:int ->@ ?program_number:Netnumber.uint4 ->@ ?version_number:Netnumber.uint4 ->@ ";
(* ML: *)
fprintf f "@[<hv 2>let create_async_server@ ";
fprintf f "?(limit = 20)@ ";
fprintf f "?program_number@ ";
fprintf f "?version_number@ ";
(* Both: *)
List.iter
(fun proc ->
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf mli "proc_%s : (@[<hv>Rpc_server.session ->@ t_%s'arg ->@ (t_%s'res -> unit) ->@ unit)@] ->@ "
proc.proc_symbol.ocaml_name
pvp
pvp;
fprintf f "~proc_%s@ " proc.proc_symbol.ocaml_name)
vers.version_def;
(* MLI: *)
fprintf mli "Rpc_server.connector ->@ ";
fprintf mli "Rpc.protocol ->@ ";
fprintf mli "Rpc.mode ->@ ";
fprintf mli "Unixqueue.event_system ->@ ";
fprintf mli "Rpc_server.t@]@ ";
(* ML: *)
fprintf f "connector@ ";
fprintf f "protocol@ ";
fprintf f "mode@ ";
fprintf f "esys@ ";
fprintf f "=@ ";
fprintf f " @[<hv 2>";
fprintf f "Rpc_server.create@ ?program_number ?version_number esys connector protocol mode _program@ ";
fprintf f " @[<hv 2>[";
List.iter
(fun proc ->
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf f "@ (Rpc_server.Async { @[<v>Rpc_server.async_name = \"%s\";@ "
proc.proc_symbol.xdr_name;
fprintf f "Rpc_server.async_invoke = (fun s x -> proc_%s s (_to_%s'arg x) (fun y -> Rpc_server.reply s (_of_%s'res y)))@]});"
proc.proc_symbol.ocaml_name pvp pvp;
)
vers.version_def;
fprintf f "@]@ ]@ ";
fprintf f " limit@]@]";
fprintf f "@ @ ";
fprintf mli "@]end@ @]";
fprintf f "@]end@ ";
fprintf f "@]";
and check_version2 prog vers =
let pv =
prog.prog_symbol.ocaml_name ^ "'" ^ vers.version_symbol.ocaml_name in
(* MLI: *)
fprintf mli "@[<v>";
fprintf mli "@[<v 2>module %s : sig" vers.version_symbol.ocaml_name;
fprintf mli "@ ";
fprintf mli "open %s@ " auxname;
fprintf mli "val @[<hv 4>bind :@ ?program_number:Netnumber.uint4 ->@ ?version_number:Netnumber.uint4 ->@ ";
(* ML: *)
fprintf f "@[<v>";
fprintf f "@[<v 2>module %s = struct@ " vers.version_symbol.ocaml_name;
fprintf f "open %s@ " auxname;
fprintf f "let _program = program_%s@ " pv;
fprintf f "@ ";
fprintf f "@[<hv 2>let bind@ ";
fprintf f "?program_number@ ";
fprintf f "?version_number@ ";
(* Both: *)
List.iter
(fun proc ->
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf mli "proc_%s : (@[<hv>t_%s'arg ->@ t_%s'res@]) ->@ "
proc.proc_symbol.ocaml_name
pvp
pvp;
fprintf f "~proc_%s@ " proc.proc_symbol.ocaml_name)
vers.version_def;
(* MLI: *)
fprintf mli "Rpc_server.t ->@ ";
fprintf mli "unit@]@ ";
(* ML: *)
fprintf f "srv@ ";
fprintf f "=@ ";
fprintf f " @[<hv 2>";
fprintf f "Rpc_server.bind@ ?program_number ?version_number _program @ ";
fprintf f " @[<hv 2>[";
List.iter
(fun proc ->
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf f "@ (Rpc_server.Sync { @[<v>Rpc_server.sync_name = \"%s\";@ "
proc.proc_symbol.xdr_name;
fprintf f "Rpc_server.sync_proc = (fun x -> _of_%s'res (proc_%s (_to_%s'arg x)))@]});"
pvp proc.proc_symbol.ocaml_name pvp;
)
vers.version_def;
fprintf f "@]@ ]@ ";
fprintf f " srv@]@]";
fprintf f "@ @ ";
(* MLI: *)
fprintf mli "val @[<hv 4>bind_async :@ ?program_number:Netnumber.uint4 ->@ ?version_number:Netnumber.uint4 ->@ ";
(* ML: *)
fprintf f "@[<hv 2>let bind_async@ ";
fprintf f "?program_number@ ";
fprintf f "?version_number@ ";
(* Both: *)
List.iter
(fun proc ->
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf mli "proc_%s : (@[<hv>Rpc_server.session ->@ t_%s'arg ->@ (t_%s'res -> unit) ->@ unit)@] ->@ "
proc.proc_symbol.ocaml_name
pvp
pvp;
fprintf f "~proc_%s@ " proc.proc_symbol.ocaml_name)
vers.version_def;
(* MLI: *)
fprintf mli "Rpc_server.t ->@ ";
fprintf mli "unit@]@ ";
(* ML: *)
fprintf f "srv@ ";
fprintf f "=@ ";
fprintf f " @[<hv 2>";
fprintf f "Rpc_server.bind@ ?program_number ?version_number _program @ ";
fprintf f " @[<hv 2>[";
List.iter
(fun proc ->
let pvp = prog.prog_symbol.ocaml_name ^ "'" ^
vers.version_symbol.ocaml_name ^ "'" ^
proc.proc_symbol.ocaml_name in
fprintf f "@ (Rpc_server.Async { @[<v>Rpc_server.async_name = \"%s\";@ "
proc.proc_symbol.xdr_name;
fprintf f "Rpc_server.async_invoke = (fun s x -> proc_%s s (_to_%s'arg x) (fun y -> Rpc_server.reply s (_of_%s'res y)))@]});"
proc.proc_symbol.ocaml_name pvp pvp;
)
vers.version_def;
fprintf f "@]@ ]@ ";
fprintf f " srv@]@]";
fprintf f "@ @ ";
fprintf mli "@]end@ @]";
fprintf f "@]end@ ";
fprintf f "@]";
in
fprintf mli "@[<v>";
fprintf f "@[<v>";
List.iter
(function
| Progdef prog ->
check_program prog
| _ ->
())
dl;
fprintf mli "@]@\n";
fprintf f "@]@\n"
;;
