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: error: %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 line %d\n"
  33       (Loc.file_name old_loc) (Loc.start_line old_loc);
  34     eprintf "  second definition at %s line %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
  90       let td = StringMap.find tname !tds in
  91       let t = td.td_type in
  92       (* The typedef may be a typedef, so we need to recursively
  93        * resolve the type.
  94        *)
  95       resolve_typedefs "typedef" td.td_name td.td_loc t
  96     with Not_found ->
  97       eprintf "generator: error: could not resolve typedef %s to a basic type\n"
  98         tname;
  99       eprintf "  in definition of %s %s at %s line %d\n"
 100         thing name (Loc.file_name loc) (Loc.start_line loc);
 101       exit 1
 102
 103 let resolve_typedefs_in_ret thing name loc = function
 104   | RVoid as t -> t
 105   | Return t -> Return (resolve_typedefs thing name loc t)
 106
 107 let get_api () =
 108   let tds = !tds in
 109   let ens = !ens in
 110   let sds = !sds in
 111   let uns = !uns in
 112   let eps = !eps in
 113
 114   (* Resolve typedefs in all ptypes in everything. *)
 115   let sds = StringMap.map (
 116     fun sd ->
 117       let fields = sd.sd_fields in
 118       let fields =
 119         Array.map (resolve_typedefs "enum" sd.sd_name sd.sd_loc) fields in
 120       { sd with sd_fields = fields }
 121   ) sds in
 122
 123   let uns = StringMap.map (
 124     fun un ->
 125       let fields = un.un_fields in
 126       let fields =
 127         Array.map (resolve_typedefs "union" un.un_name un.un_loc) fields in
 128       { un with un_fields = fields }
 129   ) uns in
 130
 131   let eps = StringMap.map (
 132     fun ep ->
 133       let name = ep.ep_name in
 134       let loc = ep.ep_loc in
 135       let ret, req, opt = ep.ep_ftype in
 136       let ret = resolve_typedefs_in_ret "entry_point" name loc ret in
 137       let req = List.map (
 138         fun (n, t, prec) ->
 139           n, resolve_typedefs "entry_point" name loc t, prec
 140       ) req in
 141       let opt = List.map (
 142         fun (n, t, prec) ->
 143           n, resolve_typedefs "entry_point" name loc t, prec
 144       ) opt in
 145       { ep with ep_ftype = (ret, req, opt) }
 146   ) eps in
 147
 148   { api_typedefs = tds;
 149     api_enums = ens;
 150     api_structs = sds;
 151     api_unions = uns;
 152     api_entry_points = eps }