let create_struct_hierarchy file =
let struct_fields ty =
match unrollType ty with
| TComp(compinfo,_,_) -> compinfo.cfields
| _ -> assert false
in
let num_fields ty = List.length (struct_fields ty) in
let compare_num_fields ty1 ty2 =
Pervasives.compare (num_fields ty1) (num_fields ty2)
in
let subtype ty1 ty2 =
let fields1 = struct_fields ty1 and fields2 = struct_fields ty2 in
let len1 = List.length fields1 and len2 = List.length fields2 in
if len1 > len2 then
List.fold_left2 (fun eq fi1 fi2 ->
eq && TypeComparable.equal fi1.ftype fi2.ftype
) true (sub_list fields1 len2) fields2
else false
in
let compute_hierarchy () =
let classes = TypeUnion.classes () in
List.iter (fun cls ->
let types = TypeSet.elements cls in
let types = List.sort compare_num_fields types in
let root,types =
match types with [] -> assert false | a::r -> a,r
in
TypeHashtbl.remove type_to_parent_type root;
List.iter
(fun ty ->
add_inheritance_relation ty root;
List.iter
(fun party ->
if subtype ty party then
add_inheritance_relation ty party
) types
) types
) classes;
TypeHashtbl.iter (fun ty party ->
let fields1 = struct_fields ty in
let fields2 = struct_fields party in
let num2 = List.length fields2 in
let subfields1 = sub_list fields1 num2 in
List.iter2 add_field_representant subfields1 fields2
) type_to_parent_type
in
let visitor = new createStructHierarchy in
visitFramacFile visitor file;
compute_hierarchy ();
let visitor = new exploitStructHierarchy in
visitFramacFile visitor file