generator/wrappi_c_impl.ml

   1 (* wrappi
   2  * Copyright (C) 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 open Camlp4.PreCast
  20
  21 open Wrappi_utils
  22 open Wrappi_types
  23 open Wrappi_boilerplate
  24 open Wrappi_pr
  25
  26 open Printf
  27
  28 let inputs = ["wrappi_c_impl.ml"]
  29
  30 let c_of_ptype ~param = function
  31   | TBool -> "int"
  32   | TBuffer -> assert false (* XXX not implemented *)
  33   | TEnum name -> sprintf "wrap_%s_enum" name
  34   | TFile -> if param then "const char *" else "char *"
  35   | THash t -> if param then "char * const *" else "char **"
  36   | TInt -> "int" (* XXX not int, correct type depends on preconditions *)
  37   | TInt32 -> "int32_t"
  38   | TInt64 -> "int64_t"
  39   | TList t -> assert false (* XXX not implemented *)
  40   | TNullable TString -> if param then "const char *" else "char *"
  41   | TNullable _ -> assert false (* XXX may be implemented in future *)
  42   | TString -> if param then "const char *" else "char *"
  43   | TStruct name ->
  44     if param then sprintf "const struct wrap_%s *" name
  45     else sprintf "struct wrap_%s *" name
  46   | TTypedef name -> assert false (* should never happen *)
  47   | TUInt32 -> "uint32_t"
  48   | TUInt64 -> "uint64_t"
  49   | TUnion name -> sprintf "union wrap_%s" name
  50
  51 let c_of_rtype = function
  52   | RVoid -> "void"
  53   | RStaticString -> "const char *"
  54   | Return t -> c_of_ptype ~param:false t
  55
  56 let pr_defn ?(impl = false) ep =
  57   let ret, req, opt = ep.ep_ftype in
  58
  59   if not impl then (
  60     pr "%s\n" (c_of_rtype ret);
  61     pr "wrap_%s (wrap_h *w" ep.ep_name
  62   ) else (
  63     pr "static %s\n" (c_of_rtype ret);
  64     pr "impl_%s (struct wrap_internal_h *w" ep.ep_name
  65   );
  66
  67   (* Required parameters. *)
  68   List.iter (
  69     fun (name, t, _) ->
  70       let t = c_of_ptype ~param:true t in
  71       let sep = (* "const char *" - omit space after asterisk *)
  72         let len = String.length t in
  73         if isalnum t.[len-1] then " " else "" in
  74       pr ", %s%s%s" t sep name
  75   ) req;
  76
  77   (* Optional parameters. *)
  78   if opt <> [] then
  79     pr ", ...";
  80
  81   pr ")\n"
  82
  83 let generate_implementation ep =
  84   generate_header inputs CStyle LGPLv2plus;
  85
  86   pr "\
  87 /* Automatically generated implementation of '%s'.
  88 " ep.ep_name;
  89
  90   if not (Loc.is_ghost ep.ep_loc) then
  91     pr " * This API was defined in '%s' at line %d.\n"
  92       (Loc.file_name ep.ep_loc) (Loc.start_line ep.ep_loc);
  93
  94   pr " */
  95
  96 #include <config.h>
  97
  98 #include <stdio.h>
  99 #include <stdlib.h>
 100 #include <stdint.h>
 101 #include <string.h>
 102 #include <assert.h>
 103 ";
 104   List.iter (pr "#include <%s>\n") ep.ep_includes;
 105
 106 pr "\
 107
 108 #include \"wrappi.h\"
 109 #include \"internal.h\"
 110
 111 ";
 112
 113   pr_defn ~impl:(not ep.ep_local) ep;
 114
 115   pr "{\n";
 116
 117   (match ep.ep_code with
 118   | None -> () (* XXX implicit code *)
 119   | Some { cc_loc = loc; cc_code = code } ->
 120     (* If the return is a struct/union/list then allocate the structure
 121      * in a local variable called 'ret' which the function should
 122      * assign to.
 123      *)
 124     let ret, _, _ = ep.ep_ftype in
 125     (match ret with
 126     | Return (TStruct name) ->
 127       pr "  struct wrap_%s *ret = malloc (sizeof *ret);\n" name;
 128       pr "  if (!ret) {\n";
 129       pr "    set_error_errno (\"malloc: struct wrap_%%s\", \"%s\");\n" name;
 130       pr "    return NULL;\n";
 131       pr "  }\n"
 132     | _ -> () (* XXX union, list, etc. *)
 133     );
 134
 135     (* Make sure included code has correct line numbers. *)
 136     if not (Loc.is_ghost loc) then
 137       pr "#line %d \"%s\"\n" (Loc.start_line loc) (Loc.file_name loc);
 138
 139     pr "%s" code
 140   );
 141
 142   pr "}\n";
 143
 144   (* For remote functions only, we now need to generate the
 145    * local binding code.
 146    *)
 147   if not ep.ep_local then (
 148     pr "\n";
 149
 150     pr_defn ep;
 151
 152     pr "{\n";
 153     pr "  /* XXX Argument precondition checks here. */\n";
 154     pr "\n";
 155     pr "  if (w->scheme == WRAP_SCHEME_LOCAL) {\n";
 156     pr "    /* Local connection. */\n";
 157     pr "    ";
 158
 159     let name = ep.ep_name in
 160     let ret, req, opt = ep.ep_ftype in
 161
 162     (match ret with
 163     | RVoid -> ()
 164     | _ -> pr "return "
 165     );
 166
 167     pr "impl_%s ((struct wrap_internal_h *)w" name;
 168
 169     (* Required parameters. *)
 170     List.iter (fun (n, _, _) -> pr ", %s" n) req;
 171
 172     (* Optional parameters. *)
 173     if opt <> [] then
 174       assert false; (* XXX not implemented *)
 175
 176     pr ");\n";
 177
 178     (match ret with
 179     | RVoid -> pr "    return;\n"
 180     | _ -> ()
 181     );
 182
 183     pr "  } else {\n";
 184     pr "    /* Remote connection. */\n";
 185     pr "    struct wrap_int_%s_args args;\n" name;
 186     pr "    struct wrap_int_%s_ret ret;\n" name;
 187     pr "\n";
 188     List.iter (fun (n, _, _) -> pr "    args.%s = %s;\n" n n) req;
 189
 190     if opt <> [] then assert false; (* XXX not implemented *)
 191     pr "\n";
 192
 193     pr "    memset (&ret, 0, sizeof ret);\n";
 194     pr "\n";
 195
 196     pr "    wrap_int_make_request (w, wrap_int_%s_num,\n" name;
 197     pr "                           &args, &ret);\n";
 198
 199     (match ret with
 200     | RVoid -> ()
 201     | _ ->
 202       pr "\n";
 203       pr "    return ret.r;\n"
 204     );
 205
 206     pr "  }\n";
 207
 208     pr "}\n"
 209   )
 210
 211 let generate_lib_internal_procs_h api =
 212   generate_header inputs CStyle LGPLv2plus;
 213
 214   pr "\
 215 #ifndef WRAPPI_INTERNAL_PROCS_H_
 216 #define WRAPPI_INTERNAL_PROCS_H_
 217
 218 ";
 219
 220   pr "\
 221 /* NOTE: These constants can change with each run of the generator.
 222  * They are only for internal use within the library, eg. for indexing
 223  * arrays.  The constants must not 'escape' from the library into
 224  * on-the-wire formats etc.
 225  */
 226 enum {
 227 ";
 228
 229   iter_entry_points api (
 230     fun ep -> pr "  wrap_int_%s_num,\n" ep.ep_name
 231   );
 232
 233   pr "};\n";
 234   pr "\n";
 235
 236   pr "#define wrap_int_nr_procs %d\n" (StringMap.cardinal api.api_entry_points);
 237
 238   pr "\n";
 239
 240   pr "\
 241 /* These structures are used as the first stage of marshalling
 242  * arguments and return types of entry points.  It is much more
 243  * convenient to be able to pass around one of these structs,
 244  * than to have to pass a variable list of arguments.  They must
 245  * not be exposed externally.
 246  */
 247 ";
 248
 249   iter_entry_points api (
 250     fun ep ->
 251       let name = ep.ep_name in
 252       let ret, req, opt = ep.ep_ftype in
 253
 254       pr "struct wrap_int_%s_args {\n" name;
 255       List.iter (
 256         fun (n, t, _) ->
 257           let t = c_of_ptype ~param:true t in
 258           let sep = (* "const char *" - omit space after asterisk *)
 259             let len = String.length t in
 260             if isalnum t.[len-1] then " " else "" in
 261           pr "  %s%s%s;\n" t sep n
 262       ) req;
 263       pr "};\n";
 264       pr "\n";
 265
 266       if opt <> [] then assert false; (* XXX not implemented *)
 267
 268       pr "struct wrap_int_%s_ret {\n" name;
 269       (match ret with
 270       | RVoid -> ()
 271       | RStaticString -> pr "  const char *r;\n";
 272       | Return t ->
 273         let t = c_of_ptype ~param:false t in
 274         let sep = (* "const char *" - omit space after asterisk *)
 275           let len = String.length t in
 276           if isalnum t.[len-1] then " " else "" in
 277         pr "  %s%sr;\n" t sep
 278       );
 279
 280       pr "};\n";
 281       pr "\n";
 282   );
 283
 284   iter_entry_points api (
 285     fun ep ->
 286       if not ep.ep_local then (
 287         let name = ep.ep_name in
 288         pr "extern bool_t wrap_int_xdr_%s_args (XDR *, struct wrap_int_%s_args *);\n" name name;
 289         pr "extern bool_t wrap_int_xdr_%s_ret (XDR *, struct wrap_int_%s_ret *);\n" name name
 290       )
 291   );
 292
 293   pr "\n";
 294   pr "#endif /* WRAPPI_INTERNAL_PROCS_H_ */\n"
 295
 296 let generate_lib_internal_procs_c api =
 297   generate_header inputs CStyle LGPLv2plus;
 298
 299   pr "\
 300 #include <stdlib.h>
 301
 302 #include \"wrappi.h\"
 303 #include \"internal.h\"
 304
 305 ";
 306
 307   pr "const struct proc_table wrap_int_proc_table[] = {\n";
 308
 309   iter_entry_points api (
 310     fun ep ->
 311       let name = ep.ep_name in
 312       pr "  [wrap_int_%s_num] = {\n" name;
 313       pr "    .name = \"%s\",\n" name;
 314       if not ep.ep_local then (
 315         pr "    .xdr_args = (xdrproc_t) &wrap_int_xdr_%s_args,\n" name;
 316         pr "    .xdr_ret = (xdrproc_t) &wrap_int_xdr_%s_ret,\n" name;
 317       );
 318       pr "  },\n"
 319   );
 320
 321   pr "};\n"
 322
 323 (* Make a unique, reproducible filename for each entry point. *)
 324 let filename_of_ep ep =
 325   let filename = Loc.file_name ep.ep_loc in
 326   let filename = Filename.basename filename in
 327   let filename =
 328     try Filename.chop_extension filename
 329     with Invalid_argument _ -> filename in
 330   let filename = sprintf "%s-%s.c" filename ep.ep_name in
 331   filename
 332
 333 let generate_lib_implementation_files_mk api =
 334   generate_header inputs HashStyle GPLv2plus;
 335
 336   let eps = StringMap.bindings api.api_entry_points in
 337   let cmp (a, _) (b, _) = compare a b in
 338   let eps = List.sort cmp eps in
 339   let eps = List.map snd eps in
 340
 341   let rec loop = function
 342     | [] -> ()
 343     | [ep] -> pr "\t%s\n" (filename_of_ep ep)
 344     | ep :: eps -> pr "\t%s \\\n" (filename_of_ep ep); loop eps
 345   in
 346
 347   pr "local_implementation_files := \\\n";
 348
 349   loop (List.filter (fun ep -> ep.ep_local && ep.ep_code <> None) eps);
 350
 351   pr "\n";
 352   pr "remote_implementation_files := \\\n";
 353
 354   loop (List.filter (fun ep -> not ep.ep_local) eps)
 355
 356 let generate api =
 357   let gitignores = ref [] in
 358
 359   iter_entry_points api (
 360     fun ep ->
 361       (* Local entry points which don't have associated code are
 362        * assumed to be implemented in hand-written code elsewhere under
 363        * lib/.
 364        *)
 365       if not ep.ep_local || ep.ep_code <> None then (
 366         let filename = filename_of_ep ep in
 367
 368         gitignores := ("/" ^ filename) :: !gitignores;
 369
 370         output_to ("lib/" ^ filename) generate_implementation ep
 371       )
 372   );
 373
 374   output_to "lib/internal-procs.h"
 375     generate_lib_internal_procs_h api;
 376
 377   output_to "lib/internal-procs.c"
 378     generate_lib_internal_procs_c api;
 379
 380   output_to "lib/implementation_files.mk"
 381     generate_lib_implementation_files_mk api;
 382
 383   let gitignores = List.rev !gitignores in
 384   output_to "lib/.gitignore"
 385     (fun () -> List.iter (pr "%s\n") gitignores) ()