You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
660 lines
23 KiB
660 lines
23 KiB
(*
|
|
* Copyright (c) 2013 - present Facebook, Inc.
|
|
* All rights reserved.
|
|
*
|
|
* This source code is licensed under the BSD style license found in the
|
|
* LICENSE file in the root directory of this source tree. An additional grant
|
|
* of patent rights can be found in the PATENTS file in the same directory.
|
|
*)
|
|
|
|
open! Utils
|
|
|
|
(** Module for utility functions for the whole frontend. Includes functions for printing, *)
|
|
(** for transformations of ast nodes and general utility functions such as functions on lists *)
|
|
|
|
module L = Logging
|
|
module F = Format
|
|
|
|
module Printing =
|
|
struct
|
|
let log_out fmt =
|
|
let pp = if Config.debug_mode then Format.fprintf else Format.ifprintf in
|
|
pp Format.std_formatter fmt
|
|
|
|
let log_err fmt =
|
|
let pp = if Config.debug_mode then Format.fprintf else Format.ifprintf in
|
|
pp Format.err_formatter fmt
|
|
|
|
|
|
let annotation_to_string (annotation, _) =
|
|
"< " ^ annotation.Typ.class_name ^ " : " ^
|
|
(IList.to_string (fun x -> x) annotation.Typ.parameters) ^ " >"
|
|
|
|
let field_to_string (fieldname, typ, annotation) =
|
|
(Ident.fieldname_to_string fieldname) ^ " " ^
|
|
(Typ.to_string typ) ^ (IList.to_string annotation_to_string annotation)
|
|
|
|
let log_stats fmt =
|
|
let pp =
|
|
if Config.stats_mode || Config.debug_mode
|
|
then Format.fprintf else Format.ifprintf in
|
|
pp Format.std_formatter fmt
|
|
|
|
let print_tenv tenv =
|
|
Tenv.iter (fun typname struct_t ->
|
|
match typname with
|
|
| Typename.TN_csu (Csu.Class _, _) | Typename.TN_csu (Csu.Protocol, _) ->
|
|
print_endline (
|
|
(Typename.to_string typname) ^ " " ^
|
|
(Typ.item_annotation_to_string struct_t.struct_annotations) ^ "\n" ^
|
|
"---> superclass and protocols " ^ (IList.to_string (fun tn ->
|
|
"\t" ^ (Typename.to_string tn) ^ "\n") struct_t.superclasses) ^
|
|
"---> methods " ^
|
|
(IList.to_string (fun x ->"\t" ^ (Procname.to_string x) ^ "\n") struct_t.def_methods)
|
|
^ " " ^
|
|
"\t---> fields " ^ (IList.to_string field_to_string struct_t.instance_fields) ^ "\n")
|
|
| _ -> ()
|
|
) tenv
|
|
|
|
let print_tenv_struct_unions tenv =
|
|
Tenv.iter (fun typname struct_t ->
|
|
match typname with
|
|
| Typename.TN_csu (Csu.Struct, _) | Typename.TN_csu (Csu.Union, _) ->
|
|
print_endline (
|
|
(Typename.to_string typname)^"\n"^
|
|
"\t---> fields "^(IList.to_string (fun (fieldname, typ, _) ->
|
|
match typ with
|
|
| Typ.Tvar tname -> "tvar"^(Typename.to_string tname)
|
|
| Typ.Tstruct _ | _ ->
|
|
"\t struct "^(Ident.fieldname_to_string fieldname)^" "^
|
|
(Typ.to_string typ)^"\n") struct_t.instance_fields
|
|
)
|
|
)
|
|
| Typename.TN_typedef typname ->
|
|
print_endline
|
|
((Mangled.to_string typname)^"-->"^(Typ.to_string (Typ.Tstruct struct_t)))
|
|
| _ -> ()
|
|
) tenv
|
|
|
|
let print_procedures cfg =
|
|
let procs = Cfg.get_all_procs cfg in
|
|
print_endline
|
|
(IList.to_string (fun pdesc ->
|
|
let pname = Cfg.Procdesc.get_proc_name pdesc in
|
|
"name> "^
|
|
(Procname.to_string pname) ^
|
|
" defined? " ^ (string_of_bool (Cfg.Procdesc.is_defined pdesc)) ^ "\n")
|
|
procs)
|
|
|
|
let print_failure_info pointer =
|
|
L.err "AST Element> %s IN FILE> %s @.@." pointer !CFrontend_config.json
|
|
|
|
let print_nodes nodes =
|
|
IList.iter (fun node -> print_endline (Cfg.Node.get_description pe_text node)) nodes
|
|
|
|
let instrs_to_string instrs =
|
|
let pp fmt () = Format.fprintf fmt "%a" (Sil.pp_instr_list pe_text) instrs in
|
|
pp_to_string pp ()
|
|
|
|
end
|
|
|
|
module Ast_utils =
|
|
struct
|
|
type type_ptr_to_sil_type = Tenv.t -> Clang_ast_t.type_ptr -> Typ.t
|
|
|
|
let string_of_decl decl =
|
|
let name = Clang_ast_proj.get_decl_kind_string decl in
|
|
let info = Clang_ast_proj.get_decl_tuple decl in
|
|
Printf.sprintf "<\"%s\"> '%d'" name info.Clang_ast_t.di_pointer
|
|
|
|
let string_of_unary_operator_kind = function
|
|
| `PostInc -> "PostInc"
|
|
| `PostDec -> "PostDec"
|
|
| `PreInc -> "PreInc"
|
|
| `PreDec -> "PreDec"
|
|
| `AddrOf -> "AddrOf"
|
|
| `Deref -> "Deref"
|
|
| `Plus -> "Plus"
|
|
| `Minus -> "Minus"
|
|
| `Not -> "Not"
|
|
| `LNot -> "LNot"
|
|
| `Real -> "Real"
|
|
| `Imag -> "Imag"
|
|
| `Extension -> "Extension"
|
|
| `Coawait -> "Coawait"
|
|
|
|
let string_of_stmt stmt =
|
|
let name = Clang_ast_proj.get_stmt_kind_string stmt in
|
|
let info, _ = Clang_ast_proj.get_stmt_tuple stmt in
|
|
Printf.sprintf "<\"%s\"> '%d'" name info.Clang_ast_t.si_pointer
|
|
|
|
let get_stmts_from_stmt stmt =
|
|
let open Clang_ast_t in
|
|
match stmt with
|
|
| OpaqueValueExpr (_, lstmt, _, opaque_value_expr_info) ->
|
|
(match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with
|
|
| Some stmt -> lstmt @ [stmt]
|
|
| _ -> lstmt)
|
|
(* given that this has not been translated, looking up for variables *)
|
|
(* inside leads to inconsistencies *)
|
|
| ObjCAtCatchStmt _ ->
|
|
[]
|
|
| _ -> snd (Clang_ast_proj.get_stmt_tuple stmt)
|
|
|
|
let fold_qual_name qual_name_list =
|
|
match qual_name_list with
|
|
| [] -> ""
|
|
| name :: quals ->
|
|
let s = (IList.fold_right (fun el res -> res ^ el ^ "::") quals "") ^ name in
|
|
let no_slash = Str.global_replace (Str.regexp "/") "_" s in
|
|
no_slash
|
|
|
|
let get_qualified_name name_info =
|
|
fold_qual_name name_info.Clang_ast_t.ni_qual_name
|
|
|
|
let get_unqualified_name name_info =
|
|
let name = match name_info.Clang_ast_t.ni_qual_name with
|
|
| name :: _ -> name
|
|
| [] -> name_info.Clang_ast_t.ni_name in
|
|
fold_qual_name [name]
|
|
|
|
let get_class_name_from_member member_name_info =
|
|
match member_name_info.Clang_ast_t.ni_qual_name with
|
|
| _ :: class_qual_list -> fold_qual_name class_qual_list
|
|
| [] -> assert false
|
|
|
|
let make_name_decl name = {
|
|
Clang_ast_t.ni_name = name;
|
|
ni_qual_name = [name];
|
|
}
|
|
|
|
let make_qual_name_decl class_name_quals name = {
|
|
Clang_ast_t.ni_name = name;
|
|
ni_qual_name = name :: class_name_quals;
|
|
}
|
|
|
|
let property_name property_impl_decl_info =
|
|
let no_property_name = make_name_decl "WARNING_NO_PROPERTY_NAME" in
|
|
match property_impl_decl_info.Clang_ast_t.opidi_property_decl with
|
|
| Some decl_ref ->
|
|
(match decl_ref.Clang_ast_t.dr_name with
|
|
| Some n -> n
|
|
| _ -> no_property_name)
|
|
| None -> no_property_name
|
|
|
|
let generated_ivar_name property_name =
|
|
match property_name.Clang_ast_t.ni_qual_name with
|
|
| [name; class_name] ->
|
|
let ivar_name = "_" ^ name in
|
|
{ Clang_ast_t.ni_name = ivar_name;
|
|
ni_qual_name = [ivar_name; class_name]
|
|
}
|
|
| _ -> make_name_decl property_name.Clang_ast_t.ni_name
|
|
|
|
let property_attribute_compare att1 att2 =
|
|
match att1, att2 with
|
|
`Readonly, `Readonly -> 0
|
|
| `Readonly, _ -> -1
|
|
| _, `Readonly -> 1
|
|
| `Assign, `Assign -> 0
|
|
| `Assign, _ -> -1
|
|
| _, `Assign -> 1
|
|
| `Readwrite, `Readwrite -> 0
|
|
| `Readwrite, _ -> -1
|
|
| _, `Readwrite -> 1
|
|
| `Retain, `Retain -> 0
|
|
| `Retain, _ -> -1
|
|
| _, `Retain -> 1
|
|
| `Copy, `Copy -> 0
|
|
| `Copy, _ -> -1
|
|
| _, `Copy -> 1
|
|
| `Nonatomic, `Nonatomic -> 0
|
|
| `Nonatomic, _ -> -1
|
|
| _, `Nonatomic -> 1
|
|
| `Atomic, `Atomic -> 0
|
|
| `Atomic, _ -> 1
|
|
| _, `Atomic -> 1
|
|
| `Weak, `Weak -> 0
|
|
| `Weak, _ -> -1
|
|
| _, `Weak -> 1
|
|
| `Strong, `Strong -> 0
|
|
| `Strong, _ -> -1
|
|
| _, `Strong -> 1
|
|
| `Unsafe_unretained, `Unsafe_unretained -> 0
|
|
| `Unsafe_unretained, _ -> -1
|
|
| _, `Unsafe_unretained -> 1
|
|
| `ExplicitGetter, `ExplicitGetter -> 0
|
|
| `ExplicitGetter, _ -> -1
|
|
| _, `ExplicitGetter -> 1
|
|
| `ExplicitSetter, `ExplicitSetter -> 0
|
|
|
|
let property_attribute_eq att1 att2 =
|
|
property_attribute_compare att1 att2 = 0
|
|
|
|
let get_memory_management_attributes () =
|
|
[`Assign; `Retain; `Copy; `Weak; `Strong; `Unsafe_unretained]
|
|
|
|
let is_retain attribute_opt =
|
|
match attribute_opt with
|
|
| Some attribute ->
|
|
attribute = `Retain || attribute = `Strong
|
|
| _ -> false
|
|
|
|
let is_copy attribute_opt =
|
|
match attribute_opt with
|
|
| Some attribute ->
|
|
attribute = `Copy
|
|
| _ -> false
|
|
|
|
let name_opt_of_name_info_opt name_info_opt =
|
|
match name_info_opt with
|
|
| Some name_info -> Some (get_qualified_name name_info)
|
|
| None -> None
|
|
|
|
let pointer_counter = ref 0
|
|
|
|
let get_fresh_pointer () =
|
|
pointer_counter := !pointer_counter + 1;
|
|
let internal_pointer = -(!pointer_counter) in
|
|
internal_pointer
|
|
|
|
let get_invalid_pointer () =
|
|
CFrontend_config.invalid_pointer
|
|
|
|
let type_from_unary_expr_or_type_trait_expr_info info =
|
|
match info.Clang_ast_t.uttei_type_ptr with
|
|
| Some tp -> Some tp
|
|
| None -> None
|
|
|
|
let get_decl decl_ptr =
|
|
try
|
|
Some (Clang_ast_main.PointerMap.find decl_ptr !CFrontend_config.pointer_decl_index)
|
|
with Not_found -> Printing.log_stats "decl with pointer %d not found\n" decl_ptr; None
|
|
|
|
let get_decl_opt decl_ptr_opt =
|
|
match decl_ptr_opt with
|
|
| Some decl_ptr -> get_decl decl_ptr
|
|
| None -> None
|
|
|
|
let get_stmt stmt_ptr =
|
|
try
|
|
Some (Clang_ast_main.PointerMap.find stmt_ptr !CFrontend_config.pointer_stmt_index)
|
|
with Not_found -> Printing.log_stats "stmt with pointer %d not found\n" stmt_ptr; None
|
|
|
|
let get_stmt_opt stmt_ptr_opt =
|
|
match stmt_ptr_opt with
|
|
| Some stmt_ptr -> get_stmt stmt_ptr
|
|
| None -> None
|
|
|
|
let get_decl_opt_with_decl_ref decl_ref_opt =
|
|
match decl_ref_opt with
|
|
| Some decl_ref -> get_decl decl_ref.Clang_ast_t.dr_decl_pointer
|
|
| None -> None
|
|
|
|
let update_sil_types_map type_ptr sil_type =
|
|
CFrontend_config.sil_types_map :=
|
|
Clang_ast_types.TypePointerMap.add type_ptr sil_type !CFrontend_config.sil_types_map
|
|
|
|
let update_enum_map enum_constant_pointer sil_exp =
|
|
let open Clang_ast_main in
|
|
let (predecessor_pointer_opt, _) =
|
|
try PointerMap.find enum_constant_pointer !CFrontend_config.enum_map
|
|
with Not_found -> assert false in
|
|
let enum_map_value = (predecessor_pointer_opt, Some sil_exp) in
|
|
CFrontend_config.enum_map :=
|
|
PointerMap.add enum_constant_pointer enum_map_value !CFrontend_config.enum_map
|
|
|
|
let add_enum_constant enum_constant_pointer predecessor_pointer_opt =
|
|
let enum_map_value = (predecessor_pointer_opt, None) in
|
|
CFrontend_config.enum_map :=
|
|
Clang_ast_main.PointerMap.add enum_constant_pointer enum_map_value !CFrontend_config.enum_map
|
|
|
|
let get_enum_constant_exp enum_constant_pointer =
|
|
Clang_ast_main.PointerMap.find enum_constant_pointer !CFrontend_config.enum_map
|
|
|
|
let get_type type_ptr =
|
|
try
|
|
(* There is chance for success only if type_ptr is in fact clang pointer *)
|
|
(let raw_ptr = Clang_ast_types.type_ptr_to_clang_pointer type_ptr in
|
|
try
|
|
Some (Clang_ast_main.PointerMap.find raw_ptr !CFrontend_config.pointer_type_index)
|
|
with Not_found -> Printing.log_stats "type with pointer %d not found\n" raw_ptr; None)
|
|
with Clang_ast_types.Not_Clang_Pointer ->
|
|
(* otherwise, function fails *)
|
|
let type_str = Clang_ast_types.type_ptr_to_string type_ptr in
|
|
Printing.log_stats "type %s is not clang pointer\n" type_str;
|
|
None
|
|
|
|
let get_desugared_type type_ptr =
|
|
let typ_opt = get_type type_ptr in
|
|
match typ_opt with
|
|
| Some typ ->
|
|
let type_info = Clang_ast_proj.get_type_tuple typ in
|
|
(match type_info.Clang_ast_t.ti_desugared_type with
|
|
| Some ptr -> get_type ptr
|
|
| _ -> typ_opt)
|
|
| _ -> typ_opt
|
|
|
|
let get_decl_from_typ_ptr typ_ptr =
|
|
let typ_opt = get_desugared_type typ_ptr in
|
|
let typ = match typ_opt with Some t -> t | _ -> assert false in
|
|
(* it needs extending to handle objC types *)
|
|
match typ with
|
|
| Clang_ast_t.RecordType (_, decl_ptr) -> get_decl decl_ptr
|
|
| _ -> None
|
|
|
|
(*TODO take the attributes into account too. To be done after we get the attribute's arguments. *)
|
|
let is_type_nonnull type_ptr =
|
|
let open Clang_ast_t in
|
|
match get_type type_ptr with
|
|
| Some AttributedType (_, attr_info) -> attr_info.ati_attr_kind = `Nonnull
|
|
| _ -> false
|
|
|
|
let is_type_nullable type_ptr =
|
|
let open Clang_ast_t in
|
|
match get_type type_ptr with
|
|
| Some AttributedType (_, attr_info) -> attr_info.ati_attr_kind = `Nullable
|
|
| _ -> false
|
|
|
|
let string_of_type_ptr type_ptr =
|
|
match get_desugared_type type_ptr with
|
|
| Some typ -> (Clang_ast_proj.get_type_tuple typ).Clang_ast_t.ti_raw
|
|
| None -> ""
|
|
|
|
let add_type_from_decl_ref type_ptr_to_sil_type tenv decl_ref_opt fail_if_not_found =
|
|
match decl_ref_opt with (* translate interface first if found *)
|
|
| Some dr ->
|
|
ignore (type_ptr_to_sil_type tenv (`DeclPtr dr.Clang_ast_t.dr_decl_pointer));
|
|
| _ -> if fail_if_not_found then assert false else ()
|
|
|
|
let add_type_from_decl_ref_list type_ptr_to_sil_type tenv decl_ref_list =
|
|
let add_elem dr =
|
|
ignore (type_ptr_to_sil_type tenv (`DeclPtr dr.Clang_ast_t.dr_decl_pointer)) in
|
|
IList.iter add_elem decl_ref_list
|
|
|
|
let get_function_decl_with_body decl_ptr =
|
|
let open Clang_ast_t in
|
|
let decl_opt = get_decl decl_ptr in
|
|
let decl_ptr' = match decl_opt with
|
|
| Some (FunctionDecl (_, _, _, fdecl_info))
|
|
| Some (CXXMethodDecl (_, _, _, fdecl_info, _))
|
|
| Some (CXXConstructorDecl (_, _, _, fdecl_info, _))
|
|
| Some (CXXConversionDecl (_, _, _, fdecl_info, _))
|
|
| Some (CXXDestructorDecl (_, _, _, fdecl_info, _)) ->
|
|
fdecl_info.Clang_ast_t.fdi_decl_ptr_with_body
|
|
| _ -> Some decl_ptr in
|
|
if decl_ptr' = (Some decl_ptr) then decl_opt
|
|
else get_decl_opt decl_ptr'
|
|
|
|
let get_info_from_decl_ref decl_ref =
|
|
let name_info = match decl_ref.Clang_ast_t.dr_name with Some ni -> ni | _ -> assert false in
|
|
let decl_ptr = decl_ref.Clang_ast_t.dr_decl_pointer in
|
|
let type_ptr = match decl_ref.Clang_ast_t.dr_type_ptr with Some tp -> tp | _ -> assert false in
|
|
name_info, decl_ptr, type_ptr
|
|
|
|
(* st |= EF (atomic_pred param) *)
|
|
let rec exists_eventually_st atomic_pred param st =
|
|
if atomic_pred param st then true
|
|
else
|
|
let _, st_list = Clang_ast_proj.get_stmt_tuple st in
|
|
IList.exists (exists_eventually_st atomic_pred param) st_list
|
|
|
|
let is_global_var decl =
|
|
match decl with
|
|
| Clang_ast_t.VarDecl (_, _ ,_, vdi) -> vdi.vdi_is_global
|
|
| _ -> false
|
|
|
|
let is_const_expr_var decl =
|
|
match decl with
|
|
| Clang_ast_t.VarDecl (_, _ ,_, vdi) -> vdi.vdi_is_const_expr
|
|
| _ -> false
|
|
|
|
let is_objc () =
|
|
match Config.clang_lang with
|
|
| Config.OBJC -> true
|
|
| _ -> false
|
|
|
|
let is_objcpp () =
|
|
match Config.clang_lang with
|
|
| Config.OBJCPP -> true
|
|
| _ -> false
|
|
|
|
(*
|
|
let rec getter_attribute_opt attributes =
|
|
match attributes with
|
|
| [] -> None
|
|
| attr:: rest ->
|
|
match attr with
|
|
| `Getter getter -> getter.Clang_ast_t.dr_name
|
|
| _ -> (getter_attribute_opt rest)
|
|
|
|
let rec setter_attribute_opt attributes =
|
|
match attributes with
|
|
| [] -> None
|
|
| attr:: rest ->
|
|
match attr with
|
|
| `Setter setter -> setter.Clang_ast_t.dr_name
|
|
| _ -> (setter_attribute_opt rest)
|
|
*)
|
|
end
|
|
|
|
(* Global counter for anonymous block*)
|
|
let block_counter = ref 0
|
|
|
|
(* Returns a fresh index for a new anonymous block *)
|
|
let get_fresh_block_index () =
|
|
block_counter := !block_counter +1;
|
|
!block_counter
|
|
|
|
module General_utils =
|
|
struct
|
|
|
|
type var_info = Clang_ast_t.decl_info * Clang_ast_t.type_ptr * Clang_ast_t.var_decl_info * bool
|
|
|
|
let rec swap_elements_list l =
|
|
match l with
|
|
| el1:: el2:: rest ->
|
|
el2:: el1:: (swap_elements_list rest)
|
|
| [] -> []
|
|
| _ -> assert false
|
|
|
|
let rec string_from_list l =
|
|
match l with
|
|
| [] -> ""
|
|
| [item] -> item
|
|
| item:: l' -> item^" "^(string_from_list l')
|
|
|
|
let rec append_no_duplicates eq list1 list2 =
|
|
match list2 with
|
|
| el:: rest2 ->
|
|
if (IList.mem eq el list1) then
|
|
(append_no_duplicates eq list1 rest2)
|
|
else (append_no_duplicates eq list1 rest2)@[el]
|
|
| [] -> list1
|
|
|
|
let append_no_duplicates_csu list1 list2 =
|
|
append_no_duplicates Typename.equal list1 list2
|
|
|
|
let append_no_duplicates_methods list1 list2 =
|
|
append_no_duplicates Procname.equal list1 list2
|
|
|
|
let append_no_duplicated_vars list1 list2 =
|
|
let eq (m1, t1) (m2, t2) = (Mangled.equal m1 m2) && (Typ.equal t1 t2) in
|
|
append_no_duplicates eq list1 list2
|
|
|
|
let append_no_duplicateds list1 list2 =
|
|
let eq (e1, t1) (e2, t2) = (Sil.exp_equal e1 e2) && (Typ.equal t1 t2) in
|
|
append_no_duplicates eq list1 list2
|
|
|
|
|
|
let append_no_duplicates_annotations list1 list2 =
|
|
let eq (annot1, _) (annot2, _) = annot1.Typ.class_name = annot2.Typ.class_name in
|
|
append_no_duplicates eq list1 list2
|
|
|
|
let add_no_duplicates_fields field_tuple l =
|
|
let rec replace_field field_tuple l found =
|
|
match field_tuple, l with
|
|
| (field, typ, annot), ((old_field, old_typ, old_annot) as old_field_tuple :: rest) ->
|
|
let ret_list, ret_found = replace_field field_tuple rest found in
|
|
if Ident.fieldname_equal field old_field && Typ.equal typ old_typ then
|
|
let annotations = append_no_duplicates_annotations annot old_annot in
|
|
(field, typ, annotations) :: ret_list, true
|
|
else old_field_tuple :: ret_list, ret_found
|
|
| _, [] -> [], found in
|
|
let new_list, found = replace_field field_tuple l false in
|
|
if found then new_list
|
|
else field_tuple :: l
|
|
|
|
let rec append_no_duplicates_fields list1 list2 =
|
|
match list1 with
|
|
| field_tuple :: rest ->
|
|
let updated_list2 = append_no_duplicates_fields rest list2 in
|
|
add_no_duplicates_fields field_tuple updated_list2
|
|
| [] -> list2
|
|
|
|
let sort_fields fields =
|
|
let compare (name1, _, _) (name2, _, _) =
|
|
Ident.fieldname_compare name1 name2 in
|
|
IList.sort compare fields
|
|
|
|
|
|
let sort_fields_tenv tenv =
|
|
let sort_fields_struct typname st =
|
|
let st' = { st with Typ.instance_fields = (sort_fields st.Typ.instance_fields) } in
|
|
Tenv.add tenv typname st' in
|
|
Tenv.iter sort_fields_struct tenv
|
|
|
|
let rec collect_list_tuples l (a, a1, b, c, d) =
|
|
match l with
|
|
| [] -> (a, a1, b, c, d)
|
|
| (a', a1', b', c', d'):: l' -> collect_list_tuples l' (a@a', a1@a1', b@b', c@c', d@d')
|
|
|
|
let is_static_var var_decl_info =
|
|
match var_decl_info.Clang_ast_t.vdi_storage_class with
|
|
| Some sc -> sc = CFrontend_config.static
|
|
| _ -> false
|
|
|
|
let block_procname_with_index defining_proc i =
|
|
Config.anonymous_block_prefix^(Procname.to_string defining_proc)^Config.anonymous_block_num_sep^(string_of_int i)
|
|
|
|
(* Makes a fresh name for a block defined inside the defining procedure.*)
|
|
(* It updates the global block_counter *)
|
|
let mk_fresh_block_procname defining_proc =
|
|
let name = block_procname_with_index defining_proc (get_fresh_block_index ()) in
|
|
Procname.mangled_objc_block name
|
|
|
|
(* Returns the next fresh name for a block defined inside the defining procedure *)
|
|
(* It does not update the global block_counter *)
|
|
let get_next_block_pvar defining_proc =
|
|
let name = block_procname_with_index defining_proc (!block_counter +1) in
|
|
Pvar.mk (Mangled.from_string (CFrontend_config.temp_var^"_"^name)) defining_proc
|
|
|
|
(* Reset block counter *)
|
|
let reset_block_counter () =
|
|
block_counter := 0
|
|
|
|
let rec zip xs ys =
|
|
match xs, ys with
|
|
| [], _
|
|
| _, [] -> []
|
|
| x :: xs, y :: ys -> (x, y) :: zip xs ys
|
|
|
|
let list_range i j =
|
|
let rec aux n acc =
|
|
if n < i then acc else aux (n -1) (n :: acc)
|
|
in aux j [] ;;
|
|
|
|
let replicate n el = IList.map (fun _ -> el) (list_range 0 (n -1))
|
|
|
|
let mk_class_field_name field_qual_name =
|
|
let field_name = field_qual_name.Clang_ast_t.ni_name in
|
|
let class_name = Ast_utils.get_class_name_from_member field_qual_name in
|
|
Ident.create_fieldname (Mangled.mangled field_name class_name) 0
|
|
|
|
let get_rel_file_path file_opt =
|
|
match file_opt with
|
|
| Some file ->
|
|
(match Config.project_root with
|
|
| Some root ->
|
|
DB.source_file_to_rel_path (DB.rel_source_file_from_abs_path root file)
|
|
| None -> file)
|
|
| None -> ""
|
|
|
|
let mk_procname_from_function name function_decl_info_opt tp language =
|
|
let file =
|
|
match function_decl_info_opt with
|
|
| Some (decl_info, function_decl_info) ->
|
|
(match function_decl_info.Clang_ast_t.fdi_storage_class with
|
|
| Some "static" ->
|
|
let file_opt = (fst decl_info.Clang_ast_t.di_source_range).Clang_ast_t.sl_file in
|
|
get_rel_file_path file_opt
|
|
| _ -> "")
|
|
| None -> "" in
|
|
let type_string =
|
|
match language with
|
|
| Config.CPP
|
|
| Config.OBJCPP -> Ast_utils.string_of_type_ptr tp
|
|
| _ -> "" in
|
|
(* remove __restrict from type name to avoid mismatches. Clang allows to declare function*)
|
|
(* with __restrict parameters and then define it without (it mostly applies to models).*)
|
|
(* We are not using this information right now so we can remove it to avoid dealing with*)
|
|
(* corner cases on different systems *)
|
|
let type_string_no_restrict = Str.global_replace (Str.regexp "__restrict") "" type_string in
|
|
let mangled = file ^ type_string_no_restrict in
|
|
if String.length mangled == 0 then
|
|
Procname.from_string_c_fun name
|
|
else
|
|
let crc = string_crc_hex32 mangled in
|
|
Procname.C (Procname.c name crc)
|
|
|
|
let mk_procname_from_objc_method class_name method_name method_kind =
|
|
let mangled = Procname.mangled_of_objc_method_kind method_kind in
|
|
Procname.ObjC_Cpp
|
|
(Procname.objc_cpp class_name method_name mangled)
|
|
|
|
let mk_procname_from_cpp_method class_name method_name tp =
|
|
let type_name = Ast_utils.string_of_type_ptr tp in
|
|
let type_name_crc = Some (string_crc_hex32 type_name) in
|
|
Procname.ObjC_Cpp
|
|
(Procname.objc_cpp class_name method_name type_name_crc)
|
|
|
|
let get_var_name_mangled name_info var_decl_info =
|
|
let clang_name = Ast_utils.get_qualified_name name_info in
|
|
let param_idx_opt = var_decl_info.Clang_ast_t.vdi_parm_index_in_function in
|
|
let name_string =
|
|
match clang_name, param_idx_opt with
|
|
| "", Some index -> "__param_" ^ string_of_int index
|
|
| "", None -> assert false
|
|
| _ -> clang_name in
|
|
let mangled = match param_idx_opt with
|
|
| Some index -> Mangled.mangled name_string (string_of_int index)
|
|
| None -> Mangled.from_string name_string in
|
|
name_string, mangled
|
|
|
|
let mk_sil_var name decl_info_type_ptr_opt procname outer_procname =
|
|
let name_string = Ast_utils.get_qualified_name name in
|
|
match decl_info_type_ptr_opt with
|
|
| Some (decl_info, type_ptr, var_decl_info, should_be_mangled) ->
|
|
let name_string, simple_name = get_var_name_mangled name var_decl_info in
|
|
if var_decl_info.Clang_ast_t.vdi_is_global then
|
|
let global_mangled_name =
|
|
if var_decl_info.Clang_ast_t.vdi_is_static_local then
|
|
Mangled.from_string ((Procname.to_string outer_procname) ^ "_" ^ name_string)
|
|
else simple_name in
|
|
Pvar.mk_global global_mangled_name
|
|
else if not should_be_mangled then Pvar.mk simple_name procname
|
|
else
|
|
let type_name = Ast_utils.string_of_type_ptr type_ptr in
|
|
let start_location = fst decl_info.Clang_ast_t.di_source_range in
|
|
let line_opt = start_location.Clang_ast_t.sl_line in
|
|
let line_str = match line_opt with | Some line -> string_of_int line | None -> "" in
|
|
let mangled = string_crc_hex32 (type_name ^ line_str) in
|
|
let mangled_name = Mangled.mangled name_string mangled in
|
|
Pvar.mk mangled_name procname
|
|
| None -> Pvar.mk (Mangled.from_string name_string) procname
|
|
|
|
let is_cpp_translation language =
|
|
language = Config.CPP || language = Config.OBJCPP
|
|
|
|
end
|