generator-lib/wrappi_accumulator.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_types
  22 open Wrappi_utils
  23
  24 open Printf
  25
  26 let check_not_defined name new_ map thing get_loc =
  27   try
  28     let old = StringMap.find name map in
  29     eprintf "generator: %s %s redefined\n" thing name;
  30     let old_loc = get_loc old in
  31     let new_loc = get_loc new_ in
  32     eprintf "  first definition at %s:%d\n"
  33       (Loc.file_name old_loc) (Loc.start_line old_loc);
  34     eprintf "  second definition at %s:%d\n"
  35       (Loc.file_name new_loc) (Loc.start_line new_loc);
  36     exit 1
  37   with
  38     Not_found -> ()
  39
  40 let tds = ref StringMap.empty
  41 let add_typedef td =
  42   let name = td.td_name in
  43   check_not_defined name td !tds "typedef" (fun td -> td.td_loc);
  44   tds := StringMap.add name td !tds
  45
  46 let ens = ref StringMap.empty
  47 let add_enum en =
  48   let name = en.en_name in
  49   check_not_defined name en !ens "enum" (fun en -> en.en_loc);
  50   ens := StringMap.add name en !ens
  51
  52 let sds = ref StringMap.empty
  53 let add_struct sd =
  54   let name = sd.sd_name in
  55   check_not_defined name sd !sds "struct" (fun sd -> sd.sd_loc);
  56   sds := StringMap.add name sd !sds
  57
  58 let uns = ref StringMap.empty
  59 let add_union un =
  60   let name = un.un_name in
  61   check_not_defined name un !uns "union" (fun un -> un.un_loc);
  62   uns := StringMap.add name un !uns
  63
  64 let eps = ref StringMap.empty
  65 let add_entry_point ep =
  66   let name = ep.ep_name in
  67   check_not_defined name ep !eps "entry_point" (fun ep -> ep.ep_loc);
  68   eps := StringMap.add name ep !eps
  69
  70 let rec resolve_typedefs thing name loc = function
  71   | (TBool
  72         | TBuffer
  73         | TEnum _
  74         | TFile
  75         | TInt
  76         | TInt32
  77         | TInt64
  78         | TString
  79         | TStruct _
  80         | TUInt32
  81         | TUInt64
  82         | TUnion _) as t -> t
  83
  84   | THash t -> THash (resolve_typedefs thing name loc t)
  85   | TList t -> TList (resolve_typedefs thing name loc t)
  86   | TNullable t -> TNullable (resolve_typedefs thing name loc t)
  87
  88   | TTypedef tname ->
  89     try (StringMap.find tname !tds).td_type
  90     with Not_found ->
  91       eprintf "generator: could not resolve typedef %s\n" tname;
  92       eprintf "  in definition of %s %s at %s:%d\n"
  93         thing name (Loc.file_name loc) (Loc.start_line loc);
  94       exit 1
  95
  96 let resolve_typedefs_in_ret thing name loc = function
  97   | RErr as t -> t
  98   | Return t -> Return (resolve_typedefs thing name loc t)
  99
 100 let get_api () =
 101   let tds = !tds in
 102   let ens = !ens in
 103   let sds = !sds in
 104   let uns = !uns in
 105   let eps = !eps in
 106
 107   (* Resolve typedefs in all ptypes in everything. *)
 108   let sds = StringMap.map (
 109     fun sd ->
 110       let fields = sd.sd_fields in
 111       let fields =
 112         Array.map (resolve_typedefs "enum" sd.sd_name sd.sd_loc) fields in
 113       { sd with sd_fields = fields }
 114   ) sds in
 115
 116   let uns = StringMap.map (
 117     fun un ->
 118       let fields = un.un_fields in
 119       let fields =
 120         Array.map (resolve_typedefs "union" un.un_name un.un_loc) fields in
 121       { un with un_fields = fields }
 122   ) uns in
 123
 124   let eps = StringMap.map (
 125     fun ep ->
 126       let name = ep.ep_name in
 127       let loc = ep.ep_loc in
 128       let ret, req, opt = ep.ep_ftype in
 129       let ret = resolve_typedefs_in_ret "entry_point" name loc ret in
 130       let req = List.map (
 131         fun (n, t, prec) ->
 132           n, resolve_typedefs "entry_point" name loc t, prec
 133       ) req in
 134       let opt = List.map (
 135         fun (n, t, prec) ->
 136           n, resolve_typedefs "entry_point" name loc t, prec
 137       ) opt in
 138       { ep with ep_ftype = (ret, req, opt) }
 139   ) eps in
 140
 141   { api_typedefs = tds;
 142     api_enums = ens;
 143     api_structs = sds;
 144     api_unions = uns;
 145     api_entry_points = eps }