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")
 428             (args_of_optargs optargs @ args) in
 429
 430       let needs_extra_vs =
 431         match ret with RConstOptString _ -> true | _ -> false in
 432
 433       pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 434       pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
 435       List.iter (pr ", value %s") (List.tl params); pr ");\n";
 436       pr "\n";
 437
 438       pr "CAMLprim value\n";
 439       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
 440       List.iter (pr ", value %s") (List.tl params);
 441       pr ")\n";
 442       pr "{\n";
 443
 444       (* CAMLparam<N> can only take up to 5 parameters.  Further parameters
 445        * have to be passed in groups of 5 to CAMLxparam<N> calls.
 446        *)
 447       (match params with
 448        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
 449            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
 450            let rec loop = function
 451              | [] -> ()
 452              | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
 453                pr "  CAMLxparam5 (%s);\n"
 454                  (String.concat ", " [p1; p2; p3; p4; p5]);
 455                loop rest
 456              | rest ->
 457                pr "  CAMLxparam%d (%s);\n"
 458                  (List.length rest) (String.concat ", " rest)
 459            in
 460            loop rest
 461        | ps ->
 462            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
 463       );
 464       if not needs_extra_vs then
 465         pr "  CAMLlocal1 (rv);\n"
 466       else
 467         pr "  CAMLlocal3 (rv, v, v2);\n";
 468       pr "\n";
 469
 470       pr "  guestfs_h *g = Guestfs_val (gv);\n";
 471       pr "  if (g == NULL)\n";
 472       pr "    ocaml_guestfs_raise_closed (\"%s\");\n" name;
 473       pr "\n";
 474
 475       List.iter (
 476         function
 477         | Pathname n
 478         | Device n | Dev_or_Path n
 479         | String n
 480         | FileIn n
 481         | FileOut n
 482         | Key n ->
 483             (* Copy strings in case the GC moves them: RHBZ#604691 *)
 484             pr "  char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
 485         | OptString n ->
 486             pr "  char *%s =\n" n;
 487             pr "    %sv != Val_int (0) ?\n" n;
 488             pr "      guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
 489         | BufferIn n ->
 490             pr "  size_t %s_size = caml_string_length (%sv);\n" n n;
 491             pr "  char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
 492         | StringList n | DeviceList n ->
 493             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
 494         | Bool n ->
 495             pr "  int %s = Bool_val (%sv);\n" n n
 496         | Int n ->
 497             pr "  int %s = Int_val (%sv);\n" n n
 498         | Int64 n ->
 499             pr "  int64_t %s = Int64_val (%sv);\n" n n
 500         | Pointer (t, n) ->
 501             pr "  %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
 502       ) args;
 503
 504       (* Optional arguments. *)
 505       if optargs <> [] then (
 506         pr "  struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
 507         pr "  struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
 508         let uc_name = String.uppercase name in
 509         List.iter (
 510           fun argt ->
 511             let n = name_of_optargt argt in
 512             let uc_n = String.uppercase n in
 513             pr "  if (%sv != Val_int (0)) {\n" n;
 514             pr "    optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
 515             pr "    optargs_s.%s = " n;
 516             (match argt with
 517              | OBool _ -> pr "Bool_val (Field (%sv, 0))" n
 518              | OInt _ -> pr "Int_val (Field (%sv, 0))" n
 519              | OInt64 _ -> pr "Int64_val (Field (%sv, 0))" n
 520              | OString _ ->
 521                  pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
 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         | OBool _ | OInt _ | OInt64 _ -> ()
 574         | OString n ->
 575             pr "  if (%sv != Val_int (0))\n" n;
 576             pr "    free ((char *) optargs_s.%s);\n" n
 577       ) optargs;
 578
 579       (match errcode_of_ret ret with
 580        | `CannotReturnError -> ()
 581        | `ErrorIsMinusOne ->
 582            pr "  if (r == -1)\n";
 583            pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
 584        | `ErrorIsNULL ->
 585            pr "  if (r == NULL)\n";
 586            pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
 587       );
 588       pr "\n";
 589
 590       (match ret with
 591        | RErr -> pr "  rv = Val_unit;\n"
 592        | RInt _ -> pr "  rv = Val_int (r);\n"
 593        | RInt64 _ ->
 594            pr "  rv = caml_copy_int64 (r);\n"
 595        | RBool _ -> pr "  rv = Val_bool (r);\n"
 596        | RConstString _ ->
 597            pr "  rv = caml_copy_string (r);\n"
 598        | RConstOptString _ ->
 599            pr "  if (r) { /* Some string */\n";
 600            pr "    v = caml_alloc (1, 0);\n";
 601            pr "    v2 = caml_copy_string (r);\n";
 602            pr "    Store_field (v, 0, v2);\n";
 603            pr "  } else /* None */\n";
 604            pr "    v = Val_int (0);\n";
 605        | RString _ ->
 606            pr "  rv = caml_copy_string (r);\n";
 607            pr "  free (r);\n"
 608        | RStringList _ ->
 609            pr "  rv = caml_copy_string_array ((const char **) r);\n";
 610            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 611            pr "  free (r);\n"
 612        | RStruct (_, typ) ->
 613            pr "  rv = copy_%s (r);\n" typ;
 614            pr "  guestfs_free_%s (r);\n" typ;
 615        | RStructList (_, typ) ->
 616            pr "  rv = copy_%s_list (r);\n" typ;
 617            pr "  guestfs_free_%s_list (r);\n" typ;
 618        | RHashtable _ ->
 619            pr "  rv = copy_table (r);\n";
 620            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 621            pr "  free (r);\n";
 622        | RBufferOut _ ->
 623            pr "  rv = caml_alloc_string (size);\n";
 624            pr "  memcpy (String_val (rv), r, size);\n";
 625            pr "  free (r);\n"
 626       );
 627
 628       pr "  CAMLreturn (rv);\n";
 629       pr "}\n";
 630       pr "\n";
 631
 632       if List.length params > 5 then (
 633         pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 634         pr "CAMLprim value ";
 635         pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
 636         pr "CAMLprim value\n";
 637         pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
 638           name;
 639         pr "{\n";
 640         pr "  return ocaml_guestfs_%s (argv[0]" name;
 641         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
 642         pr ");\n";
 643         pr "}\n";
 644         pr "\n"
 645       )
 646   ) all_functions_sorted
 647
 648 and generate_ocaml_structure_decls () =
 649   List.iter (
 650     fun (typ, cols) ->
 651       pr "type %s = {\n" typ;
 652       List.iter (
 653         function
 654         | name, FString -> pr "  %s : string;\n" name
 655         | name, FBuffer -> pr "  %s : string;\n" name
 656         | name, FUUID -> pr "  %s : string;\n" name
 657         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
 658         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
 659         | name, FChar -> pr "  %s : char;\n" name
 660         | name, FOptPercent -> pr "  %s : float option;\n" name
 661       ) cols;
 662       pr "}\n";
 663       pr "\n"
 664   ) structs
 665
 666 and generate_ocaml_prototype ?(is_external = false) name style =
 667   if is_external then pr "external " else pr "val ";
 668   pr "%s : t -> " name;
 669   generate_ocaml_function_type style;
 670   if is_external then (
 671     pr " = ";
 672     let _, args, optargs = style in
 673     if List.length args + List.length optargs + 1 > 5 then
 674       pr "\"ocaml_guestfs_%s_byte\" " name;
 675     pr "\"ocaml_guestfs_%s\"" name
 676   );
 677   pr "\n"
 678
 679 and generate_ocaml_function_type (ret, args, optargs) =
 680   List.iter (
 681     function
 682     | OBool n -> pr "?%s:bool -> " n
 683     | OInt n -> pr "?%s:int -> " n
 684     | OInt64 n -> pr "?%s:int64 -> " n
 685     | OString n -> pr "?%s:string -> " n
 686   ) optargs;
 687   List.iter (
 688     function
 689     | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
 690     | BufferIn _ | Key _ -> pr "string -> "
 691     | OptString _ -> pr "string option -> "
 692     | StringList _ | DeviceList _ -> pr "string array -> "
 693     | Bool _ -> pr "bool -> "
 694     | Int _ -> pr "int -> "
 695     | Int64 _ | Pointer _ -> pr "int64 -> "
 696   ) args;
 697   (match ret with
 698    | RErr -> pr "unit" (* all errors are turned into exceptions *)
 699    | RInt _ -> pr "int"
 700    | RInt64 _ -> pr "int64"
 701    | RBool _ -> pr "bool"
 702    | RConstString _ -> pr "string"
 703    | RConstOptString _ -> pr "string option"
 704    | RString _ | RBufferOut _ -> pr "string"
 705    | RStringList _ -> pr "string array"
 706    | RStruct (_, typ) -> pr "%s" typ
 707    | RStructList (_, typ) -> pr "%s array" typ
 708    | RHashtable _ -> pr "(string * string) list"
 709   )