(* cppext: *)
| Macro of string * (define_kind * define_val)
+let print_scoped_env e =
+ List.iter
+ (function e ->
+ List.iter
+ (function
+ VarOrFunc(s,_) -> Printf.printf "%s " s
+ | EnumConstant(s,_) -> Printf.printf "%s " s
+ | TypeDef(s,t) -> Printf.printf "%s" s
+ | StructUnionNameDef(s,_) -> Printf.printf "%s " s
+ | Macro(s,_) -> Printf.printf "%s " s)
+ e;
+ Printf.printf "\n")
+ e
(* Because have nested scope, have nested list, hence the list list.
*
(*
VarOrFunc("malloc",
- (Lib.al_type(Parse_c.type_of_string "void* (*)(int size)"),
+ (Lib.al_type(Parse_c.type_of_string "void* ( * )(int size)"),
Ast_c.NotLocalVar));
VarOrFunc("free",
- (Lib.al_type(Parse_c.type_of_string "void (*)(void *ptr)"),
+ (Lib.al_type(Parse_c.type_of_string "void ( * )(void *ptr)"),
Ast_c.NotLocalVar));
*)
]
(* ------------------------------------------------------------ *)
let rec type_unfold_one_step ty env =
+ let rec loop seen ty env =
match Ast_c.unwrap_typeC ty with
+ | NoType -> ty
| BaseType x -> ty
| Pointer t -> ty
| Array (e, t) -> ty
(try
if !typedef_debug then pr2 "type_unfold_one_step: lookup_typedef";
let (t', env') = lookup_typedef s env in
- type_unfold_one_step t' env'
+ if List.mem s seen (* avoid pb with recursive typedefs *)
+ then type_unfold_one_step t' env'
+ else loop (s::seen) t' env
with Not_found ->
ty
)
| TypeOfExpr e ->
pr2_once ("Type_annoter: not handling typeof");
ty
- | TypeOfType t -> type_unfold_one_step t env
+ | TypeOfType t -> type_unfold_one_step t env in
+ loop [] ty env
* for most tasks.
*)
let rec typedef_fix ty env =
- match Ast_c.unwrap_typeC ty with
- | BaseType x ->
- ty
- | Pointer t ->
- Pointer (typedef_fix t env) +> Ast_c.rewrap_typeC ty
- | Array (e, t) ->
- Array (e, typedef_fix t env) +> Ast_c.rewrap_typeC ty
- | StructUnion (su, sopt, fields) ->
+ let rec loop seen ty env =
+ match Ast_c.unwrap_typeC ty with
+ | NoType ->
+ ty
+ | BaseType x ->
+ ty
+ | Pointer t ->
+ Pointer (typedef_fix t env) +> Ast_c.rewrap_typeC ty
+ | Array (e, t) ->
+ Array (e, typedef_fix t env) +> Ast_c.rewrap_typeC ty
+ | StructUnion (su, sopt, fields) ->
(* normalize, fold.
- * todo? but what if correspond to a nested struct def ?
- *)
- Type_c.structdef_to_struct_name ty
- | FunctionType ft ->
- (FunctionType ft) (* todo ? *) +> Ast_c.rewrap_typeC ty
- | Enum (s, enumt) ->
- (Enum (s, enumt)) (* todo? *) +> Ast_c.rewrap_typeC ty
- | EnumName s ->
- (EnumName s) (* todo? *) +> Ast_c.rewrap_typeC ty
-
+ * todo? but what if correspond to a nested struct def ?
+ *)
+ Type_c.structdef_to_struct_name ty
+ | FunctionType ft ->
+ (FunctionType ft) (* todo ? *) +> Ast_c.rewrap_typeC ty
+ | Enum (s, enumt) ->
+ (Enum (s, enumt)) (* todo? *) +> Ast_c.rewrap_typeC ty
+ | EnumName s ->
+ (EnumName s) (* todo? *) +> Ast_c.rewrap_typeC ty
+
(* we prefer StructUnionName to StructUnion when it comes to typed metavar *)
- | StructUnionName (su, s) -> ty
-
+ | StructUnionName (su, s) ->
+ ty
+
(* keep the typename but complete with more information *)
- | TypeName (name, typ) ->
- let s = Ast_c.str_of_name name in
- (match typ with
- | Some _ ->
- pr2 ("typedef value already there:" ^ s);
- ty
- | None ->
- (try
- if !typedef_debug then pr2 "typedef_fix: lookup_typedef";
- let (t', env') = lookup_typedef s env in
-
+ | TypeName (name, typ) ->
+ let s = Ast_c.str_of_name name in
+ (match typ with
+ | Some _ ->
+ pr2 ("typedef value already there:" ^ s);
+ ty
+ | None ->
+ (try
+ if !typedef_debug then pr2 "typedef_fix: lookup_typedef";
+ let (t', env') = lookup_typedef s env in
+
(* bugfix: termination bug if use env instead of env' below, because
- * can have some weird mutually recursive typedef which
- * each new type alias search for its mutual def.
- *)
- TypeName (name, Some (typedef_fix t' env')) +> Ast_c.rewrap_typeC ty
- with Not_found ->
- ty
- ))
+ * can have some weird mutually recursive typedef which
+ * each new type alias search for its mutual def.
+ * seen is an attempt to do better.
+ *)
+ let fixed =
+ if List.mem s seen
+ then loop (s::seen) t' env
+ else typedef_fix t' env' in
+ TypeName (name, Some fixed) +>
+ Ast_c.rewrap_typeC ty
+ with Not_found ->
+ ty))
(* remove paren for better matching with typed metavar. kind of iso again *)
- | ParenType t ->
- typedef_fix t env
- | TypeOfExpr e ->
- pr2_once ("Type_annoter: not handling typeof");
- ty
+ | ParenType t ->
+ typedef_fix t env
+ | TypeOfExpr e ->
+ pr2_once ("Type_annoter: not handling typeof");
+ ty
- | TypeOfType t ->
- typedef_fix t env
+ | TypeOfType t ->
+ typedef_fix t env in
+ loop [] ty env
(*****************************************************************************)
let (current, older) = Common.uncons !_scoped_env in
_scoped_env := (namedef::current)::older
-
(* ------------------------------------------------------------ *)
(* sort of hackish... *)
(* -------------------------------------------------- *)
(* todo: should analyse the 's' for int to know if unsigned or not *)
- | Constant (String (s,kind)) -> make_info_def (type_of_s "char *")
- | Constant MultiString _ -> make_info_def (type_of_s "char *")
+ | Constant (String (s,kind)) -> make_info_def (type_of_s "char []")
+ | Constant MultiString _ -> make_info_def (type_of_s "char []")
| Constant (Char (s,kind)) -> make_info_def (type_of_s "char")
| Constant (Int (s,kind)) ->
(* this seems really unpleasant, but perhaps the type needs to be set
| FunCall (e1, args) ->
(match Ast_c.unwrap_expr e1 with
| Ident (ident) ->
-
(* recurse *)
args +> List.iter (fun (e,ii) ->
(* could typecheck if arguments agree with prototype *)
| DefineVar, _ ->
pr2 ("Type_annoter: not a macro-func: " ^ s);
Type_c.noTypeHere
+ | Undef, _ ->
+ pr2 ("Type_annoter: not a macro-func: " ^ s);
+ Type_c.noTypeHere
| DefineFunc _, _ ->
- (* normally the FunCall case should have catch it *)
+ (* normally the FunCall case should have caught it *)
pr2 ("Type_annoter: not a macro-func-expr: " ^ s);
Type_c.noTypeHere
)
| Ident (ident) ->
let s = Ast_c.str_of_name ident in
(match lookup_opt_env lookup_var s with
- | Some ((typ,local),_nextenv) ->
- make_info_fix (typ,local)
+ | Some ((typ,local),_nextenv) -> make_info_fix (typ,local)
| None ->
(match lookup_opt_env lookup_macro s with
| Some ((defkind, defval), _nextenv) ->
(* normally the FunCall case should have catch it *)
pr2 ("Type_annoter: not a macro-var: " ^ s);
Type_c.noTypeHere
+ | Undef, _ ->
+ pr2 ("Type_annoter: not a expression: " ^ s);
+ Type_c.noTypeHere
)
| None ->
(match lookup_opt_env lookup_enum s with
make_info_def_fix ft
)
-
(* -------------------------------------------------- *)
(* fields *)
| RecordAccess (e, namefld)
| RecordPtAccess (e, namefld) as x ->
-
let fld = Ast_c.str_of_name namefld in
k expr; (* recurse to set the types-ref of sub expressions *)
| Pointer (t) -> Some t
| _ -> None
)
- | _ -> raise Impossible
+ | _ -> raise (Impossible 159)
in
(match topt with
(* todo? lub, hmm maybe not, cos type must be e1 *)
| Assignment (e1, op, e2) ->
k expr;
- (* value of an assignment is the value of the RHS expression *)
- Ast_c.get_type_expr e2
+ (* value of an assignment is the value of the RHS expression, but its
+ type is the type of the lhs expression. Use the rhs exp if no
+ information is available *)
+ (match Ast_c.get_type_expr e1 with
+ (None,_) -> Ast_c.get_type_expr e2
+ | (Some ty,t) -> (Some ty,t))
| Sequence (e1, e2) ->
k expr;
Ast_c.get_type_expr e2
| SizeOfType _|SizeOfExpr _ ->
k expr; (* recurse to set the types-ref of sub expressions *)
- make_info_def (type_of_s "int")
+ make_info_def (type_of_s "size_t")
| Constructor (ft, ini) ->
k expr; (* recurse to set the types-ref of sub expressions *)
| Unary (e, Not) ->
k expr; (* recurse to set the types-ref of sub expressions *)
- Ast_c.get_type_expr e
+ (* the result of ! is always 0 or 1, not the argument type *)
+ make_info_def (type_of_s "int")
| Unary (e, Tilde) ->
k expr; (* recurse to set the types-ref of sub expressions *)
Ast_c.get_type_expr e
| _ -> k expr; Type_c.noTypeHere
*)
+ | New ty ->
+ k expr;
+ pr2_once "Type annotater:not handling New";
+ Type_c.noTypeHere (* TODO *)
+
+ | Delete e ->
+ k expr;
+ pr2_once "Type annotater:not handling Delete";
+ Type_c.noTypeHere (* TODO *)
+
in
Ast_c.set_type_expr expr ty
add_binding (Macro (s, (defkind, defval) )) true;
- | Undef _
| PragmaAndCo _ -> ()
);
let local =
- match local with
- | Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
- | Ast_c.LocalDecl -> Ast_c.LocalVar (Ast_c.info_of_type t)
+ match (sto,local) with
+ | (_,Ast_c.NotLocalDecl) -> Ast_c.NotLocalVar
+ | ((Ast_c.Sto Ast_c.Static, _), Ast_c.LocalDecl) ->
+ (match Ast_c.info_of_type t with
+ (* if there is no info about the type it must not be
+ present, so we don't know what the variable is *)
+ None -> Ast_c.NotLocalVar
+ | Some ii -> Ast_c.StaticLocalVar ii)
+ | (_,Ast_c.LocalDecl) ->
+ (match Ast_c.info_of_type t with
+ (* if there is no info about the type it must not be
+ present, so we don't know what the variable is *)
+ None -> Ast_c.NotLocalVar
+ | Some ii -> Ast_c.LocalVar ii)
in
var +> Common.do_option (fun (name, iniopt) ->
let s = Ast_c.str_of_name name in
if need_annotate_body then begin
(* int x = sizeof(x) is legal so need process ini *)
- iniopt +> Common.do_option (fun (info, ini) ->
- Visitor_c.vk_ini bigf ini
- );
+ match iniopt with
+ Ast_c.NoInit -> ()
+ | Ast_c.ValInit(iini,init) -> Visitor_c.vk_ini bigf init
+ | Ast_c.ConstrInit((args,_)) ->
+ args +> List.iter (fun (e,ii) ->
+ Visitor_c.vk_argument bigf e
+ )
end
);
);
- | MacroDecl _ ->
+ | MacroDecl _ | MacroDeclInit _ ->
if need_annotate_body
then k d
);
*)
| iifunc1::iifunc2::ibrace1::ibrace2::ifakestart::isto ->
iifunc1, iifunc2
- | _ -> raise Impossible
+ | _ -> raise (Impossible 160)
in
let funcs = Ast_c.str_of_name name in
match nameopt with
| Some name ->
let s = Ast_c.str_of_name name in
- let local = Ast_c.LocalVar (Ast_c.info_of_type t) in
+ let local =
+ (match Ast_c.info_of_type t with
+ (* if there is no info about the type it must
+ not be present, so we don't know what the
+ variable is *)
+ None -> Ast_c.NotLocalVar
+ | Some ii -> Ast_c.LocalVar ii)
+ in
add_binding (VarOrFunc (s,(Lib.al_type t,local))) true
| None ->
pr2 "no type, certainly because Void type ?"
| Binary(e1,Logical(OrLog),e2) -> propagate_test e1; propagate_test e2
| Unary(e1,Not) -> propagate_test e1
| ParenExpr(e) -> propagate_test e
+ | FunCall(e,args) -> (* not very nice, but so painful otherwise *)
+ (match (unwrap e,args) with
+ ((Ident(i),_),[(Left a,_)]) ->
+ let nm = str_of_name i in
+ if List.mem nm ["likely";"unlikely"]
+ then propagate_test a
+ else ()
+ | _ -> ())
| _ -> () in
let bigf = { Visitor_c.default_visitor_c with
HCoop / bpt / coccinelle.git / blobdiff