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 c_of_ptype ~param = function
  29   | TBool -> "int"
  30   | TBuffer -> assert false (* XXX not implemented *)
  31   | TEnum name -> sprintf "enum wrap_%s" name
  32   | TFile -> if param then "const char *" else "char *"
  33   | THash t -> if param then "char * const *" else "char **"
  34   | TInt -> "int" (* XXX not int, correct type depends on preconditions *)
  35   | TInt32 -> "int32_t"
  36   | TInt64 -> "int64_t"
  37   | TList t -> assert false (* XXX not implemented *)
  38   | TNullable TString -> if param then "const char *" else "char *"
  39   | TNullable _ -> assert false (* XXX may be implemented in future *)
  40   | TString -> if param then "const char *" else "char *"
  41   | TStruct name -> sprintf "struct wrap_%s" name
  42   | TTypedef name -> assert false (* should never happen *)
  43   | TUInt32 -> "uint32_t"
  44   | TUInt64 -> "uint64_t"
  45   | TUnion name -> sprintf "union wrap_%s" name
  46
  47 let c_of_rtype = function
  48   | RVoid -> "void"
  49   | RStaticString -> "const char *"
  50   | Return t -> c_of_ptype ~param:false t
  51
  52 let pr_defn ?(impl = false) ep =
  53   let ret, req, opt = ep.ep_ftype in
  54
  55   if not impl then (
  56     pr "%s\n" (c_of_rtype ret);
  57     pr "wrap_%s (wrap_h *w" ep.ep_name
  58   ) else (
  59     pr "static %s\n" (c_of_rtype ret);
  60     pr "impl_%s (struct wrap_internal_h *w" ep.ep_name
  61   );
  62
  63   (* Required parameters. *)
  64   List.iter (
  65     fun (name, t, _) ->
  66       let t = c_of_ptype ~param:true t in
  67       let sep = (* "const char *" - omit space after asterisk *)
  68         let len = String.length t in
  69         if isalnum t.[len-1] then " " else "" in
  70       pr ", %s%s%s" t sep name
  71   ) req;
  72
  73   (* Optional parameters. *)
  74   if opt <> [] then
  75     pr ", ...";
  76
  77   pr ")\n"
  78
  79 let generate_implementation ep =
  80   generate_header CStyle LGPLv2plus;
  81
  82   pr "\
  83 /* Automatically generated implementation of '%s'.
  84  * This API was defined in '%s' at line %d.
  85  */
  86
  87 " ep.ep_name (Loc.file_name ep.ep_loc) (Loc.start_line ep.ep_loc);
  88
  89   pr "\
  90 #include <config.h>
  91
  92 #include <stdio.h>
  93 #include <stdlib.h>
  94 #include <stdint.h>
  95 #include <string.h>
  96 #include <assert.h>
  97 ";
  98   List.iter (pr "#include <%s>\n") ep.ep_includes;
  99
 100 pr "\
 101
 102 #include \"wrappi.h\"
 103 #include \"internal.h\"
 104
 105 ";
 106
 107   pr_defn ~impl:(not ep.ep_local) ep;
 108
 109   pr "{\n";
 110
 111   (match ep.ep_code with
 112   | None -> () (* XXX implicit code *)
 113   | Some { cc_loc = loc; cc_code = code } ->
 114     pr "#line %d \"%s\"\n" (Loc.start_line loc) (Loc.file_name loc);
 115     pr "%s" code
 116   );
 117
 118   pr "}\n";
 119
 120   (* For remote functions only, we now need to generate the
 121    * local binding code.
 122    *)
 123   if not ep.ep_local then (
 124     pr "\n";
 125
 126     pr_defn ep;
 127
 128     pr "{\n";
 129     pr "  assert (w->scheme == NULL); /* XXX */;\n";
 130     pr "\n";
 131     pr "  ";
 132
 133     let ret, req, opt = ep.ep_ftype in
 134
 135     (match ret with
 136     | RVoid -> ()
 137     | _ -> pr "return "
 138     );
 139
 140     pr "impl_%s ((struct wrap_internal_h *)w" ep.ep_name;
 141
 142     (* Required parameters. *)
 143     List.iter (fun (name, _, _) -> pr ", %s" name) req;
 144
 145     (* Optional parameters. *)
 146     if opt <> [] then
 147       assert false; (* XXX not implemented *)
 148
 149     pr ");\n";
 150
 151     (match ret with
 152     | RVoid -> pr "  return;\n"
 153     | _ -> ()
 154     );
 155
 156     pr "}\n"
 157   )
 158
 159 (* Make a unique, reproducible filename for each entry point. *)
 160 let filename_of_ep ep =
 161   let filename = Loc.file_name ep.ep_loc in
 162   let filename = Filename.basename filename in
 163   let filename =
 164     try Filename.chop_extension filename
 165     with Invalid_argument _ -> filename in
 166   let filename = sprintf "%s-%s.c" filename ep.ep_name in
 167   filename
 168
 169 let generate_lib_implementation_files_mk api =
 170   generate_header HashStyle GPLv2plus;
 171
 172   let eps = StringMap.bindings api.api_entry_points in
 173   let cmp (a, _) (b, _) = compare a b in
 174   let eps = List.sort cmp eps in
 175   let eps = List.map snd eps in
 176
 177   let rec loop = function
 178     | [] -> ()
 179     | [ep] -> pr "\t%s\n" (filename_of_ep ep)
 180     | ep :: eps -> pr "\t%s \\\n" (filename_of_ep ep); loop eps
 181   in
 182
 183   pr "local_implementation_files := \\\n";
 184
 185   loop (List.filter (fun ep -> ep.ep_local && ep.ep_code <> None) eps);
 186
 187   pr "\n";
 188   pr "remote_implementation_files := \\\n";
 189
 190   loop (List.filter (fun ep -> not ep.ep_local) eps)
 191
 192 let generate api =
 193   let gitignores = ref [] in
 194
 195   iter_entry_points api (
 196     fun ep ->
 197       (* Local entry points which don't have associated code are
 198        * assumed to be implemented in hand-written code elsewhere under
 199        * lib/.
 200        *)
 201       if not ep.ep_local || ep.ep_code <> None then (
 202         let filename = filename_of_ep ep in
 203
 204         gitignores := ("/" ^ filename) :: !gitignores;
 205
 206         output_to ("lib/" ^ filename) generate_implementation ep
 207       )
 208   );
 209
 210   let gitignores = List.rev !gitignores in
 211   output_to "lib/.gitignore"
 212     (fun () -> List.iter (pr "%s\n") gitignores) ();
 213
 214   output_to "lib/implementation_files.mk"
 215     generate_lib_implementation_files_mk api