Add poc files
This commit is contained in:
Joey Yakimowich-Payne
parent
30da2412e3
commit
fa600b98f7
220 changed files with 45679 additions and 0 deletions
772
lang_c/parsing/ast_c_simple_build.ml
Normal file
772
lang_c/parsing/ast_c_simple_build.ml
Normal file
|
|
@ -0,0 +1,772 @@
|
|||
(* Yoann Padioleau
|
||||
*
|
||||
* Copyright (C) 2012, 2014 Facebook
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
* version 2.1 as published by the Free Software Foundation, with the
|
||||
* special exception on linking described in file license.txt.
|
||||
*
|
||||
* This library 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 Common
|
||||
|
||||
open Ast_cpp
|
||||
module A = Ast_c
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Prelude *)
|
||||
(*****************************************************************************)
|
||||
(*
|
||||
* Ast_cpp to Ast_c_simple.
|
||||
*
|
||||
* We skip the then part of ifdefs.
|
||||
*
|
||||
* todo:
|
||||
* - lift up local union and struct defined in functions?
|
||||
* (hmm but better to rewrite the code I think)
|
||||
*)
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Globals *)
|
||||
(*****************************************************************************)
|
||||
(* for anon struct, which is dangerous! because the main function
|
||||
* will return different results given the same input when called
|
||||
* two times in a row
|
||||
*)
|
||||
let cnt = ref 0
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Types *)
|
||||
(*****************************************************************************)
|
||||
|
||||
exception ObsoleteConstruct of string * Parse_info.info
|
||||
exception CplusplusConstruct
|
||||
exception TodoConstruct of string * Parse_info.info
|
||||
exception CaseOutsideSwitch
|
||||
exception MacroInCase
|
||||
|
||||
type env = {
|
||||
mutable struct_defs_toadd: A.struct_def list;
|
||||
mutable enum_defs_toadd: A.enum_def list;
|
||||
mutable typedefs_toadd: A.type_def list;
|
||||
}
|
||||
|
||||
let empty_env () = {
|
||||
struct_defs_toadd = [];
|
||||
enum_defs_toadd = [];
|
||||
typedefs_toadd = [];
|
||||
}
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Helpers *)
|
||||
(*****************************************************************************)
|
||||
|
||||
let debug any =
|
||||
let v = Meta_ast_cpp.vof_any any in
|
||||
let s = Ocaml.string_of_v v in
|
||||
pr2 s
|
||||
|
||||
let rec ifdef_skipper xs f =
|
||||
|
||||
match xs with
|
||||
| [] -> []
|
||||
| x::xs ->
|
||||
(match f x with
|
||||
| None -> x::ifdef_skipper xs f
|
||||
| Some ifdef ->
|
||||
(match ifdef with
|
||||
| Ifdef, tok ->
|
||||
pr2_once (spf "skipping: %s" (Parse_info.str_of_info tok));
|
||||
(try
|
||||
let (_, x, rest) =
|
||||
xs +> Common2.split_when (fun x ->
|
||||
match f x with
|
||||
| Some (IfdefElse, _) -> true
|
||||
| Some (IfdefEndif, _) -> true
|
||||
| _ -> false
|
||||
)
|
||||
in
|
||||
(match f x with
|
||||
| Some (IfdefEndif, _) ->
|
||||
ifdef_skipper rest f
|
||||
| Some (IfdefElse, _) ->
|
||||
let (before, _x, rest) =
|
||||
rest +> Common2.split_when (fun x ->
|
||||
match f x with
|
||||
| Some (IfdefEndif, _) -> true
|
||||
| _ -> false
|
||||
)
|
||||
in
|
||||
ifdef_skipper before f @ ifdef_skipper rest f
|
||||
| _ -> raise Impossible
|
||||
)
|
||||
with Not_found ->
|
||||
failwith (spf "%s: unclosed ifdef" (Parse_info.string_of_info tok))
|
||||
)
|
||||
| _, tok ->
|
||||
failwith (spf "%s: no ifdef" (Parse_info.string_of_info tok))
|
||||
)
|
||||
)
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Main entry point *)
|
||||
(*****************************************************************************)
|
||||
|
||||
let rec program xs =
|
||||
let env = empty_env () in
|
||||
toplevels env xs +> List.flatten
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* Toplevels *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
|
||||
and toplevels env xs =
|
||||
ifdef_skipper xs (function IfdefDecl x -> Some x | _ -> None)
|
||||
+> List.map (toplevel env)
|
||||
|
||||
and toplevel env x =
|
||||
match x with
|
||||
| DeclElem decl -> declaration env decl
|
||||
| CppDirectiveDecl x -> cpp_directive env x
|
||||
|
||||
| (MacroVarTop (_, _)|MacroTop (_, _, _)) ->
|
||||
debug (Toplevel x); raise Todo
|
||||
|
||||
| IfdefDecl _ -> raise Impossible (* see ifdef_skipper *)
|
||||
(* not much we can do here, at least the parsing statistics should warn the
|
||||
* user that some code was not processed
|
||||
*)
|
||||
| NotParsedCorrectly _ -> []
|
||||
|
||||
|
||||
and declaration env x =
|
||||
match x with
|
||||
| Func (func_or_else) ->
|
||||
(match func_or_else with
|
||||
| FunctionOrMethod def ->
|
||||
[A.FuncDef (func_def env def)]
|
||||
| Constructor _ | Destructor _ ->
|
||||
debug (Toplevel (DeclElem x)); raise CplusplusConstruct
|
||||
)
|
||||
|
||||
| BlockDecl bd ->
|
||||
(match block_declaration env bd with
|
||||
| A.Vars xs ->
|
||||
let structs = env.struct_defs_toadd in
|
||||
let enums = env.enum_defs_toadd in
|
||||
let typedefs = env.typedefs_toadd in
|
||||
env.struct_defs_toadd <- [];
|
||||
env.enum_defs_toadd <- [];
|
||||
env.typedefs_toadd <- [];
|
||||
(structs +> List.map (fun x -> A.StructDef x)) @
|
||||
(enums +> List.map (fun x -> A.EnumDef x)) @
|
||||
(typedefs +> List.map (fun x -> A.TypeDef x)) @
|
||||
(xs +> List.map (fun x ->
|
||||
(* could skip extern declaration? *)
|
||||
match x with
|
||||
| { A.v_type = A.TFunction ft; v_storage = storage; _ } ->
|
||||
A.Prototype { A.
|
||||
f_name = x.A.v_name;
|
||||
f_type = ft;
|
||||
f_static = (storage =*= A.Static);
|
||||
f_body = [];
|
||||
}
|
||||
| _ -> A.Global x
|
||||
))
|
||||
| _ ->
|
||||
debug (Toplevel (DeclElem x)); raise Todo
|
||||
)
|
||||
|
||||
| EmptyDef _ -> []
|
||||
|
||||
| NameSpaceAnon (_, _)|NameSpaceExtend (_, _)|NameSpace (_, _, _)
|
||||
| ExternCList (_, _, _)|ExternC (_, _, _)|TemplateSpecialization (_, _, _)
|
||||
| TemplateDecl _ ->
|
||||
debug (Toplevel (DeclElem x)); raise CplusplusConstruct
|
||||
| DeclTodo ->
|
||||
debug (Toplevel (DeclElem x)); raise Todo
|
||||
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* Functions *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
and func_def env def =
|
||||
{ A.
|
||||
f_name = name env def.f_name;
|
||||
f_type = function_type env def.f_type;
|
||||
f_static =
|
||||
(match def.f_storage with
|
||||
| Sto (Static, _) -> true
|
||||
| _ -> false
|
||||
);
|
||||
f_body = compound env def.f_body;
|
||||
}
|
||||
|
||||
and function_type env x =
|
||||
match x with
|
||||
{ ft_ret = ret;
|
||||
ft_params = params;
|
||||
ft_dots = _dotsTODO;
|
||||
ft_const = const;
|
||||
ft_throw = throw;
|
||||
} ->
|
||||
(match const, throw with
|
||||
| None, None -> ()
|
||||
| _ -> raise CplusplusConstruct
|
||||
);
|
||||
|
||||
(full_type env ret,
|
||||
List.map (parameter env) (params +> unparen +> uncomma)
|
||||
)
|
||||
|
||||
and parameter env x =
|
||||
match x with
|
||||
{ p_name = n;
|
||||
p_type = t;
|
||||
p_register = _regTODO;
|
||||
p_val = v;
|
||||
} ->
|
||||
(match v with
|
||||
| None -> ()
|
||||
| Some _ -> debug (Parameter x); raise CplusplusConstruct
|
||||
);
|
||||
{ A.
|
||||
p_name =
|
||||
(match n with
|
||||
(* probably a prototype where didn't specify the name *)
|
||||
| None -> None
|
||||
| Some (name) -> Some name
|
||||
);
|
||||
p_type = full_type env t;
|
||||
}
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* Variables *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
and onedecl env d =
|
||||
match d with
|
||||
{ v_namei = ni;
|
||||
v_type = ft;
|
||||
v_storage = sto;
|
||||
} ->
|
||||
(match ni, sto with
|
||||
| Some (n, iopt), (NoSto | Sto _) ->
|
||||
let init_opt =
|
||||
match iopt with
|
||||
| None -> None
|
||||
| Some (EqInit (_, ini)) -> Some (initialiser env ini)
|
||||
| Some (ObjInit _) ->
|
||||
debug (OneDecl d);
|
||||
raise CplusplusConstruct
|
||||
in
|
||||
Some { A.
|
||||
v_name = name env n;
|
||||
v_type = full_type env ft;
|
||||
v_storage = storage env sto;
|
||||
v_init = init_opt;
|
||||
}
|
||||
| Some (n, None), (StoTypedef _) ->
|
||||
let def = (name env n, full_type env ft) in
|
||||
env.typedefs_toadd <- def :: env.typedefs_toadd;
|
||||
None
|
||||
| None, NoSto ->
|
||||
(match Ast_cpp.unwrap_typeC ft with
|
||||
(* it's ok to not have any var decl as long as a type
|
||||
* was defined. struct_defs_toadd should not be empty then.
|
||||
*)
|
||||
| StructDef _ | EnumDef _ ->
|
||||
let _ = full_type env ft in
|
||||
None
|
||||
(* forward declaration *)
|
||||
| StructUnionName _ ->
|
||||
None
|
||||
|
||||
| _ -> debug (OneDecl d); raise Todo
|
||||
)
|
||||
| _ -> debug (OneDecl d); raise Todo
|
||||
)
|
||||
|
||||
and initialiser env x =
|
||||
match x with
|
||||
| InitExpr e -> expr env e
|
||||
| InitList xs ->
|
||||
(match xs +> unbrace +> uncomma with
|
||||
| [] -> debug (Init x); raise Impossible
|
||||
| (InitDesignators ([DesignatorField (_, _)], _, _init))::_ ->
|
||||
A.RecordInit (
|
||||
xs +> unbrace +> uncomma +> List.map (function
|
||||
| InitDesignators ([DesignatorField (_, ident)], _, init) ->
|
||||
ident, initialiser env init
|
||||
| _ -> debug (Init x); raise Todo
|
||||
))
|
||||
| _ ->
|
||||
A.ArrayInit ((xs +> unbrace +> uncomma) +> List.map (function
|
||||
(* less: todo? *)
|
||||
| InitIndexOld ((_, idx, _), ini) ->
|
||||
Some (expr env idx), initialiser env ini
|
||||
| InitDesignators([DesignatorIndex((_, idx, _))], _, ini) ->
|
||||
Some (expr env idx), initialiser env ini
|
||||
| x -> None, initialiser env x
|
||||
))
|
||||
)
|
||||
|
||||
(* should be covered by caller *)
|
||||
| InitDesignators _ -> debug (Init x); raise Todo
|
||||
| InitIndexOld _ | InitFieldOld _ -> debug (Init x); raise Todo
|
||||
|
||||
and storage _env x =
|
||||
match x with
|
||||
| NoSto -> A.DefaultStorage
|
||||
| StoTypedef _ -> raise Impossible
|
||||
| Sto (y, _) ->
|
||||
(match y with
|
||||
| Static -> A.Static
|
||||
| Extern -> A.Extern
|
||||
| Auto | Register -> A.DefaultStorage
|
||||
)
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* Cpp *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
|
||||
and cpp_directive env x =
|
||||
match x with
|
||||
| Define (_tok, name, def_kind, def_val) ->
|
||||
let v = cpp_def_val x env def_val in
|
||||
(match def_kind with
|
||||
| DefineVar ->
|
||||
[A.Define (name, v)]
|
||||
| DefineFunc(args) ->
|
||||
[A.Macro(name,
|
||||
args +> unparen +> uncomma +> List.map (fun (s, ii) ->
|
||||
(s, List.hd ii)
|
||||
),
|
||||
v)]
|
||||
)
|
||||
| Include (tok, inc_kind, path) ->
|
||||
let s =
|
||||
match inc_kind with
|
||||
| Local -> "\"" ^ path ^ "\""
|
||||
| Standard -> "<" ^ path ^ ">"
|
||||
| Weird -> debug (Cpp x); raise Todo
|
||||
in
|
||||
[A.Include (s, tok)]
|
||||
| Undef _ -> debug (Cpp x); raise Todo
|
||||
| PragmaAndCo _ -> []
|
||||
|
||||
and cpp_def_val for_debug env x =
|
||||
match x with
|
||||
| DefineExpr e -> A.CppExpr (expr env e)
|
||||
| DefineStmt st -> A.CppStmt (stmt env st)
|
||||
| DefineDoWhileZero (st, _) -> A.CppStmt (stmt env st)
|
||||
| DefinePrintWrapper (_, (_, e, _), id) ->
|
||||
A.CppExpr (
|
||||
A.CondExpr (expr env e,
|
||||
A.Id (name env id),
|
||||
A.Id (name env id)))
|
||||
|
||||
| DefineInit init -> A.CppExpr (initialiser env init)
|
||||
|
||||
| DefineEmpty (* A.CppEmpty*)
|
||||
| ( DefineText _| DefineFunction _
|
||||
| DefineType _
|
||||
| DefineTodo
|
||||
) ->
|
||||
debug (Cpp for_debug); raise Todo
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* Stmt *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
|
||||
and stmt env x =
|
||||
let (st, ii) = x in
|
||||
match st with
|
||||
| Compound x -> A.Block (compound env x)
|
||||
| Selection s ->
|
||||
(match s with
|
||||
| If (_, (_, e, _), st1, _, st2) ->
|
||||
A.If (expr env e, stmt env st1, stmt env st2)
|
||||
| Switch (_, (_, e, _), st) ->
|
||||
A.Switch (expr env e, cases env st)
|
||||
)
|
||||
| Iteration i ->
|
||||
(match i with
|
||||
| While (_, (_, e, _), st) ->
|
||||
A.While (expr env e, stmt env st)
|
||||
| DoWhile (_, st, _, (_, e, _), _) ->
|
||||
A.DoWhile (stmt env st, expr env e)
|
||||
| For (_, (_, ((est1, _), (est2, _), (est3, _)), _), st) ->
|
||||
A.For (
|
||||
Common2.fmap (expr env) est1,
|
||||
Common2.fmap (expr env) est2,
|
||||
Common2.fmap (expr env) est3,
|
||||
stmt env st
|
||||
)
|
||||
|
||||
| MacroIteration _ ->
|
||||
debug (Stmt x); raise Todo
|
||||
)
|
||||
| ExprStatement eopt ->
|
||||
(match eopt with
|
||||
| None -> A.Block []
|
||||
| Some e -> A.ExprSt (expr env e)
|
||||
)
|
||||
| DeclStmt block_decl ->
|
||||
block_declaration env block_decl
|
||||
|
||||
| Labeled lbl ->
|
||||
(match lbl with
|
||||
| Label (s, st) ->
|
||||
A.Label ((s, List.hd ii), stmt env st)
|
||||
| Case _ | CaseRange _ | Default _ ->
|
||||
debug (Stmt x); raise CaseOutsideSwitch
|
||||
)
|
||||
| Jump j ->
|
||||
(match j with
|
||||
| Goto s -> A.Goto ((s, List.hd ii))
|
||||
| Return -> A.Return None;
|
||||
| ReturnExpr e -> A.Return (Some (expr env e))
|
||||
| Continue -> A.Continue
|
||||
| Break -> A.Break
|
||||
| GotoComputed _ -> debug (Stmt x); raise Todo
|
||||
)
|
||||
|
||||
| Try (_, _, _) ->
|
||||
debug (Stmt x); raise CplusplusConstruct
|
||||
|
||||
| (NestedFunc _ | StmtTodo | MacroStmt ) ->
|
||||
debug (Stmt x); raise Todo
|
||||
|
||||
and compound env (_, xs, _) =
|
||||
statements_sequencable env xs +> List.flatten
|
||||
|
||||
and statements_sequencable env xs =
|
||||
ifdef_skipper xs (function IfdefStmt x -> Some x | _ -> None)
|
||||
+> List.map (statement_sequencable env)
|
||||
|
||||
|
||||
and statement_sequencable env x =
|
||||
match x with
|
||||
| StmtElem st -> [stmt env st]
|
||||
| CppDirectiveStmt x -> debug (Cpp x); raise Todo
|
||||
| IfdefStmt _ -> raise Impossible
|
||||
|
||||
and cases env x =
|
||||
let (st, ii) = x in
|
||||
match st with
|
||||
| Compound (l, xs, r) ->
|
||||
let rec aux xs =
|
||||
match xs with
|
||||
| [] -> []
|
||||
| x::xs ->
|
||||
(match x with
|
||||
| StmtElem ((Labeled (Case (_, st))), _)
|
||||
| StmtElem ((Labeled (Default st)), _)
|
||||
->
|
||||
let xs', rest =
|
||||
(StmtElem st::xs) +> Common.span (function
|
||||
| StmtElem ((Labeled (Case (_, _st))), _)
|
||||
| StmtElem ((Labeled (Default _st)), _) -> false
|
||||
| _ -> true
|
||||
)
|
||||
in
|
||||
let stmts = List.map (function
|
||||
| StmtElem st -> stmt env st
|
||||
| x ->
|
||||
debug (Stmt (Compound (l, [x], r), ii));
|
||||
raise MacroInCase
|
||||
) xs' in
|
||||
(match x with
|
||||
| StmtElem ((Labeled (Case (e, _))), _) ->
|
||||
A.Case (expr env e, stmts)
|
||||
| StmtElem ((Labeled (Default _st)), _) ->
|
||||
A.Default (stmts)
|
||||
| _ -> raise Impossible
|
||||
)::aux rest
|
||||
| x -> debug (Body (l, [x], r)); raise Todo
|
||||
)
|
||||
in
|
||||
aux xs
|
||||
| _ ->
|
||||
debug (Stmt x); raise Todo
|
||||
|
||||
and block_declaration env block_decl =
|
||||
match block_decl with
|
||||
| DeclList (xs, _) ->
|
||||
let xs = uncomma xs in
|
||||
A.Vars (Common.map_filter (onedecl env) xs)
|
||||
|
||||
(* todo *)
|
||||
| Asm (_tok1, _volatile_opt, _asmbody, _tok2) ->
|
||||
A.Asm []
|
||||
|
||||
| MacroDecl _ -> debug (BlockDecl2 block_decl); raise Todo
|
||||
|
||||
| UsingDecl _ | UsingDirective _ | NameSpaceAlias _ ->
|
||||
raise CplusplusConstruct
|
||||
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* Expr *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
|
||||
and expr env e =
|
||||
let (e', toks) = e in
|
||||
match e' with
|
||||
| C cst -> constant env toks cst
|
||||
|
||||
| Id (n, _) -> A.Id (name env n)
|
||||
|
||||
| RecordAccess (e, n) ->
|
||||
A.RecordPtAccess (A.Unary (expr env e, (GetRef,List.hd toks)), name env n)
|
||||
| RecordPtAccess (e, n) ->
|
||||
A.RecordPtAccess (expr env e, name env n)
|
||||
|
||||
| Cast ((_, ft, _), e) ->
|
||||
A.Cast (full_type env ft, expr env e)
|
||||
|
||||
| ArrayAccess (e1, (_, e2, _)) ->
|
||||
A.ArrayAccess (expr env e1, expr env e2)
|
||||
| Binary (e1, op, e2) -> A.Binary (expr env e1, (op, List.hd toks), expr env e2)
|
||||
| Unary (e, op) -> A.Unary (expr env e, (op, List.hd toks))
|
||||
| Infix (e, op) -> A.Infix (expr env e, (op, List.hd toks))
|
||||
| Postfix (e, op) -> A.Postfix (expr env e, (op, List.hd toks))
|
||||
|
||||
| Assignment (e1, op, e2) ->
|
||||
A.Assign ((op, List.hd toks), expr env e1, expr env e2)
|
||||
| Sequence (e1, e2) ->
|
||||
A.Sequence (expr env e1, expr env e2)
|
||||
| CondExpr (e1, e2opt, e3) ->
|
||||
A.CondExpr (expr env e1,
|
||||
(match e2opt with
|
||||
| Some e2 -> expr env e2
|
||||
| None ->
|
||||
debug (Expr e); raise Todo
|
||||
),
|
||||
expr env e3)
|
||||
| Call (e, args) ->
|
||||
A.Call (expr env e,
|
||||
Common.map_filter (argument env) (args +> unparen +> uncomma))
|
||||
|
||||
| SizeOfExpr (_tok, e) ->
|
||||
A.SizeOf(Left (expr env e))
|
||||
| SizeOfType (_tok, (_, ft, _)) ->
|
||||
A.SizeOf(Right (full_type env ft))
|
||||
| GccConstructor ((_, ft, _), xs) ->
|
||||
A.GccConstructor (full_type env ft,
|
||||
initialiser env (InitList xs))
|
||||
|
||||
| ConstructedObject (_, _) ->
|
||||
pr2_once "BUG PARSING LOCAL DECL PROBABLY";
|
||||
debug (Expr e);
|
||||
raise CplusplusConstruct
|
||||
|
||||
| StatementExpr _
|
||||
| ExprTodo
|
||||
->
|
||||
debug (Expr e); raise Todo
|
||||
| Throw _|DeleteArray (_, _)|Delete (_, _)|New (_, _, _, _, _)
|
||||
| CplusplusCast (_, _, _)
|
||||
| This _
|
||||
| RecordPtStarAccess (_, _)|RecordStarAccess (_, _)
|
||||
| TypeId (_, _)
|
||||
->
|
||||
debug (Expr e); raise CplusplusConstruct
|
||||
|
||||
| ParenExpr (_, e, _) -> expr env e
|
||||
|
||||
and constant _env toks x =
|
||||
match x with
|
||||
| Int s -> A.Int (s, List.hd toks)
|
||||
| Float (s, _) -> A.Float (s, List.hd toks)
|
||||
| Char (s, _) -> A.Char (s, List.hd toks)
|
||||
| String (s, _) -> A.String (s, List.hd toks)
|
||||
|
||||
| Bool _ -> raise CplusplusConstruct
|
||||
| MultiString -> A.String ("TODO", List.hd toks)
|
||||
|
||||
and argument env x =
|
||||
match x with
|
||||
| Left e -> Some (expr env e)
|
||||
(* TODO! can't just skip it ... *)
|
||||
| Right _w ->
|
||||
pr2 ("type argument, maybe wrong typedef inference!");
|
||||
debug (Argument x);
|
||||
None
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* Type *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
and full_type env x =
|
||||
let (_qu, (t, ii)) = x in
|
||||
match t with
|
||||
| Pointer t -> A.TPointer (full_type env t)
|
||||
| BaseType t ->
|
||||
let s =
|
||||
(match t with
|
||||
| Void -> "void"
|
||||
| FloatType ft ->
|
||||
(match ft with
|
||||
| CFloat -> "float"
|
||||
| CDouble -> "double"
|
||||
| CLongDouble -> "long_double"
|
||||
)
|
||||
| IntType it ->
|
||||
(match it with
|
||||
| CChar -> "char"
|
||||
| Si (si, base) ->
|
||||
(match si with
|
||||
| Signed -> ""
|
||||
| UnSigned -> "unsigned_"
|
||||
) ^
|
||||
(match base with
|
||||
(* 'char' is a CChar and 'unsigned char' is a Si (_, CChar2) *)
|
||||
| CChar2 -> "char"
|
||||
| CShort -> "short"
|
||||
| CInt -> "int"
|
||||
| CLong -> "long"
|
||||
(* gccext: *)
|
||||
| CLongLong -> "long_long"
|
||||
)
|
||||
| CBool | WChar_t ->
|
||||
debug (Type x); raise CplusplusConstruct
|
||||
)
|
||||
)
|
||||
in
|
||||
A.TBase (s, List.hd ii)
|
||||
|
||||
| FunctionType ft -> A.TFunction (function_type env ft)
|
||||
| Array ((_, eopt, _), ft) ->
|
||||
A.TArray (Common.map_opt (expr env) eopt, full_type env ft)
|
||||
| TypeName (n) -> A.TTypeName (name env n)
|
||||
|
||||
| StructUnionName ((kind, _), name) ->
|
||||
A.TStructName (struct_kind env kind, name)
|
||||
| StructDef def ->
|
||||
(match def with
|
||||
{ c_kind = (kind, tok);
|
||||
c_name = name_opt;
|
||||
c_inherit = _inh;
|
||||
c_members = (_, xs, _);
|
||||
} ->
|
||||
let name =
|
||||
match name_opt with
|
||||
| None ->
|
||||
incr cnt;
|
||||
let s = spf "__anon_struct_%d" !cnt in
|
||||
(s, tok)
|
||||
| Some n -> name env n
|
||||
in
|
||||
let def' = { A.
|
||||
s_name = name;
|
||||
s_kind = struct_kind env kind;
|
||||
s_flds = class_members_sequencable env xs +> List.flatten;
|
||||
}
|
||||
in
|
||||
env.struct_defs_toadd <- def' :: env.struct_defs_toadd;
|
||||
A.TStructName (struct_kind env kind, name)
|
||||
)
|
||||
|
||||
| EnumName (_tok, name) -> A.TEnumName (name)
|
||||
| EnumDef (tok, name_opt, xs) ->
|
||||
let name =
|
||||
match name_opt with
|
||||
| None ->
|
||||
incr cnt;
|
||||
let s = spf "__anon_enum_%d" !cnt in
|
||||
(s, tok)
|
||||
| Some n -> n
|
||||
in
|
||||
let xs' =
|
||||
xs +> unbrace +> uncomma +> List.map (fun eelem ->
|
||||
let (name, e_opt) = eelem.e_name, eelem.e_val in
|
||||
name,
|
||||
match e_opt with
|
||||
| None -> None
|
||||
| Some (_tok, e) -> Some (expr env e)
|
||||
)
|
||||
in
|
||||
let def = name, xs' in
|
||||
env.enum_defs_toadd <- def :: env.enum_defs_toadd;
|
||||
A.TEnumName (name)
|
||||
|
||||
| TypeOf (_, _) ->
|
||||
debug (Type x); raise Todo
|
||||
| TypenameKwd (_, _) | Reference _ ->
|
||||
debug (Type x); raise CplusplusConstruct
|
||||
|
||||
| ParenType (_, t, _) -> full_type env t
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* structure *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
and class_member env x =
|
||||
match x with
|
||||
| MemberField (fldkind, _) ->
|
||||
let xs = uncomma fldkind in
|
||||
xs +> List.map (fieldkind env)
|
||||
| ( UsingDeclInClass _| TemplateDeclInClass _
|
||||
| QualifiedIdInClass (_, _)| MemberDecl _| MemberFunc _| Access (_, _)
|
||||
) ->
|
||||
debug (ClassMember x); raise Todo
|
||||
| EmptyField _ -> []
|
||||
|
||||
|
||||
and class_members_sequencable env xs =
|
||||
ifdef_skipper xs (function IfdefStruct x -> Some x | _ -> None)
|
||||
+> List.map (class_member_sequencable env)
|
||||
|
||||
and class_member_sequencable env x =
|
||||
match x with
|
||||
| ClassElem x -> class_member env x
|
||||
| CppDirectiveStruct dir ->
|
||||
debug (Cpp dir); raise Todo
|
||||
| IfdefStruct _ -> raise Impossible
|
||||
|
||||
and fieldkind env x =
|
||||
match x with
|
||||
| FieldDecl decl ->
|
||||
(match decl with
|
||||
{ v_namei = ni;
|
||||
v_type = ft;
|
||||
v_storage = sto;
|
||||
} ->
|
||||
(match ni, sto with
|
||||
| Some (n, None), NoSto ->
|
||||
{ A.
|
||||
fld_name = Some (name env n);
|
||||
fld_type = full_type env ft;
|
||||
}
|
||||
| None, NoSto ->
|
||||
{ A.
|
||||
fld_name = None;
|
||||
fld_type = full_type env ft;
|
||||
}
|
||||
|
||||
| _ -> debug (OneDecl decl); raise Todo
|
||||
)
|
||||
)
|
||||
| BitField (name_opt, _tok, ft, e) ->
|
||||
let _ = expr env e in
|
||||
{ A.
|
||||
fld_name = name_opt;
|
||||
fld_type = full_type env ft;
|
||||
}
|
||||
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
(* Misc *)
|
||||
(* ---------------------------------------------------------------------- *)
|
||||
|
||||
and name _env x =
|
||||
match x with
|
||||
| (None, [], IdIdent (name)) -> name
|
||||
| _ -> debug (Name x); raise CplusplusConstruct
|
||||
|
||||
and struct_kind _env = function
|
||||
| Struct -> A.Struct
|
||||
| Union -> A.Union
|
||||
| Class -> raise CplusplusConstruct
|
||||
Loading…
Add table
Add a link
Reference in a new issue