generator/pa_wrap.ml

   1 (* wrappi
   2  * Copyright (C) 2011-2012 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 (* For general information about camlp4, see:
  20  * http://brion.inria.fr/gallium/index.php/Camlp4
  21  *
  22  * For information about quotations, see:
  23  * http://brion.inria.fr/gallium/index.php/Quotation
  24  *)
  25
  26 open Camlp4.PreCast
  27 open Syntax
  28 open Ast
  29
  30 open Wrappi_types
  31
  32 (* Convert a plain list into a list AST. *)
  33 let rec expr_of_list _loc = function
  34   | [] -> <:expr< [] >>
  35   | h::t -> let t = expr_of_list _loc t in <:expr< $h$ :: $t$ >>
  36
  37 (* Convert an optional type into an option AST. *)
  38 let expr_of_option _loc = function
  39   | None -> <:expr< None >>
  40   | Some x -> <:expr< Some $x$ >>
  41
  42 (* Convert a _loc to an AST. *)
  43 let expr_of_loc _loc loc =
  44   let file_name,
  45     start_line, start_bol, start_off,
  46     stop_line, stop_bol, stop_off,
  47     ghost = Loc.to_tuple loc in
  48   <:expr< Camlp4.PreCast.Loc.of_tuple
  49     ($str:file_name$,
  50      $`int:start_line$, $`int:start_bol$, $`int:start_off$,
  51      $`int:stop_line$, $`int:stop_bol$, $`int:stop_off$,
  52      $`bool:ghost$) >>
  53
  54 let add_entry_point _loc local name parameters rtype code includes =
  55   let loc = expr_of_loc _loc _loc in
  56
  57   let local =
  58     match local with None -> <:expr< false >> | _ -> <:expr< true >> in
  59
  60   let parameters = List.map (
  61     fun (name, t) -> <:expr< ($str:name$, $t$, None) >>
  62   ) parameters in
  63   let parameters = expr_of_list _loc parameters in
  64
  65   let code = expr_of_option _loc code in
  66
  67   let includes = match includes with None -> <:expr< [] >> | Some xs -> xs in
  68
  69   <:str_item<
  70     let ep = { Wrappi_types.ep_loc = $loc$;
  71                ep_local = $local$;
  72                ep_name = $str:name$;
  73                ep_ftype = ($rtype$, $parameters$, []);
  74                ep_code = $code$;
  75                ep_includes = $includes$ } in
  76     Wrappi_accumulator.add_entry_point ep
  77   >>
  78
  79 let add_typedef _loc name t =
  80   let loc = expr_of_loc _loc _loc in
  81
  82   <:str_item<
  83     let td = { Wrappi_types.td_loc = $loc$;
  84                td_name = $str:name$;
  85                td_type = $t$ } in
  86     Wrappi_accumulator.add_typedef td
  87   >>
  88
  89 let add_enum _loc name identifiers =
  90   let loc = expr_of_loc _loc _loc in
  91
  92   <:str_item<
  93     let en = { Wrappi_types.en_loc = $loc$;
  94                en_name = $str:name$;
  95                en_identifiers = Array.of_list $identifiers$ } in
  96     Wrappi_accumulator.add_enum en
  97   >>
  98
  99 let add_struct _loc name fields =
 100   let loc = expr_of_loc _loc _loc in
 101
 102   let fields = List.map (
 103     fun (name, t) -> <:expr< ($str:name$, $t$) >>
 104   ) fields in
 105   let fields = expr_of_list _loc fields in
 106
 107   <:str_item<
 108     let sd = { Wrappi_types.sd_loc = $loc$;
 109                sd_name = $str:name$;
 110                sd_fields = Array.of_list $fields$ } in
 111     Wrappi_accumulator.add_struct sd
 112   >>
 113
 114 let () =
 115   (* Quotation expander for C code. *)
 116   let c_quotation_expander _loc _ code =
 117     let loc = expr_of_loc _loc _loc in
 118
 119     (* XXX Expand %- or $- expressions in code. *)
 120     (* XXX Escape >> in code. *)
 121
 122     <:expr< { Wrappi_types.cc_loc = $loc$;
 123               cc_code = $str:code$ } >>
 124   in
 125   Quotation.add "c" Quotation.DynAst.expr_tag c_quotation_expander;
 126
 127   (* Default quotation expander (<< .. >>) should be C code ("c"). *)
 128   Quotation.default := "c"
 129
 130 ;;
 131
 132 (* Extend the regular OCaml grammar. *)
 133 EXTEND Gram
 134   GLOBAL: str_item;
 135
 136   (* A parameter or return type. *)
 137   ptype: [
 138     [ "bool" -> <:expr< Wrappi_types.TBool >> ]
 139   | [ "buffer" -> <:expr< Wrappi_types.TBuffer >> ]
 140   | [ "enum"; name = LIDENT -> <:expr< Wrappi_types.TEnum $str:name$ >> ]
 141   | [ "file" -> <:expr< Wrappi_types.TFile >> ]
 142   | [ "hash"; "("; t = ptype; ")" -> <:expr< Wrappi_types.THash $t$ >> ]
 143   | [ "int" -> <:expr< Wrappi_types.TInt >> ]
 144   | [ "int32" -> <:expr< Wrappi_types.TInt32 >> ]
 145   | [ "int64" -> <:expr< Wrappi_types.TInt64 >> ]
 146   | [ "list"; "("; t = ptype; ")" -> <:expr< Wrappi_types.TList $t$ >> ]
 147   | [ "nullable"; "("; t = ptype; ")" -> <:expr< Wrappi_types.TNullable $t$ >> ]
 148   | [ "string" -> <:expr< Wrappi_types.TString >> ]
 149   | [ "struct"; name = LIDENT -> <:expr< Wrappi_types.TStruct $str:name$ >> ]
 150   | [ "uint32" -> <:expr< Wrappi_types.TUInt32 >> ]
 151   | [ "uint64" -> <:expr< Wrappi_types.TUInt64 >> ]
 152   | [ "union"; name = LIDENT -> <:expr< Wrappi_types.TUnion $str:name$ >> ]
 153   | [ name = LIDENT -> <:expr< Wrappi_types.TTypedef $str:name$ >> ]
 154   ];
 155
 156   (* A return type. *)
 157   rtype: [
 158     [ "void" -> <:expr< Wrappi_types.RVoid >> ]
 159   | [ "static_string" -> <:expr< Wrappi_types.RStaticString >> ]
 160   | [ t = ptype -> <:expr< Wrappi_types.Return $t$ >> ]
 161   ];
 162
 163   (* A single function parameter.  XXX Preconditions. *)
 164   parameter: [[ t = ptype; name = LIDENT -> (name, t) ]];
 165
 166   (* A single struct field.  XXX Preconditions. *)
 167   struct_field: [[ t = ptype; name = LIDENT -> (name, t) ]];
 168
 169   str_item: LEVEL "top" [
 170     [ "entry_point";
 171       local = OPT "local";
 172       rtype = rtype; name = LIDENT;
 173       "("; parameters = LIST0 parameter SEP ","; ")";
 174       code = OPT [ code = expr -> code ];
 175       includes = OPT [ "includes"; includes = expr -> includes ]
 176       ->
 177       add_entry_point _loc local name parameters rtype code includes
 178     ]
 179
 180   | [ "enum"; name = LIDENT; identifiers = expr ->
 181       add_enum _loc name identifiers
 182     ]
 183
 184   | [ "struct"; name = LIDENT; "{";
 185       fields = LIST0 struct_field SEP ";";
 186       "}" ->
 187       add_struct _loc name fields
 188     ]
 189
 190   | [ "typedef"; t = ptype; name = LIDENT ->
 191       add_typedef _loc name t
 192     ]
 193   ];
 194
 195 END