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   | Return t -> c_of_ptype ~param:false t
  50
  51 let pr_decl ep =
  52   let ret, req, opt = ep.ep_ftype in
  53   pr "%s\n" (c_of_rtype ret);
  54   pr "wrap_%s (wrap_h *w" ep.ep_name;
  55
  56   (* Required parameters. *)
  57   List.iter (
  58     fun (name, t, _) ->
  59       let t = c_of_ptype ~param:true t in
  60       let sep = (* "const char *" - omit space after asterisk *)
  61         let len = String.length t in
  62         if isalnum t.[len-1] then " " else "" in
  63       pr ", %s%s%s" t sep name
  64   ) req;
  65
  66   (* Optional parameters. *)
  67   if opt <> [] then
  68     pr ", ...";
  69
  70   pr ")\n"
  71
  72 let generate_implementation ep =
  73   generate_header CStyle LGPLv2plus;
  74
  75   pr "\
  76 #include <config.h>
  77
  78 #include <stdio.h>
  79 #include <stdlib.h>
  80 ";
  81   List.iter (pr "#include <%s>\n") ep.ep_includes;
  82
  83 pr "\
  84
  85 #include \"wrappi.h\"
  86
  87 #include \"internal.h\"
  88
  89 /* Automatically generated implementation of '%s'.
  90  * This API was defined in '%s' at line %d.
  91  */
  92
  93 " ep.ep_name (Loc.file_name ep.ep_loc) (Loc.start_line ep.ep_loc);
  94
  95   (* Depending on whether this is a local or remote function, include
  96    * different definitions here.
  97    *)
  98   (*if ep.ep_local then ... *)
  99
 100   pr_decl ep;
 101
 102   pr "\
 103 {
 104 #line %d \"%s\"
 105 " (Loc.start_line ep.ep_loc) (Loc.file_name ep.ep_loc);
 106
 107   (match ep.ep_code with
 108   | None -> ()
 109   | Some code -> pr "%s" code
 110   );
 111
 112   pr "}\n"
 113
 114 (* Make a unique, reproducible filename for each entry point. *)
 115 let filename_of_ep ep =
 116   let filename = Loc.file_name ep.ep_loc in
 117   let filename = Filename.basename filename in
 118   let filename =
 119     try Filename.chop_extension filename
 120     with Invalid_argument _ -> filename in
 121   let filename = sprintf "%s-%s.c" filename ep.ep_name in
 122   filename
 123
 124 let generate_lib_implementation_files_mk api =
 125   generate_header HashStyle GPLv2plus;
 126
 127   let eps = StringMap.bindings api.api_entry_points in
 128   let cmp (a, _) (b, _) = compare a b in
 129   let eps = List.sort cmp eps in
 130   let eps = List.map snd eps in
 131
 132   let rec loop = function
 133     | [] -> ()
 134     | [ep] -> pr "\t%s\n" (filename_of_ep ep)
 135     | ep :: eps -> pr "\t%s \\\n" (filename_of_ep ep); loop eps
 136   in
 137
 138   pr "local_implementation_files := \\\n";
 139
 140   loop (List.filter (fun ep -> ep.ep_local) eps);
 141
 142   pr "\n";
 143   pr "remote_implementation_files := \\\n";
 144
 145   loop (List.filter (fun ep -> not ep.ep_local) eps)
 146
 147 let generate api =
 148   let gitignores = ref [] in
 149
 150   iter_entry_points api (
 151     fun ep ->
 152       let filename = filename_of_ep ep in
 153
 154       gitignores := ("/" ^ filename) :: !gitignores;
 155
 156       output_to ("lib/" ^ filename) generate_implementation ep
 157   );
 158
 159   let gitignores = List.rev !gitignores in
 160   output_to "lib/.gitignore"
 161     (fun () -> List.iter (pr "%s\n") gitignores) ();
 162
 163   output_to "lib/implementation_files.mk"
 164     generate_lib_implementation_files_mk api