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       (match params with
 444        | [p1; p2; p3; p4; p5] ->
 445            pr "  CAMLparam5 (%s);\n" (String.concat ", " params)
 446        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
 447            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
 448            pr "  CAMLxparam%d (%s);\n"
 449              (List.length rest) (String.concat ", " rest)
 450        | ps ->
 451            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
 452       );
 453       if not needs_extra_vs then
 454         pr "  CAMLlocal1 (rv);\n"
 455       else
 456         pr "  CAMLlocal3 (rv, v, v2);\n";
 457       pr "\n";
 458
 459       pr "  guestfs_h *g = Guestfs_val (gv);\n";
 460       pr "  if (g == NULL)\n";
 461       pr "    ocaml_guestfs_raise_closed (\"%s\");\n" name;
 462       pr "\n";
 463
 464       List.iter (
 465         function
 466         | Pathname n
 467         | Device n | Dev_or_Path n
 468         | String n
 469         | FileIn n
 470         | FileOut n
 471         | Key n ->
 472             (* Copy strings in case the GC moves them: RHBZ#604691 *)
 473             pr "  char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
 474         | OptString n ->
 475             pr "  char *%s =\n" n;
 476             pr "    %sv != Val_int (0) ?\n" n;
 477             pr "      guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
 478         | BufferIn n ->
 479             pr "  size_t %s_size = caml_string_length (%sv);\n" n n;
 480             pr "  char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
 481         | StringList n | DeviceList n ->
 482             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
 483         | Bool n ->
 484             pr "  int %s = Bool_val (%sv);\n" n n
 485         | Int n ->
 486             pr "  int %s = Int_val (%sv);\n" n n
 487         | Int64 n ->
 488             pr "  int64_t %s = Int64_val (%sv);\n" n n
 489         | Pointer (t, n) ->
 490             pr "  %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
 491       ) args;
 492
 493       (* Optional arguments. *)
 494       if optargs <> [] then (
 495         pr "  struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
 496         pr "  struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
 497         let uc_name = String.uppercase name in
 498         List.iter (
 499           fun argt ->
 500             let n = name_of_argt argt in
 501             let uc_n = String.uppercase n in
 502             pr "  if (%sv != Val_int (0)) {\n" n;
 503             pr "    optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
 504             pr "    optargs_s.%s = " n;
 505             (match argt with
 506              | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
 507              | Int _ -> pr "Int_val (Field (%sv, 0))" n
 508              | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
 509              | String _ ->
 510                  pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
 511              | _ -> assert false
 512             );
 513             pr ";\n";
 514             pr "  }\n";
 515         ) optargs
 516       );
 517
 518       (match ret with
 519        | RErr -> pr "  int r;\n"
 520        | RInt _ -> pr "  int r;\n"
 521        | RInt64 _ -> pr "  int64_t r;\n"
 522        | RBool _ -> pr "  int r;\n"
 523        | RConstString _ | RConstOptString _ ->
 524            pr "  const char *r;\n"
 525        | RString _ -> pr "  char *r;\n"
 526        | RStringList _ ->
 527            pr "  size_t i;\n";
 528            pr "  char **r;\n"
 529        | RStruct (_, typ) ->
 530            pr "  struct guestfs_%s *r;\n" typ
 531        | RStructList (_, typ) ->
 532            pr "  struct guestfs_%s_list *r;\n" typ
 533        | RHashtable _ ->
 534            pr "  size_t i;\n";
 535            pr "  char **r;\n"
 536        | RBufferOut _ ->
 537            pr "  char *r;\n";
 538            pr "  size_t size;\n"
 539       );
 540       pr "\n";
 541
 542       pr "  caml_enter_blocking_section ();\n";
 543       if optargs = [] then
 544         pr "  r = guestfs_%s " name
 545       else
 546         pr "  r = guestfs_%s_argv " name;
 547       generate_c_call_args ~handle:"g" style;
 548       pr ";\n";
 549       pr "  caml_leave_blocking_section ();\n";
 550
 551       (* Free strings if we copied them above. *)
 552       List.iter (
 553         function
 554         | Pathname n | Device n | Dev_or_Path n | String n | OptString n
 555         | FileIn n | FileOut n | BufferIn n | Key n ->
 556             pr "  free (%s);\n" n
 557         | StringList n | DeviceList n ->
 558             pr "  ocaml_guestfs_free_strings (%s);\n" n;
 559         | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
 560       ) args;
 561       List.iter (
 562         function
 563         | String n ->
 564             pr "  if (%sv != Val_int (0))\n" n;
 565             pr "    free ((char *) optargs_s.%s);\n" n
 566         | Bool _ | Int _ | Int64 _
 567         | Pathname _ | Device _ | Dev_or_Path _ | OptString _
 568         | FileIn _ | FileOut _ | BufferIn _ | Key _
 569         | StringList _ | DeviceList _ | Pointer _ -> ()
 570       ) optargs;
 571
 572       (match errcode_of_ret ret with
 573        | `CannotReturnError -> ()
 574        | `ErrorIsMinusOne ->
 575            pr "  if (r == -1)\n";
 576            pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
 577        | `ErrorIsNULL ->
 578            pr "  if (r == NULL)\n";
 579            pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
 580       );
 581       pr "\n";
 582
 583       (match ret with
 584        | RErr -> pr "  rv = Val_unit;\n"
 585        | RInt _ -> pr "  rv = Val_int (r);\n"
 586        | RInt64 _ ->
 587            pr "  rv = caml_copy_int64 (r);\n"
 588        | RBool _ -> pr "  rv = Val_bool (r);\n"
 589        | RConstString _ ->
 590            pr "  rv = caml_copy_string (r);\n"
 591        | RConstOptString _ ->
 592            pr "  if (r) { /* Some string */\n";
 593            pr "    v = caml_alloc (1, 0);\n";
 594            pr "    v2 = caml_copy_string (r);\n";
 595            pr "    Store_field (v, 0, v2);\n";
 596            pr "  } else /* None */\n";
 597            pr "    v = Val_int (0);\n";
 598        | RString _ ->
 599            pr "  rv = caml_copy_string (r);\n";
 600            pr "  free (r);\n"
 601        | RStringList _ ->
 602            pr "  rv = caml_copy_string_array ((const char **) r);\n";
 603            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 604            pr "  free (r);\n"
 605        | RStruct (_, typ) ->
 606            pr "  rv = copy_%s (r);\n" typ;
 607            pr "  guestfs_free_%s (r);\n" typ;
 608        | RStructList (_, typ) ->
 609            pr "  rv = copy_%s_list (r);\n" typ;
 610            pr "  guestfs_free_%s_list (r);\n" typ;
 611        | RHashtable _ ->
 612            pr "  rv = copy_table (r);\n";
 613            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 614            pr "  free (r);\n";
 615        | RBufferOut _ ->
 616            pr "  rv = caml_alloc_string (size);\n";
 617            pr "  memcpy (String_val (rv), r, size);\n";
 618       );
 619
 620       pr "  CAMLreturn (rv);\n";
 621       pr "}\n";
 622       pr "\n";
 623
 624       if List.length params > 5 then (
 625         pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 626         pr "CAMLprim value ";
 627         pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
 628         pr "CAMLprim value\n";
 629         pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
 630           name;
 631         pr "{\n";
 632         pr "  return ocaml_guestfs_%s (argv[0]" name;
 633         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
 634         pr ");\n";
 635         pr "}\n";
 636         pr "\n"
 637       )
 638   ) all_functions_sorted
 639
 640 and generate_ocaml_structure_decls () =
 641   List.iter (
 642     fun (typ, cols) ->
 643       pr "type %s = {\n" typ;
 644       List.iter (
 645         function
 646         | name, FString -> pr "  %s : string;\n" name
 647         | name, FBuffer -> pr "  %s : string;\n" name
 648         | name, FUUID -> pr "  %s : string;\n" name
 649         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
 650         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
 651         | name, FChar -> pr "  %s : char;\n" name
 652         | name, FOptPercent -> pr "  %s : float option;\n" name
 653       ) cols;
 654       pr "}\n";
 655       pr "\n"
 656   ) structs
 657
 658 and generate_ocaml_prototype ?(is_external = false) name style =
 659   if is_external then pr "external " else pr "val ";
 660   pr "%s : t -> " name;
 661   generate_ocaml_function_type style;
 662   if is_external then (
 663     pr " = ";
 664     let _, args, optargs = style in
 665     if List.length args + List.length optargs + 1 > 5 then
 666       pr "\"ocaml_guestfs_%s_byte\" " name;
 667     pr "\"ocaml_guestfs_%s\"" name
 668   );
 669   pr "\n"
 670
 671 and generate_ocaml_function_type (ret, args, optargs) =
 672   List.iter (
 673     function
 674     | Bool n -> pr "?%s:bool -> " n
 675     | Int n -> pr "?%s:int -> " n
 676     | Int64 n -> pr "?%s:int64 -> " n
 677     | String n -> pr "?%s:string -> " n
 678     | _ -> assert false
 679   ) optargs;
 680   List.iter (
 681     function
 682     | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
 683     | BufferIn _ | Key _ -> pr "string -> "
 684     | OptString _ -> pr "string option -> "
 685     | StringList _ | DeviceList _ -> pr "string array -> "
 686     | Bool _ -> pr "bool -> "
 687     | Int _ -> pr "int -> "
 688     | Int64 _ | Pointer _ -> pr "int64 -> "
 689   ) args;
 690   (match ret with
 691    | RErr -> pr "unit" (* all errors are turned into exceptions *)
 692    | RInt _ -> pr "int"
 693    | RInt64 _ -> pr "int64"
 694    | RBool _ -> pr "bool"
 695    | RConstString _ -> pr "string"
 696    | RConstOptString _ -> pr "string option"
 697    | RString _ | RBufferOut _ -> pr "string"
 698    | RStringList _ -> pr "string array"
 699    | RStruct (_, typ) -> pr "%s" typ
 700    | RStructList (_, typ) -> pr "%s array" typ
 701    | RHashtable _ -> pr "(string * string) list"
 702   )