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 "  if (w->scheme == NULL) {\n";
 154     pr "    /* Local connection. */\n";
 155     pr "    ";
 156
 157     let ret, req, opt = ep.ep_ftype in
 158
 159     (match ret with
 160     | RVoid -> ()
 161     | _ -> pr "return "
 162     );
 163
 164     pr "impl_%s ((struct wrap_internal_h *)w" ep.ep_name;
 165
 166     (* Required parameters. *)
 167     List.iter (fun (name, _, _) -> pr ", %s" name) req;
 168
 169     (* Optional parameters. *)
 170     if opt <> [] then
 171       assert false; (* XXX not implemented *)
 172
 173     pr ");\n";
 174
 175     (match ret with
 176     | RVoid -> pr "    return;\n"
 177     | _ -> ()
 178     );
 179
 180     pr "  } else {\n";
 181     pr "    /* Remote connection. */\n";
 182     pr "    abort (); /* XXX */\n";
 183     pr "  }\n";
 184
 185     pr "}\n"
 186   )
 187
 188 (* Make a unique, reproducible filename for each entry point. *)
 189 let filename_of_ep ep =
 190   let filename = Loc.file_name ep.ep_loc in
 191   let filename = Filename.basename filename in
 192   let filename =
 193     try Filename.chop_extension filename
 194     with Invalid_argument _ -> filename in
 195   let filename = sprintf "%s-%s.c" filename ep.ep_name in
 196   filename
 197
 198 let generate_lib_implementation_files_mk api =
 199   generate_header inputs HashStyle GPLv2plus;
 200
 201   let eps = StringMap.bindings api.api_entry_points in
 202   let cmp (a, _) (b, _) = compare a b in
 203   let eps = List.sort cmp eps in
 204   let eps = List.map snd eps in
 205
 206   let rec loop = function
 207     | [] -> ()
 208     | [ep] -> pr "\t%s\n" (filename_of_ep ep)
 209     | ep :: eps -> pr "\t%s \\\n" (filename_of_ep ep); loop eps
 210   in
 211
 212   pr "local_implementation_files := \\\n";
 213
 214   loop (List.filter (fun ep -> ep.ep_local && ep.ep_code <> None) eps);
 215
 216   pr "\n";
 217   pr "remote_implementation_files := \\\n";
 218
 219   loop (List.filter (fun ep -> not ep.ep_local) eps)
 220
 221 let generate api =
 222   let gitignores = ref [] in
 223
 224   iter_entry_points api (
 225     fun ep ->
 226       (* Local entry points which don't have associated code are
 227        * assumed to be implemented in hand-written code elsewhere under
 228        * lib/.
 229        *)
 230       if not ep.ep_local || ep.ep_code <> None then (
 231         let filename = filename_of_ep ep in
 232
 233         gitignores := ("/" ^ filename) :: !gitignores;
 234
 235         output_to ("lib/" ^ filename) generate_implementation ep
 236       )
 237   );
 238
 239   let gitignores = List.rev !gitignores in
 240   output_to "lib/.gitignore"
 241     (fun () -> List.iter (pr "%s\n") gitignores) ();
 242
 243   output_to "lib/implementation_files.mk"
 244     generate_lib_implementation_files_mk api