2 * Copyright (C) 2011 Red Hat Inc.
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.
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.
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.
19 (* For general information about camlp4, see:
20 * http://brion.inria.fr/gallium/index.php/Camlp4
22 * For information about quotations, see:
23 * http://brion.inria.fr/gallium/index.php/Quotation
32 (* Convert a plain list into a list AST. *)
33 let rec expr_of_list _loc = function
35 | h::t -> let t = expr_of_list _loc t in <:expr< $h$ :: $t$ >>
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$ >>
42 (* Convert a _loc to an AST. *)
43 let expr_of_loc _loc loc =
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
50 $`int:start_line$, $`int:start_bol$, $`int:start_off$,
51 $`int:stop_line$, $`int:stop_bol$, $`int:stop_off$,
54 let add_entry_point _loc local name parameters rtype code includes =
55 let loc = expr_of_loc _loc _loc in
58 match local with None -> <:expr< false >> | _ -> <:expr< true >> in
60 let parameters = List.map (
61 fun (name, t) -> <:expr< ($str:name$, $t$, None) >>
63 let parameters = expr_of_list _loc parameters in
65 let code = expr_of_option _loc code in
67 let includes = match includes with None -> <:expr< [] >> | Some xs -> xs in
70 let ep = { Wrappi_types.ep_loc = $loc$;
73 ep_ftype = ($rtype$, $parameters$, []);
75 ep_includes = $includes$ } in
76 Wrappi_accumulator.add_entry_point ep
79 let add_typedef _loc name t =
80 let loc = expr_of_loc _loc _loc in
83 let td = { Wrappi_types.td_loc = $loc$;
86 Wrappi_accumulator.add_typedef td
89 let add_enum _loc name identifiers =
90 let loc = expr_of_loc _loc _loc in
93 let en = { Wrappi_types.en_loc = $loc$;
95 en_identifiers = Array.of_list $identifiers$ } in
96 Wrappi_accumulator.add_enum en
100 (* Quotation expander for C code. *)
101 let c_quotation_expander _loc _ code =
102 let loc = expr_of_loc _loc _loc in
104 (* XXX Expand %- or $- expressions in code. *)
105 (* XXX Escape >> in code. *)
107 <:expr< { Wrappi_types.cc_loc = $loc$;
108 cc_code = $str:code$ } >>
110 Quotation.add "c" Quotation.DynAst.expr_tag c_quotation_expander;
112 (* Default quotation expander (<< .. >>) should be C code ("c"). *)
113 Quotation.default := "c"
117 (* Extend the regular OCaml grammar. *)
121 (* A parameter or return type. *)
123 [ "bool" -> <:expr< Wrappi_types.TBool >> ]
124 | [ "buffer" -> <:expr< Wrappi_types.TBuffer >> ]
125 | [ "enum"; name = LIDENT -> <:expr< Wrappi_types.TEnum $str:name$ >> ]
126 | [ "file" -> <:expr< Wrappi_types.TFile >> ]
127 | [ "hash"; "("; t = ptype; ")" -> <:expr< Wrappi_types.THash $t$ >> ]
128 | [ "int" -> <:expr< Wrappi_types.TInt >> ]
129 | [ "int32" -> <:expr< Wrappi_types.TInt32 >> ]
130 | [ "int64" -> <:expr< Wrappi_types.TInt64 >> ]
131 | [ "list"; "("; t = ptype; ")" -> <:expr< Wrappi_types.TList $t$ >> ]
132 | [ "nullable"; "("; t = ptype; ")" -> <:expr< Wrappi_types.TNullable $t$ >> ]
133 | [ "string" -> <:expr< Wrappi_types.TString >> ]
134 | [ "struct"; name = LIDENT -> <:expr< Wrappi_types.TStruct $str:name$ >> ]
135 | [ "uint32" -> <:expr< Wrappi_types.TUInt32 >> ]
136 | [ "uint64" -> <:expr< Wrappi_types.TUInt64 >> ]
137 | [ "union"; name = LIDENT -> <:expr< Wrappi_types.TUnion $str:name$ >> ]
138 | [ name = LIDENT -> <:expr< Wrappi_types.TTypedef $str:name$ >> ]
143 [ "void" -> <:expr< Wrappi_types.RVoid >> ]
144 | [ "static_string" -> <:expr< Wrappi_types.RStaticString >> ]
145 | [ t = ptype -> <:expr< Wrappi_types.Return $t$ >> ]
148 (* A single function parameter. XXX Preconditions. *)
149 parameter: [[ t = ptype; name = LIDENT -> (name, t) ]];
151 str_item: LEVEL "top" [
154 rtype = rtype; name = LIDENT;
155 "("; parameters = LIST0 parameter SEP ","; ")";
156 code = OPT [ code = expr -> code ];
157 includes = OPT [ "includes"; includes = expr -> includes ]
159 add_entry_point _loc local name parameters rtype code includes
162 | [ "enum"; name = LIDENT; identifiers = expr ->
163 add_enum _loc name identifiers
166 | [ "typedef"; t = ptype; name = LIDENT ->
167 add_typedef _loc name t