generator/generator_ocaml.ml

   1 (* libguestfs
   2  * Copyright (C) 2009-2011 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *)
  18
  19 (* Please read generator/README first. *)
  20
  21 open Printf
  22
  23 open Generator_types
  24 open Generator_utils
  25 open Generator_pr
  26 open Generator_docstrings
  27 open Generator_optgroups
  28 open Generator_actions
  29 open Generator_structs
  30 open Generator_c
  31 open Generator_events
  32
  33 (* Generate the OCaml bindings interface. *)
  34 let rec generate_ocaml_mli () =
  35   generate_header OCamlStyle LGPLv2plus;
  36
  37   pr "\
  38 (** libguestfs bindings for OCaml.
  39
  40     For API documentation, the canonical reference is the
  41     {{:http://libguestfs.org/guestfs.3.html}guestfs(3)} man page.
  42     The OCaml API uses almost exactly the same calls.
  43
  44     For examples written in OCaml see the
  45     {{:http://libguestfs.org/guestfs-ocaml.3.html}guestfs-ocaml(3)} man page.
  46     *)
  47
  48 (** {2 Module style API}
  49
  50     This is the module-style API.  There is also an object-oriented API
  51     (see the end of this file and {!guestfs})
  52     which is functionally completely equivalent, but is more compact. *)
  53
  54 type t
  55 (** A [guestfs_h] handle. *)
  56
  57 exception Error of string
  58 (** This exception is raised when there is an error. *)
  59
  60 exception Handle_closed of string
  61 (** This exception is raised if you use a {!t} handle
  62     after calling {!close} on it.  The string is the name of
  63     the function. *)
  64
  65 val create : unit -> t
  66 (** Create a {!t} handle. *)
  67
  68 val close : t -> unit
  69 (** Close the {!t} handle and free up all resources used
  70     by it immediately.
  71
  72     Handles are closed by the garbage collector when they become
  73     unreferenced, but callers can call this in order to provide
  74     predictable cleanup. *)
  75
  76 type event =
  77 ";
  78   List.iter (
  79     fun (name, _) ->
  80       pr "  | EVENT_%s\n" (String.uppercase name)
  81   ) events;
  82   pr "\n";
  83
  84   pr "\
  85 val event_all : event list
  86 (** A list containing all event types. *)
  87
  88 type event_handle
  89 (** The opaque event handle which can be used to delete event callbacks. *)
  90
  91 type event_callback =
  92   t -> event -> event_handle -> string -> int64 array -> unit
  93 (** The event callback. *)
  94
  95 val set_event_callback : t -> event_callback -> event list -> event_handle
  96 (** [set_event_callback g f es] sets [f] as the event callback function
  97     for all events in the set [es].
  98
  99     Note that if the closure captures a reference to the handle,
 100     this reference will prevent the handle from being
 101     automatically closed by the garbage collector.  Since the
 102     handle is passed to the event callback, with careful programming
 103     it should be possible to avoid capturing the handle in the closure. *)
 104
 105 val delete_event_callback : t -> event_handle -> unit
 106 (** [delete_event_callback g eh] removes a previously registered
 107     event callback.  See {!set_event_callback}. *)
 108
 109 val last_errno : t -> int
 110 (** [last_errno g] returns the last errno that happened on the handle [g]
 111     (or [0] if there was no errno).  Note that the returned integer is the
 112     raw errno number, and it is {i not} related to the {!Unix.error} type.
 113
 114     [last_errno] can be overwritten by subsequent operations on a handle,
 115     so if you want to capture the errno correctly, you must call this
 116     in the {!Error} exception handler, before any other operation on [g]. *)
 117
 118 val user_cancel : t -> unit
 119 (** Cancel current transfer.  This is safe to call from OCaml signal
 120     handlers and threads. *)
 121
 122 ";
 123   generate_ocaml_structure_decls ();
 124
 125   (* The actions. *)
 126   List.iter (
 127     fun (name, style, _, flags, _, shortdesc, _) ->
 128       let deprecated =
 129         try Some (find_map (function DeprecatedBy fn -> Some fn | _ -> None)
 130                     flags)
 131         with Not_found -> None in
 132       let in_docs = not (List.mem NotInDocs flags) in
 133
 134       generate_ocaml_prototype name style;
 135
 136       if in_docs then (
 137         pr "(** %s" shortdesc;
 138         (match deprecated with
 139          | None -> ()
 140          | Some replacement ->
 141              pr "\n\n    @deprecated Use {!%s} instead\n" replacement
 142         );
 143         pr " *)\n";
 144       );
 145       pr "\n"
 146   ) all_functions_sorted;
 147
 148   pr "\
 149 (** {2 Object-oriented API}
 150
 151     This is an alternate way of calling the API using an object-oriented
 152     style, so you can use
 153     [g#]{{!guestfs.add_drive_opts}add_drive_opts} [filename]
 154     instead of [Guestfs.add_drive_opts g filename].
 155     Apart from the different style, it offers exactly the same functionality.
 156
 157     Calling [new guestfs ()] creates both the object and the handle.
 158     The object and handle are closed either implicitly when the
 159     object is garbage collected, or explicitly by calling the
 160     [g#]{{!guestfs.close}close} [()] method.
 161
 162     You can get the {!t} handle by calling
 163     [g#]{{!guestfs.ocaml_handle}ocaml_handle}.
 164
 165     Note that methods that take no parameters (except the implicit handle)
 166     get an extra unit [()] parameter.  This is so you can create a
 167     closure from the method easily.  For example
 168     [g#]{{!guestfs.get_verbose}get_verbose} [()]
 169     calls the method, whereas [g#get_verbose] is a function. *)
 170
 171 class guestfs : unit -> object
 172   method close : unit -> unit
 173   method set_event_callback : event_callback -> event list -> event_handle
 174   method delete_event_callback : event_handle -> unit
 175   method last_errno : unit -> int
 176   method user_cancel : unit -> unit
 177   method ocaml_handle : t
 178 ";
 179
 180   List.iter (
 181     function
 182     | name, ((_, [], []) as style), _, _, _, _, _ ->
 183         pr "  method %s : unit -> " name;
 184         generate_ocaml_function_type style;
 185         pr "\n"
 186     | name, style, _, _, _, _, _ ->
 187         pr "  method %s : " name;
 188         generate_ocaml_function_type style;
 189         pr "\n"
 190   ) all_functions_sorted;
 191
 192   pr "end\n"
 193
 194 (* Generate the OCaml bindings implementation. *)
 195 and generate_ocaml_ml () =
 196   generate_header OCamlStyle LGPLv2plus;
 197
 198   pr "\
 199 type t
 200
 201 exception Error of string
 202 exception Handle_closed of string
 203
 204 external create : unit -> t = \"ocaml_guestfs_create\"
 205 external close : t -> unit = \"ocaml_guestfs_close\"
 206
 207 type event =
 208 ";
 209   List.iter (
 210     fun (name, _) ->
 211       pr "  | EVENT_%s\n" (String.uppercase name)
 212   ) events;
 213   pr "\n";
 214
 215   pr "\
 216 let event_all = [
 217 ";
 218   List.iter (
 219     fun (name, _) ->
 220       pr "  EVENT_%s;\n" (String.uppercase name)
 221   ) events;
 222
 223   pr "\
 224 ]
 225
 226 type event_handle = int
 227
 228 type event_callback =
 229   t -> event -> event_handle -> string -> int64 array -> unit
 230
 231 external set_event_callback : t -> event_callback -> event list -> event_handle
 232   = \"ocaml_guestfs_set_event_callback\"
 233 external delete_event_callback : t -> event_handle -> unit
 234   = \"ocaml_guestfs_delete_event_callback\"
 235
 236 external last_errno : t -> int = \"ocaml_guestfs_last_errno\"
 237
 238 external user_cancel : t -> unit = \"ocaml_guestfs_user_cancel\" \"noalloc\"
 239
 240 (* Give the exceptions names, so they can be raised from the C code. *)
 241 let () =
 242   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
 243   Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
 244
 245 ";
 246
 247   generate_ocaml_structure_decls ();
 248
 249   (* The actions. *)
 250   List.iter (
 251     fun (name, style, _, _, _, shortdesc, _) ->
 252       generate_ocaml_prototype ~is_external:true name style;
 253   ) all_functions_sorted;
 254
 255   (* OO API. *)
 256   pr "
 257 class guestfs () =
 258   let g = create () in
 259   object
 260     method close () = close g
 261     method set_event_callback = set_event_callback g
 262     method delete_event_callback = delete_event_callback g
 263     method last_errno () = last_errno g
 264     method user_cancel () = user_cancel g
 265     method ocaml_handle = g
 266 ";
 267
 268   List.iter (
 269     function
 270     | name, (_, [], []), _, _, _, _, _ -> (* no params?  add explicit unit *)
 271         pr "    method %s () = %s g\n" name name
 272     | name, _, _, _, _, _, _ ->
 273         pr "    method %s = %s g\n" name name
 274   ) all_functions_sorted;
 275
 276   pr "  end\n"
 277
 278 (* Generate the OCaml bindings C implementation. *)
 279 and generate_ocaml_c () =
 280   generate_header CStyle LGPLv2plus;
 281
 282   pr "\
 283 #include <stdio.h>
 284 #include <stdlib.h>
 285 #include <string.h>
 286 #include <stdint.h>
 287
 288 #include <caml/config.h>
 289 #include <caml/alloc.h>
 290 #include <caml/callback.h>
 291 #include <caml/fail.h>
 292 #include <caml/memory.h>
 293 #include <caml/mlvalues.h>
 294 #include <caml/signals.h>
 295
 296 #include \"guestfs.h\"
 297
 298 #include \"guestfs_c.h\"
 299
 300 /* Copy a hashtable of string pairs into an assoc-list.  We return
 301  * the list in reverse order, but hashtables aren't supposed to be
 302  * ordered anyway.
 303  */
 304 static CAMLprim value
 305 copy_table (char * const * argv)
 306 {
 307   CAMLparam0 ();
 308   CAMLlocal5 (rv, pairv, kv, vv, cons);
 309   size_t i;
 310
 311   rv = Val_int (0);
 312   for (i = 0; argv[i] != NULL; i += 2) {
 313     kv = caml_copy_string (argv[i]);
 314     vv = caml_copy_string (argv[i+1]);
 315     pairv = caml_alloc (2, 0);
 316     Store_field (pairv, 0, kv);
 317     Store_field (pairv, 1, vv);
 318     cons = caml_alloc (2, 0);
 319     Store_field (cons, 1, rv);
 320     rv = cons;
 321     Store_field (cons, 0, pairv);
 322   }
 323
 324   CAMLreturn (rv);
 325 }
 326
 327 ";
 328
 329   (* Struct copy functions. *)
 330
 331   let emit_ocaml_copy_list_function typ =
 332     pr "static CAMLprim value\n";
 333     pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
 334     pr "{\n";
 335     pr "  CAMLparam0 ();\n";
 336     pr "  CAMLlocal2 (rv, v);\n";
 337     pr "  unsigned int i;\n";
 338     pr "\n";
 339     pr "  if (%ss->len == 0)\n" typ;
 340     pr "    CAMLreturn (Atom (0));\n";
 341     pr "  else {\n";
 342     pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
 343     pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
 344     pr "      v = copy_%s (&%ss->val[i]);\n" typ typ;
 345     pr "      caml_modify (&Field (rv, i), v);\n";
 346     pr "    }\n";
 347     pr "    CAMLreturn (rv);\n";
 348     pr "  }\n";
 349     pr "}\n";
 350     pr "\n";
 351   in
 352
 353   List.iter (
 354     fun (typ, cols) ->
 355       let has_optpercent_col =
 356         List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
 357
 358       pr "static CAMLprim value\n";
 359       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
 360       pr "{\n";
 361       pr "  CAMLparam0 ();\n";
 362       if has_optpercent_col then
 363         pr "  CAMLlocal3 (rv, v, v2);\n"
 364       else
 365         pr "  CAMLlocal2 (rv, v);\n";
 366       pr "\n";
 367       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
 368       iteri (
 369         fun i col ->
 370           (match col with
 371            | name, FString ->
 372                pr "  v = caml_copy_string (%s->%s);\n" typ name
 373            | name, FBuffer ->
 374                pr "  v = caml_alloc_string (%s->%s_len);\n" typ name;
 375                pr "  memcpy (String_val (v), %s->%s, %s->%s_len);\n"
 376                  typ name typ name
 377            | name, FUUID ->
 378                pr "  v = caml_alloc_string (32);\n";
 379                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
 380            | name, (FBytes|FInt64|FUInt64) ->
 381                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
 382            | name, (FInt32|FUInt32) ->
 383                pr "  v = caml_copy_int32 (%s->%s);\n" typ name
 384            | name, FOptPercent ->
 385                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
 386                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
 387                pr "    v = caml_alloc (1, 0);\n";
 388                pr "    Store_field (v, 0, v2);\n";
 389                pr "  } else /* None */\n";
 390                pr "    v = Val_int (0);\n";
 391            | name, FChar ->
 392                pr "  v = Val_int (%s->%s);\n" typ name
 393           );
 394           pr "  Store_field (rv, %d, v);\n" i
 395       ) cols;
 396       pr "  CAMLreturn (rv);\n";
 397       pr "}\n";
 398       pr "\n";
 399   ) structs;
 400
 401   (* Emit a copy_TYPE_list function definition only if that function is used. *)
 402   List.iter (
 403     function
 404     | typ, (RStructListOnly | RStructAndList) ->
 405         (* generate the function for typ *)
 406         emit_ocaml_copy_list_function typ
 407     | typ, _ -> () (* empty *)
 408   ) (rstructs_used_by all_functions);
 409
 410   (* The wrappers. *)
 411   List.iter (
 412     fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
 413       pr "/* Automatically generated wrapper for function\n";
 414       pr " * ";
 415       generate_ocaml_prototype name style;
 416       pr " */\n";
 417       pr "\n";
 418
 419       (* If we run into this situation, we'll need to change the
 420        * bindings a little.
 421        *)
 422       if args = [] && optargs <> [] then
 423         failwithf "ocaml bindings don't support args = [], optargs <> []";
 424
 425       let params =
 426         "gv" ::
 427           List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
 428
 429       let needs_extra_vs =
 430         match ret with RConstOptString _ -> true | _ -> false in
 431
 432       pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 433       pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
 434       List.iter (pr ", value %s") (List.tl params); pr ");\n";
 435       pr "\n";
 436
 437       pr "CAMLprim value\n";
 438       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
 439       List.iter (pr ", value %s") (List.tl params);
 440       pr ")\n";
 441       pr "{\n";
 442
 443       (* CAMLparam<N> can only take up to 5 parameters.  Further parameters
 444        * have to be passed in groups of 5 to CAMLxparam<N> calls.
 445        *)
 446       (match params with
 447        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
 448            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
 449            let rec loop = function
 450              | [] -> ()
 451              | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
 452                pr "  CAMLxparam5 (%s);\n"
 453                  (String.concat ", " [p1; p2; p3; p4; p5]);
 454                loop rest
 455              | rest ->
 456                pr "  CAMLxparam%d (%s);\n"
 457                  (List.length rest) (String.concat ", " rest)
 458            in
 459            loop rest
 460        | ps ->
 461            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
 462       );
 463       if not needs_extra_vs then
 464         pr "  CAMLlocal1 (rv);\n"
 465       else
 466         pr "  CAMLlocal3 (rv, v, v2);\n";
 467       pr "\n";
 468
 469       pr "  guestfs_h *g = Guestfs_val (gv);\n";
 470       pr "  if (g == NULL)\n";
 471       pr "    ocaml_guestfs_raise_closed (\"%s\");\n" name;
 472       pr "\n";
 473
 474       List.iter (
 475         function
 476         | Pathname n
 477         | Device n | Dev_or_Path n
 478         | String n
 479         | FileIn n
 480         | FileOut n
 481         | Key n ->
 482             (* Copy strings in case the GC moves them: RHBZ#604691 *)
 483             pr "  char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
 484         | OptString n ->
 485             pr "  char *%s =\n" n;
 486             pr "    %sv != Val_int (0) ?\n" n;
 487             pr "      guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
 488         | BufferIn n ->
 489             pr "  size_t %s_size = caml_string_length (%sv);\n" n n;
 490             pr "  char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
 491         | StringList n | DeviceList n ->
 492             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
 493         | Bool n ->
 494             pr "  int %s = Bool_val (%sv);\n" n n
 495         | Int n ->
 496             pr "  int %s = Int_val (%sv);\n" n n
 497         | Int64 n ->
 498             pr "  int64_t %s = Int64_val (%sv);\n" n n
 499         | Pointer (t, n) ->
 500             pr "  %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
 501       ) args;
 502
 503       (* Optional arguments. *)
 504       if optargs <> [] then (
 505         pr "  struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
 506         pr "  struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
 507         let uc_name = String.uppercase name in
 508         List.iter (
 509           fun argt ->
 510             let n = name_of_argt argt in
 511             let uc_n = String.uppercase n in
 512             pr "  if (%sv != Val_int (0)) {\n" n;
 513             pr "    optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
 514             pr "    optargs_s.%s = " n;
 515             (match argt with
 516              | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
 517              | Int _ -> pr "Int_val (Field (%sv, 0))" n
 518              | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
 519              | String _ ->
 520                  pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
 521              | _ -> assert false
 522             );
 523             pr ";\n";
 524             pr "  }\n";
 525         ) optargs
 526       );
 527
 528       (match ret with
 529        | RErr -> pr "  int r;\n"
 530        | RInt _ -> pr "  int r;\n"
 531        | RInt64 _ -> pr "  int64_t r;\n"
 532        | RBool _ -> pr "  int r;\n"
 533        | RConstString _ | RConstOptString _ ->
 534            pr "  const char *r;\n"
 535        | RString _ -> pr "  char *r;\n"
 536        | RStringList _ ->
 537            pr "  size_t i;\n";
 538            pr "  char **r;\n"
 539        | RStruct (_, typ) ->
 540            pr "  struct guestfs_%s *r;\n" typ
 541        | RStructList (_, typ) ->
 542            pr "  struct guestfs_%s_list *r;\n" typ
 543        | RHashtable _ ->
 544            pr "  size_t i;\n";
 545            pr "  char **r;\n"
 546        | RBufferOut _ ->
 547            pr "  char *r;\n";
 548            pr "  size_t size;\n"
 549       );
 550       pr "\n";
 551
 552       pr "  caml_enter_blocking_section ();\n";
 553       if optargs = [] then
 554         pr "  r = guestfs_%s " name
 555       else
 556         pr "  r = guestfs_%s_argv " name;
 557       generate_c_call_args ~handle:"g" style;
 558       pr ";\n";
 559       pr "  caml_leave_blocking_section ();\n";
 560
 561       (* Free strings if we copied them above. *)
 562       List.iter (
 563         function
 564         | Pathname n | Device n | Dev_or_Path n | String n | OptString n
 565         | FileIn n | FileOut n | BufferIn n | Key n ->
 566             pr "  free (%s);\n" n
 567         | StringList n | DeviceList n ->
 568             pr "  ocaml_guestfs_free_strings (%s);\n" n;
 569         | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
 570       ) args;
 571       List.iter (
 572         function
 573         | String n ->
 574             pr "  if (%sv != Val_int (0))\n" n;
 575             pr "    free ((char *) optargs_s.%s);\n" n
 576         | Bool _ | Int _ | Int64 _
 577         | Pathname _ | Device _ | Dev_or_Path _ | OptString _
 578         | FileIn _ | FileOut _ | BufferIn _ | Key _
 579         | StringList _ | DeviceList _ | Pointer _ -> ()
 580       ) optargs;
 581
 582       (match errcode_of_ret ret with
 583        | `CannotReturnError -> ()
 584        | `ErrorIsMinusOne ->
 585            pr "  if (r == -1)\n";
 586            pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
 587        | `ErrorIsNULL ->
 588            pr "  if (r == NULL)\n";
 589            pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
 590       );
 591       pr "\n";
 592
 593       (match ret with
 594        | RErr -> pr "  rv = Val_unit;\n"
 595        | RInt _ -> pr "  rv = Val_int (r);\n"
 596        | RInt64 _ ->
 597            pr "  rv = caml_copy_int64 (r);\n"
 598        | RBool _ -> pr "  rv = Val_bool (r);\n"
 599        | RConstString _ ->
 600            pr "  rv = caml_copy_string (r);\n"
 601        | RConstOptString _ ->
 602            pr "  if (r) { /* Some string */\n";
 603            pr "    v = caml_alloc (1, 0);\n";
 604            pr "    v2 = caml_copy_string (r);\n";
 605            pr "    Store_field (v, 0, v2);\n";
 606            pr "  } else /* None */\n";
 607            pr "    v = Val_int (0);\n";
 608        | RString _ ->
 609            pr "  rv = caml_copy_string (r);\n";
 610            pr "  free (r);\n"
 611        | RStringList _ ->
 612            pr "  rv = caml_copy_string_array ((const char **) r);\n";
 613            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 614            pr "  free (r);\n"
 615        | RStruct (_, typ) ->
 616            pr "  rv = copy_%s (r);\n" typ;
 617            pr "  guestfs_free_%s (r);\n" typ;
 618        | RStructList (_, typ) ->
 619            pr "  rv = copy_%s_list (r);\n" typ;
 620            pr "  guestfs_free_%s_list (r);\n" typ;
 621        | RHashtable _ ->
 622            pr "  rv = copy_table (r);\n";
 623            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 624            pr "  free (r);\n";
 625        | RBufferOut _ ->
 626            pr "  rv = caml_alloc_string (size);\n";
 627            pr "  memcpy (String_val (rv), r, size);\n";
 628       );
 629
 630       pr "  CAMLreturn (rv);\n";
 631       pr "}\n";
 632       pr "\n";
 633
 634       if List.length params > 5 then (
 635         pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 636         pr "CAMLprim value ";
 637         pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
 638         pr "CAMLprim value\n";
 639         pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
 640           name;
 641         pr "{\n";
 642         pr "  return ocaml_guestfs_%s (argv[0]" name;
 643         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
 644         pr ");\n";
 645         pr "}\n";
 646         pr "\n"
 647       )
 648   ) all_functions_sorted
 649
 650 and generate_ocaml_structure_decls () =
 651   List.iter (
 652     fun (typ, cols) ->
 653       pr "type %s = {\n" typ;
 654       List.iter (
 655         function
 656         | name, FString -> pr "  %s : string;\n" name
 657         | name, FBuffer -> pr "  %s : string;\n" name
 658         | name, FUUID -> pr "  %s : string;\n" name
 659         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
 660         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
 661         | name, FChar -> pr "  %s : char;\n" name
 662         | name, FOptPercent -> pr "  %s : float option;\n" name
 663       ) cols;
 664       pr "}\n";
 665       pr "\n"
 666   ) structs
 667
 668 and generate_ocaml_prototype ?(is_external = false) name style =
 669   if is_external then pr "external " else pr "val ";
 670   pr "%s : t -> " name;
 671   generate_ocaml_function_type style;
 672   if is_external then (
 673     pr " = ";
 674     let _, args, optargs = style in
 675     if List.length args + List.length optargs + 1 > 5 then
 676       pr "\"ocaml_guestfs_%s_byte\" " name;
 677     pr "\"ocaml_guestfs_%s\"" name
 678   );
 679   pr "\n"
 680
 681 and generate_ocaml_function_type (ret, args, optargs) =
 682   List.iter (
 683     function
 684     | Bool n -> pr "?%s:bool -> " n
 685     | Int n -> pr "?%s:int -> " n
 686     | Int64 n -> pr "?%s:int64 -> " n
 687     | String n -> pr "?%s:string -> " n
 688     | _ -> assert false
 689   ) optargs;
 690   List.iter (
 691     function
 692     | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
 693     | BufferIn _ | Key _ -> pr "string -> "
 694     | OptString _ -> pr "string option -> "
 695     | StringList _ | DeviceList _ -> pr "string array -> "
 696     | Bool _ -> pr "bool -> "
 697     | Int _ -> pr "int -> "
 698     | Int64 _ | Pointer _ -> pr "int64 -> "
 699   ) args;
 700   (match ret with
 701    | RErr -> pr "unit" (* all errors are turned into exceptions *)
 702    | RInt _ -> pr "int"
 703    | RInt64 _ -> pr "int64"
 704    | RBool _ -> pr "bool"
 705    | RConstString _ -> pr "string"
 706    | RConstOptString _ -> pr "string option"
 707    | RString _ | RBufferOut _ -> pr "string"
 708    | RStringList _ -> pr "string array"
 709    | RStruct (_, typ) -> pr "%s" typ
 710    | RStructList (_, typ) -> pr "%s array" typ
 711    | RHashtable _ -> pr "(string * string) list"
 712   )