infer_clone/infer/src/clang/objcInterface_decl.ml

(*
 * 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.
 *)

(** In this module an ObjC interface declaration or implementation is processed. The class  *)
(** is saved in the tenv as a struct with the corresponding fields, potential superclass and *)
(** list of defined methods *)

(* ObjectiveC doesn't have a notion of static or class fields. *)
(* So, in this module we translate a class into a sil srtuct with an empty list of static fields.*)

open Utils
open CFrontend_utils

module L = Logging

let objc_class_str = "ObjC-Class"

let objc_class_annotation =
  [({ Sil.class_name = objc_class_str; Sil.parameters =[]}, true)]

let is_objc_class_annotation a =
  match a with
  | [({ Sil.class_name = n; Sil.parameters =[]}, true)] when n = objc_class_str -> true
  | _ -> false

let is_pointer_to_objc_class tenv typ =
  match typ with
  | Sil.Tptr (Sil.Tvar (Typename.TN_csu (Csu.Class, cname)), _) ->
      (match Sil.tenv_lookup tenv (Typename.TN_csu (Csu.Class, cname)) with
       | Some Sil.Tstruct(_, _, Csu.Class, _, _, _, a) when is_objc_class_annotation a -> true
       | _ -> false)
  | Sil.Tptr (Sil.Tstruct(_, _, Csu.Class, _, _, _, a), _) when
      is_objc_class_annotation a -> true
  | _ -> false

let get_super_interface_decl otdi_super =
  match otdi_super with
  | Some dr -> Ast_utils.name_opt_of_name_info_opt dr.Clang_ast_t.dr_name
  | _ -> None

let get_protocols protocols =
  let protocol_names = IList.map (
      fun decl -> match decl.Clang_ast_t.dr_name with
        | Some name_info -> Ast_utils.get_qualified_name name_info
        | None -> assert false
    ) protocols in
  protocol_names

let get_curr_class class_name ocdi =
  let super = get_super_interface_decl ocdi.Clang_ast_t.otdi_super  in
  let protocols = get_protocols ocdi.Clang_ast_t.otdi_protocols in
  CContext.ContextCls (class_name, super, protocols)

let get_curr_class_impl oi =
  let open Clang_ast_t in
  match oi.Clang_ast_t.oidi_class_interface with
  | Some decl_ref ->
      (match Ast_utils.get_decl decl_ref.Clang_ast_t.dr_decl_pointer with
       | Some ObjCInterfaceDecl (_, name_info, _, _, obj_c_interface_decl_info) ->
           let class_name = Ast_utils.get_qualified_name name_info in
           get_curr_class class_name obj_c_interface_decl_info
       | _ -> assert false)
  | _ -> assert false

let add_class_decl type_ptr_to_sil_type tenv idi =
  let decl_ref_opt = idi.Clang_ast_t.oidi_class_interface in
  Ast_utils.add_type_from_decl_ref type_ptr_to_sil_type tenv decl_ref_opt true

let add_super_class_decl type_ptr_to_sil_type tenv ocdi =
  let decl_ref_opt = ocdi.Clang_ast_t.otdi_super in
  Ast_utils.add_type_from_decl_ref type_ptr_to_sil_type tenv decl_ref_opt false

let add_protocols_decl type_ptr_to_sil_type tenv protocols =
  Ast_utils.add_type_from_decl_ref_list type_ptr_to_sil_type tenv protocols

let add_categories_decl type_ptr_to_sil_type tenv categories =
  Ast_utils.add_type_from_decl_ref_list type_ptr_to_sil_type tenv categories

let add_class_implementation type_ptr_to_sil_type tenv idi =
  let decl_ref_opt = idi.Clang_ast_t.otdi_implementation  in
  Ast_utils.add_type_from_decl_ref type_ptr_to_sil_type tenv decl_ref_opt false

(*The superclass is the first element in the list of super classes of structs in the tenv, *)
(* then come the protocols and categories. *)
let get_interface_superclasses super_opt protocols =
  let super_class =
    match super_opt with
    | None -> []
    | Some super -> [(Csu.Class, Mangled.from_string super)] in
  let protocol_names = IList.map (
      fun name -> (Csu.Protocol, Mangled.from_string name)
    ) protocols in
  let super_classes = super_class@protocol_names in
  super_classes

let create_superclasses_fields type_ptr_to_sil_type tenv curr_class decl_list class_name
    otdi_super otdi_protocols =
  let super = get_super_interface_decl otdi_super in
  let protocols = get_protocols otdi_protocols in
  let superclasses = get_interface_superclasses super protocols in
  let fields = CField_decl.get_fields type_ptr_to_sil_type tenv curr_class decl_list in
  superclasses, fields

(* Adds pairs (interface name, interface_type_info) to the global environment. *)
let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info class_name decl_list ocidi =
  Printing.log_out "ADDING: ObjCInterfaceDecl for '%s'\n" class_name;
  let interface_name = CTypes.mk_classname class_name in
  let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
  Ast_utils.update_sil_types_map decl_key (Sil.Tvar interface_name);
  let superclasses, fields =
    create_superclasses_fields type_ptr_to_sil_type tenv curr_class decl_list class_name
      ocidi.Clang_ast_t.otdi_super
      ocidi.Clang_ast_t.otdi_protocols in
  let methods = ObjcProperty_decl.get_methods curr_class decl_list in
  let fields_sc = CField_decl.fields_superclass tenv ocidi in
  IList.iter (fun (fn, ft, _) ->
      Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn);
      Printing.log_out "type: '%s'\n" (Sil.typ_to_string ft)) fields_sc;
  (*In case we found categories, or partial definition of this class earlier and they are already in the tenv *)
  let fields, superclasses, methods =
    match Sil.tenv_lookup tenv interface_name with
    | Some Sil.Tstruct(saved_fields, _, _, _, saved_superclasses, saved_methods, _) ->
        General_utils.append_no_duplicates_fields fields saved_fields,
        General_utils.append_no_duplicates_csu superclasses saved_superclasses,
        General_utils.append_no_duplicates_methods methods saved_methods
    | _ -> fields, superclasses, methods in
  let fields = General_utils.append_no_duplicates_fields fields fields_sc in
  (* We add the special hidden counter_field for implementing reference counting *)
  let fields = General_utils.append_no_duplicates_fields [Sil.objc_ref_counter_field] fields in
  let fields = General_utils.sort_fields fields in
  Printing.log_out "Class %s field:\n" class_name;
  IList.iter (fun (fn, ft, _) ->
      Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
  let interface_type_info =
    Sil.Tstruct(fields, [], Csu.Class, Some (Mangled.from_string class_name),
                superclasses, methods, objc_class_annotation) in
  Sil.tenv_add tenv interface_name interface_type_info;
  Printing.log_out
    "  >>>Verifying that Typename '%s' is in tenv\n" (Typename.to_string interface_name);
  (match Sil.tenv_lookup tenv interface_name with
   | Some t -> Printing.log_out "  >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
   | None -> Printing.log_out "  >>>NOT Found!!\n");
  Sil.Tvar interface_name

let add_missing_methods tenv class_name decl_info decl_list curr_class =
  let methods = ObjcProperty_decl.get_methods curr_class decl_list in
  let class_tn_name = Typename.TN_csu (Csu.Class, (Mangled.from_string class_name)) in
  let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
  Ast_utils.update_sil_types_map decl_key (Sil.Tvar class_tn_name);
  (match Sil.tenv_lookup tenv class_tn_name with
   | Some Sil.Tstruct (fields, [], Csu.Class, Some name,
                       superclass, existing_methods, annotation) ->
       let methods = General_utils.append_no_duplicates_methods existing_methods methods in
       let typ =
         Sil.Tstruct (fields, [], Csu.Class, Some name, superclass, methods, annotation) in
       Sil.tenv_add tenv class_tn_name typ
   | _ -> ());
  Sil.Tvar class_tn_name

(* Interface_type_info has the name of instance variables and the name of methods. *)
let interface_declaration type_ptr_to_sil_type tenv decl =
  let open Clang_ast_t in
  match decl with
  | ObjCInterfaceDecl (decl_info, name_info, decl_list, _, ocidi) ->
      let name = Ast_utils.get_qualified_name name_info in
      let curr_class = get_curr_class name ocidi in
      let typ =
        add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name decl_list ocidi in
      let _ = add_class_implementation type_ptr_to_sil_type tenv ocidi in
      let _ = add_super_class_decl type_ptr_to_sil_type tenv ocidi in
      let _ = add_protocols_decl type_ptr_to_sil_type tenv ocidi.Clang_ast_t.otdi_protocols in
      let known_categories = ocidi.Clang_ast_t.otdi_known_categories in
      let _ = add_categories_decl type_ptr_to_sil_type tenv known_categories in
      typ
  | _ -> assert false

(* Translate the methods defined in the implementation.*)
let interface_impl_declaration type_ptr_to_sil_type tenv decl =
  let open Clang_ast_t in
  match decl with
  | ObjCImplementationDecl (decl_info, name_info, decl_list, decl_context_info, idi) ->
      let class_name = Ast_utils.get_qualified_name name_info in
      Printing.log_out "ADDING: ObjCImplementationDecl for class '%s'\n" class_name;
      let _ = add_class_decl type_ptr_to_sil_type tenv idi in
      let curr_class = get_curr_class_impl idi in
      let fields = CField_decl.get_fields type_ptr_to_sil_type tenv curr_class decl_list in
      CField_decl.add_missing_fields tenv class_name fields;
      let typ = add_missing_methods tenv class_name decl_info decl_list curr_class in
      typ
  | _ -> assert false