(* $Id$
 * ----------------------------------------------------------------------
 *
 *)


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,@ _expand_%s)@]"
                      !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 ctx (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.Netxdr.ctx_copy_string %s))" ctx var
	| T_string _
	| T_string_unlimited ->
	    fprintf
              f "(Netxdr.XV_string (%s.Netxdr.ctx_copy_string %s))" ctx 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 ctx name "x" t';
	    fprintf f "@]@]@ )";
	| T_array_fixed(_,t') ->
	    output_ofconv_for_array ctx name  var t'
	| T_array(_,t') ->
	    output_ofconv_for_array ctx name var t'
	| T_array_unlimited t' ->
	    output_ofconv_for_array ctx 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 "(_xof_%s %s %s)" ocaml_n ctx 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 ctx 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 ctx 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 ctx 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 ctx 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 ctx 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 ctx name "x" d.decl_type;
			 fprintf f "@]";
			 fprintf f " in@ ";
		 )
	      )
    );
    fprintf f "@]"

  and output_ofconv_for_array ctx 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 ctx name "x" t';
	  fprintf f ")@ %s)@]@]" var
	  
  and output_ofconv_for_tuple ctx 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 ctx 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 =
    let decl_expand =
      !Options.enable_direct && direct in
    let do_direct_mapping =
      !Options.enable_direct && direct && permit_direct t in
    (* MLI: *)
    fprintf mli "val _of_%s : %s -> Netxdr.xdr_value;;@\n" n tname;
    fprintf mli "val _xof_%s : Netxdr.ctx -> %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;
    fprintf f "@[<hv>_xof_%s Netxdr.default_ctx x@]" n;
    fprintf f "@]@\n";

    fprintf f "@[<hv>";
    begin_decl();
    fprintf f "_xof_%s (ctx:Netxdr.ctx) (x:%s) : Netxdr.xdr_value =@;<1 2>"
      n tname;
    if do_direct_mapping then (
      fprintf f
        "@[<v>";
      fprintf f
        "if ctx.Netxdr.ctx_direct then@ ";
      fprintf f
	"  Netxdr.XV_direct(X_%s x, _sizeexpr_%s x, _expand_%s)@ " tname n n;
      fprintf f
        "else@ ";
      fprintf f
        "  let ctx' = { ctx with Netxdr.ctx_direct = ctx.Netxdr.ctx_direct_sub } in@ ";
      fprintf f
        "  @[<hv>";
      output_ofconv_for_type "ctx'" n "x" t;
      fprintf f
        "@]@ @]";
    )
    else
      output_ofconv_for_type "ctx" n "x" t;
    fprintf f "@]@\n";

    if decl_expand then (
      fprintf f "@[<hv>";
      begin_decl();
      fprintf f "_expand_%s (ex:exn) : Netxdr.xdr_value =@;<1 2>" n;
      fprintf f "match ex with@ ";
      fprintf f "| X_%s x ->" tname; 
      fprintf f " _xof_%s Netxdr.expand_ctx x@ " n;
      fprintf f "| _ -> raise Netxdr.Dest_failure@ ";
      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;
    fprintf mli "val _xof_%s : Netxdr.ctx -> %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;
    fprintf f "@[<hv>_xof_%s Netxdr.default_ctx x@]" n;
    fprintf f "@]@\n";

    fprintf f "@[<hv>";
    begin_decl();
    fprintf f "_xof_%s ctx (x:%s) : Netxdr.xdr_value =@;<1 2>"
      n
      tname;
    output_ofconv_for_tuple "ctx" 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\" (_xof_%s'arg (U'C.xdr_ctx client) 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\" (_xof_%s'arg (U'C.xdr_ctx client) 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 srv x -> _xof_%s'res (Rpc_server.xdr_ctx srv)  (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 srv s x -> proc_%s s (_to_%s'arg x) (fun y -> Rpc_server.reply s (_xof_%s'res (Rpc_server.xdr_ctx srv) 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 srv x -> _xof_%s'res (Rpc_server.xdr_ctx srv) (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 srv s x -> proc_%s s (_to_%s'arg x) (fun y -> Rpc_server.reply s (_xof_%s'res (Rpc_server.xdr_ctx srv) 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"
;;
