227 lines
7.3 KiB
OCaml
227 lines
7.3 KiB
OCaml
(* Yoann Padioleau
|
|
*
|
|
* Copyright (C) 2014 Facebook
|
|
*
|
|
* This program is free software; you can redistribute it and/or
|
|
* modify it under the terms of the GNU General Public License (GPL)
|
|
* version 2 as published by the Free Software Foundation.
|
|
*
|
|
* This program is distributed in the hope that it will be useful,
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
* file license.txt for more details.
|
|
*)
|
|
|
|
open Ocaml
|
|
open Ast_c
|
|
|
|
(*****************************************************************************)
|
|
(* Prelude *)
|
|
(*****************************************************************************)
|
|
|
|
(*****************************************************************************)
|
|
(* Types *)
|
|
(*****************************************************************************)
|
|
|
|
(* hooks *)
|
|
type visitor_in = {
|
|
kexpr: Ast_c.expr vin;
|
|
kinfo: Ast_cpp.tok vin;
|
|
}
|
|
and visitor_out = any -> unit
|
|
and 'a vin = ('a -> unit) * visitor_out -> 'a -> unit
|
|
|
|
module Ast_cpp = struct
|
|
let v_assignOp _ = ()
|
|
let v_fixOp _ = ()
|
|
let v_unaryOp _ = ()
|
|
let v_binaryOp _ = ()
|
|
end
|
|
|
|
let default_visitor = {
|
|
kinfo = (fun (k,_) x -> k x);
|
|
kexpr = (fun (k,_) x -> k x);
|
|
}
|
|
|
|
let (mk_visitor: visitor_in -> visitor_out) = fun vin ->
|
|
|
|
let rec v_info x =
|
|
let k _ = () in
|
|
vin.kinfo (k, all_functions) x
|
|
|
|
and v_wrap:'a. ('a -> unit) -> 'a wrap -> unit =
|
|
fun _of_a (v1, v2) ->
|
|
let v1 = _of_a v1 and v2 = v_info v2 in ()
|
|
|
|
and v_name v = v_wrap v_string v
|
|
|
|
and v_type_ =
|
|
function
|
|
| TBase v1 -> let v1 = v_name v1 in ()
|
|
| TPointer v1 -> let v1 = v_type_ v1 in ()
|
|
| TArray ((v1, v2)) ->
|
|
let v1 = v_option v_const_expr v1 and v2 = v_type_ v2 in ()
|
|
| TFunction v1 -> let v1 = v_function_type v1 in ()
|
|
| TStructName ((v1, v2)) ->
|
|
let v1 = v_struct_kind v1 and v2 = v_name v2 in ()
|
|
| TEnumName v1 -> let v1 = v_name v1 in ()
|
|
| TTypeName v1 -> let v1 = v_name v1 in ()
|
|
|
|
and v_function_type (v1, v2) =
|
|
let v1 = v_type_ v1 and v2 = v_list v_parameter v2 in ()
|
|
and v_parameter { p_type = v_p_type; p_name = v_p_name } =
|
|
let arg = v_type_ v_p_type in let arg = v_option v_name v_p_name in ()
|
|
and v_struct_kind = function | Struct -> () | Union -> ()
|
|
and v_const_expr v = v_expr v
|
|
and v_expr x =
|
|
let k x = match x with
|
|
| Int v1 -> let v1 = v_wrap v_string v1 in ()
|
|
| Float v1 -> let v1 = v_wrap v_string v1 in ()
|
|
| String v1 -> let v1 = v_wrap v_string v1 in ()
|
|
| Char v1 -> let v1 = v_wrap v_string v1 in ()
|
|
| Id v1 -> let v1 = v_name v1 in ()
|
|
| Call ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_list v_argument v2 in ()
|
|
| Assign ((v1, v2, v3)) ->
|
|
let v1 = v_wrap Ast_cpp.v_assignOp v1
|
|
and v2 = v_expr v2
|
|
and v3 = v_expr v3
|
|
in ()
|
|
| ArrayAccess ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_expr v2 in ()
|
|
| RecordPtAccess ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_name v2 in ()
|
|
| Cast ((v1, v2)) -> let v1 = v_type_ v1 and v2 = v_expr v2 in ()
|
|
| Postfix ((v1, v2)) ->
|
|
let v1 = v_expr v1 and v2 = v_wrap Ast_cpp.v_fixOp v2 in ()
|
|
| Infix ((v1, v2)) ->
|
|
let v1 = v_expr v1 and v2 = v_wrap Ast_cpp.v_fixOp v2 in ()
|
|
| Unary ((v1, v2)) ->
|
|
let v1 = v_expr v1 and v2 = v_wrap Ast_cpp.v_unaryOp v2 in ()
|
|
| Binary ((v1, v2, v3)) ->
|
|
let v1 = v_expr v1
|
|
and v2 = v_wrap Ast_cpp.v_binaryOp v2
|
|
and v3 = v_expr v3
|
|
in ()
|
|
| CondExpr ((v1, v2, v3)) ->
|
|
let v1 = v_expr v1 and v2 = v_expr v2 and v3 = v_expr v3 in ()
|
|
| Sequence ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_expr v2 in ()
|
|
| SizeOf v1 -> let v1 = Ocaml.v_either v_expr v_type_ v1 in ()
|
|
| ArrayInit v1 ->
|
|
let v1 =
|
|
v_list
|
|
(fun (v1, v2) ->
|
|
let v1 = v_option v_expr v1 and v2 = v_expr v2 in ())
|
|
v1
|
|
in ()
|
|
| RecordInit v1 ->
|
|
let v1 =
|
|
v_list (fun (v1, v2) -> let v1 = v_name v1 and v2 = v_expr v2 in ())
|
|
v1
|
|
in ()
|
|
| GccConstructor ((v1, v2)) -> let v1 = v_type_ v1 and v2 = v_expr v2 in ()
|
|
in
|
|
vin.kexpr (k, all_functions) x
|
|
and v_argument v = v_expr v
|
|
|
|
and v_stmt =
|
|
function
|
|
| ExprSt v1 -> let v1 = v_expr v1 in ()
|
|
| Block v1 -> let v1 = v_list v_stmt v1 in ()
|
|
| If ((v1, v2, v3)) ->
|
|
let v1 = v_expr v1 and v2 = v_stmt v2 and v3 = v_stmt v3 in ()
|
|
| Switch ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_list v_case v2 in ()
|
|
| While ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_stmt v2 in ()
|
|
| DoWhile ((v1, v2)) -> let v1 = v_stmt v1 and v2 = v_expr v2 in ()
|
|
| For ((v1, v2, v3, v4)) ->
|
|
let v1 = v_option v_expr v1
|
|
and v2 = v_option v_expr v2
|
|
and v3 = v_option v_expr v3
|
|
and v4 = v_stmt v4
|
|
in ()
|
|
| Return v1 -> let v1 = v_option v_expr v1 in ()
|
|
| Continue -> ()
|
|
| Break -> ()
|
|
| Label ((v1, v2)) -> let v1 = v_name v1 and v2 = v_stmt v2 in ()
|
|
| Goto v1 -> let v1 = v_name v1 in ()
|
|
| Vars v1 -> let v1 = v_list v_var_decl v1 in ()
|
|
| Asm v1 -> let v1 = v_list v_expr v1 in ()
|
|
|
|
and v_case =
|
|
function
|
|
| Case ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_list v_stmt v2 in ()
|
|
| Default v1 -> let v1 = v_list v_stmt v1 in ()
|
|
and
|
|
v_var_decl {
|
|
v_name = v_v_name;
|
|
v_type = v_v_type;
|
|
v_storage = v_v_storage;
|
|
v_init = v_v_init
|
|
} =
|
|
let arg = v_name v_v_name in
|
|
let arg = v_type_ v_v_type in
|
|
let arg = v_storage v_v_storage in
|
|
let arg = v_option v_initialiser v_v_init in ()
|
|
and v_initialiser v = v_expr v
|
|
and v_storage = function | Extern -> () | Static -> () | DefaultStorage -> ()
|
|
|
|
and v_struct_def { s_name = v_s_name; s_kind = v_s_kind; s_flds = v_s_flds } =
|
|
let arg = v_name v_s_name in
|
|
let arg = v_struct_kind v_s_kind in
|
|
let arg = v_list v_field_def v_s_flds in ()
|
|
|
|
and v_field_def { fld_name = v_fld_name; fld_type = v_fld_type } =
|
|
let arg = v_option v_name v_fld_name in let arg = v_type_ v_fld_type in ()
|
|
|
|
and v_func_def {
|
|
f_name = v_f_name;
|
|
f_type = v_f_type;
|
|
f_body = v_f_body;
|
|
f_static = v_f_static
|
|
} =
|
|
let arg = v_name v_f_name in
|
|
let arg = v_function_type v_f_type in
|
|
let arg = v_list v_stmt v_f_body in let arg = v_bool v_f_static in ()
|
|
|
|
and v_define_body =
|
|
function
|
|
| CppExpr v1 -> let v1 = v_expr v1 in ()
|
|
| CppStmt v1 -> let v1 = v_stmt v1 in ()
|
|
|
|
and v_toplevel =
|
|
function
|
|
| Include v1 -> let v1 = v_wrap v_string v1 in ()
|
|
| Define ((v1, v2)) -> let v1 = v_name v1 and v2 = v_define_body v2 in ()
|
|
| Macro ((v1, v2, v3)) ->
|
|
let v1 = v_name v1
|
|
and v2 = v_list v_name v2
|
|
and v3 = v_define_body v3
|
|
in ()
|
|
| StructDef v1 -> let v1 = v_struct_def v1 in ()
|
|
| TypeDef v1 -> let v1 = v_type_def v1 in ()
|
|
| EnumDef v1 -> let v1 = v_enum_def v1 in ()
|
|
| FuncDef v1 -> let v1 = v_func_def v1 in ()
|
|
| Global v1 -> let v1 = v_var_decl v1 in ()
|
|
| Prototype v1 -> let v1 = v_func_def v1 in ()
|
|
|
|
and v_type_def (v1, v2) = let v1 = v_name v1 and v2 = v_type_ v2 in ()
|
|
|
|
and v_enum_def (v1, v2) =
|
|
let v1 = v_name v1
|
|
and v2 =
|
|
v_list
|
|
(fun (v1, v2) -> let v1 = v_name v1 and v2 = v_option v_expr v2 in ())
|
|
v2
|
|
in ()
|
|
|
|
and v_any =
|
|
function
|
|
| Expr v1 -> let v1 = v_expr v1 in ()
|
|
| Stmt v1 -> let v1 = v_stmt v1 in ()
|
|
| Type v1 -> let v1 = v_type_ v1 in ()
|
|
| Toplevel v1 -> let v1 = v_toplevel v1 in ()
|
|
| Program v1 -> let v1 = v_program v1 in ()
|
|
|
|
and v_program v = v_list v_toplevel v
|
|
|
|
and all_functions x = v_any x
|
|
in
|
|
v_any
|
|
|