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