From 029499cd9db42c5d5537b2dc3d8ee13959f48188 Mon Sep 17 00:00:00 2001 From: Andrzej Kotulski Date: Wed, 26 Apr 2017 10:38:55 -0700 Subject: [PATCH] [IR] add type qualifiers to Typ.t Reviewed By: jberdine, jvillard Differential Revision: D4867359 fbshipit-source-id: eef5be0 --- infer/src/IR/AttributesTable.re | 2 +- infer/src/IR/Cfg.re | 17 ++- infer/src/IR/HilInstr.ml | 4 +- infer/src/IR/Localise.ml | 10 +- infer/src/IR/Objc_models.ml | 2 +- infer/src/IR/ProcAttributes.re | 2 +- infer/src/IR/Sil.re | 4 +- infer/src/IR/Typ.re | 120 +++++++++++------- infer/src/IR/Typ.rei | 22 +++- infer/src/backend/Attribute.ml | 6 +- infer/src/backend/BuiltinDefn.ml | 40 +++--- infer/src/backend/abs.ml | 8 +- infer/src/backend/absarray.ml | 16 +-- infer/src/backend/dom.ml | 11 +- infer/src/backend/dotty.ml | 2 +- infer/src/backend/errdesc.ml | 6 +- infer/src/backend/interproc.ml | 4 +- infer/src/backend/preanal.ml | 2 +- infer/src/backend/prop.ml | 28 ++-- infer/src/backend/prover.ml | 53 ++++---- infer/src/backend/rearrange.ml | 110 ++++++++-------- infer/src/backend/symExec.ml | 30 ++--- infer/src/backend/tabulation.ml | 4 +- .../src/bufferoverrun/bufferOverrunChecker.ml | 14 +- .../bufferoverrun/bufferOverrunSemantics.ml | 22 ++-- infer/src/checkers/ThreadSafety.ml | 12 +- infer/src/checkers/accessPath.ml | 2 +- infer/src/checkers/addressTaken.ml | 4 +- infer/src/checkers/checkers.ml | 12 +- infer/src/checkers/copyPropagation.ml | 2 +- .../checkers/fragmentRetainsViewChecker.ml | 6 +- infer/src/checkers/patternMatch.ml | 33 ++--- infer/src/clang/CType.ml | 10 +- infer/src/clang/CType_decl.ml | 17 ++- infer/src/clang/cArithmetic_trans.ml | 2 +- infer/src/clang/cEnum_decl.ml | 2 +- infer/src/clang/cField_decl.ml | 6 +- infer/src/clang/cMethod_trans.ml | 14 +- infer/src/clang/cTrans.ml | 85 +++++++------ infer/src/clang/cTrans_utils.ml | 39 +++--- infer/src/clang/cType_to_sil_type.ml | 82 ++++++------ infer/src/clang/objcCategory_decl.ml | 5 +- infer/src/clang/objcInterface_decl.ml | 11 +- infer/src/clang/objcProtocol_decl.ml | 5 +- infer/src/eradicate/eradicateChecks.ml | 4 +- infer/src/eradicate/typeCheck.ml | 11 +- infer/src/harness/harness.ml | 2 +- infer/src/harness/inhabit.ml | 22 ++-- infer/src/java/jTrans.ml | 24 ++-- infer/src/java/jTransExn.ml | 8 +- infer/src/java/jTransType.ml | 60 ++++----- infer/src/quandary/JavaTaintAnalysis.ml | 12 +- infer/src/quandary/JavaTrace.ml | 4 +- infer/src/quandary/TaintAnalysis.ml | 8 +- infer/src/unit/BoundedCallTreeTests.ml | 4 +- infer/src/unit/TaintTests.ml | 6 +- infer/src/unit/TraceTests.ml | 2 +- infer/src/unit/accessPathTestUtils.ml | 2 +- infer/src/unit/accessPathTests.ml | 6 +- infer/src/unit/accessTreeTests.ml | 2 +- infer/src/unit/addressTakenTests.ml | 6 +- infer/src/unit/analyzerTester.ml | 4 +- infer/src/unit/livenessTests.ml | 4 +- 63 files changed, 569 insertions(+), 510 deletions(-) diff --git a/infer/src/IR/AttributesTable.re b/infer/src/IR/AttributesTable.re index 783df0161..1ed375e8d 100644 --- a/infer/src/IR/AttributesTable.re +++ b/infer/src/IR/AttributesTable.re @@ -201,7 +201,7 @@ let get_correct_type_from_objc_class_name type_name => switch (find_tenv_from_class_of_proc class_method) { | Some tenv => */ - Some (Typ.Tstruct type_name); + Some (Typ.mk (Tstruct type_name)); type t = { num_bindings: int, diff --git a/infer/src/IR/Cfg.re b/infer/src/IR/Cfg.re index 11d3aaf88..3d7881862 100644 --- a/infer/src/IR/Cfg.re +++ b/infer/src/IR/Cfg.re @@ -350,7 +350,7 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions => { let convert_pvar pvar => Pvar.mk (Pvar.get_name pvar) resolved_pname; let mk_ptr_typ typename => /* Only consider pointers from Java objects for now */ - Typ.Tptr (Typ.Tstruct typename) Typ.Pk_pointer; + Typ.mk (Tptr (Typ.mk (Tstruct typename)) Typ.Pk_pointer); let convert_exp = fun | Exp.Lvar origin_pvar => Exp.Lvar (convert_pvar origin_pvar) @@ -363,7 +363,10 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions => { let convert_instr instrs => fun | Sil.Load - id (Exp.Lvar origin_pvar as origin_exp) (Typ.Tptr (Tstruct origin_typename) Pk_pointer) loc => { + id + (Exp.Lvar origin_pvar as origin_exp) + {Typ.desc: Tptr {desc: Tstruct origin_typename} Pk_pointer} + loc => { let specialized_typname = try (Mangled.Map.find (Pvar.get_name origin_pvar) substitutions) { | Not_found => origin_typename @@ -371,9 +374,9 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions => { subst_map := Ident.IdentMap.add id specialized_typname !subst_map; [Sil.Load id (convert_exp origin_exp) (mk_ptr_typ specialized_typname) loc, ...instrs] } - | Sil.Load id (Exp.Var origin_id as origin_exp) (Typ.Tstruct _ as origin_typ) loc => { - let updated_typ = - try (Typ.Tstruct (Ident.IdentMap.find origin_id !subst_map)) { + | Sil.Load id (Exp.Var origin_id as origin_exp) ({Typ.desc: Tstruct _} as origin_typ) loc => { + let updated_typ: Typ.t = + try (Typ.mk default::origin_typ (Tstruct (Ident.IdentMap.find origin_id !subst_map))) { | Not_found => origin_typ }; [Sil.Load id (convert_exp origin_exp) updated_typ loc, ...instrs] @@ -474,8 +477,8 @@ let specialize_types callee_pdesc resolved_pname args => { List.fold2_exn f::( fun (params, subts) (param_name, param_typ) (_, arg_typ) => - switch arg_typ { - | Typ.Tptr (Tstruct typename) Pk_pointer => + switch arg_typ.Typ.desc { + | Tptr {desc: Tstruct typename} Pk_pointer => /* Replace the type of the parameter by the type of the argument */ ([(param_name, arg_typ), ...params], Mangled.Map.add param_name typename subts) | _ => ([(param_name, param_typ), ...params], subts) diff --git a/infer/src/IR/HilInstr.ml b/infer/src/IR/HilInstr.ml index b9d069d87..9b5da9550 100644 --- a/infer/src/IR/HilInstr.ml +++ b/infer/src/IR/HilInstr.ml @@ -73,14 +73,14 @@ let of_sil ~f_resolve_id (instr : Sil.instr) = | Call (ret_opt, call_exp, formals, loc, call_flags) -> let hil_ret = Option.map ~f:(fun (ret_id, ret_typ) -> Var.of_id ret_id, ret_typ) ret_opt in let hil_call = - match HilExp.of_sil ~f_resolve_id call_exp Typ.Tvoid with + match HilExp.of_sil ~f_resolve_id call_exp (Typ.mk Tvoid) with | Constant (Cfun procname) -> Direct procname | AccessPath access_path -> Indirect access_path | call_exp -> invalid_argf "Unexpected call expression %a" HilExp.pp call_exp in let formals = List.map ~f:(fun (exp, typ) -> HilExp.of_sil ~f_resolve_id exp typ) formals in Instr (Call (hil_ret, hil_call, formals, call_flags, loc)) | Prune (exp, loc, true_branch, if_kind) -> - let hil_exp = HilExp.of_sil ~f_resolve_id exp (Typ.Tint Typ.IBool) in + let hil_exp = HilExp.of_sil ~f_resolve_id exp (Typ.mk (Tint IBool)) in let branch = if true_branch then `Then else `Else in Instr (Assume (hil_exp, branch, if_kind, loc)) | Nullify _ | Remove_temps _ diff --git a/infer/src/IR/Localise.ml b/infer/src/IR/Localise.ml index 19b983a2f..b9db978bc 100644 --- a/infer/src/IR/Localise.ml +++ b/infer/src/IR/Localise.ml @@ -309,12 +309,12 @@ let add_by_call_to_opt problem_str tags proc_name_opt = problem_str ^ " " ^ by_call_to tags proc_name | None -> problem_str -let rec format_typ = function - | Typ.Tptr (typ, _) when Config.curr_language_is Config.Java -> - format_typ typ +let rec format_typ typ = match typ.Typ.desc with + | Typ.Tptr (t, _) when Config.curr_language_is Config.Java -> + format_typ t | Typ.Tstruct name -> Typ.Name.name name - | typ -> + | _ -> Typ.to_string typ let format_field f = @@ -771,7 +771,7 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc MF.monospaced_to_string s, " to ", " on " in let typ_str = match hpred_type_opt with - | Some (Exp.Sizeof (Tstruct name, _, _)) when Typ.Name.is_class name -> + | Some (Exp.Sizeof ({desc=Tstruct name}, _, _)) when Typ.Name.is_class name -> " of type " ^ MF.monospaced_to_string (Typ.Name.name name) ^ " " | _ -> " " in let desc_str = diff --git a/infer/src/IR/Objc_models.ml b/infer/src/IR/Objc_models.ml index 692af2e32..4ea224ab0 100644 --- a/infer/src/IR/Objc_models.ml +++ b/infer/src/IR/Objc_models.ml @@ -205,7 +205,7 @@ struct List.mem ~equal:String.equal core_graphics_types o let rec is_core_lib lib typ = - match typ with + match typ.Typ.desc with | Typ.Tptr (styp, _ ) -> is_core_lib lib styp | Typ.Tstruct name -> diff --git a/infer/src/IR/ProcAttributes.re b/infer/src/IR/ProcAttributes.re index 822341875..625566850 100644 --- a/infer/src/IR/ProcAttributes.re +++ b/infer/src/IR/ProcAttributes.re @@ -99,6 +99,6 @@ let default proc_name language => { objc_accessor: None, proc_flags: proc_flags_empty (), proc_name, - ret_type: Typ.Tvoid, + ret_type: Typ.mk Typ.Tvoid, source_file_captured: SourceFile.invalid }; diff --git a/infer/src/IR/Sil.re b/infer/src/IR/Sil.re index 0f60744c2..a19e742d2 100644 --- a/infer/src/IR/Sil.re +++ b/infer/src/IR/Sil.re @@ -229,7 +229,7 @@ let hpred_get_lhs h => /** {2 Comparision and Inspection Functions} */ let has_objc_ref_counter tenv hpred => switch hpred { - | Hpointsto _ _ (Sizeof (Tstruct name) _ _) => + | Hpointsto _ _ (Sizeof {desc: Tstruct name} _ _) => switch (Tenv.lookup tenv name) { | Some {fields} => List.exists f::Typ.Struct.is_objc_ref_counter_field fields | _ => false @@ -240,7 +240,7 @@ let has_objc_ref_counter tenv hpred => /** Returns the zero value of a type, for int, float and ptr types, None othwewise */ let zero_value_of_numerical_type_option typ => - switch typ { + switch typ.Typ.desc { | Typ.Tint _ => Some (Exp.Const (Cint IntLit.zero)) | Typ.Tfloat _ => Some (Exp.Const (Cfloat 0.0)) | Typ.Tptr _ => Some (Exp.Const (Cint IntLit.null)) diff --git a/infer/src/IR/Typ.re b/infer/src/IR/Typ.re index 731cd5b3e..9a10daf88 100644 --- a/infer/src/IR/Typ.re +++ b/infer/src/IR/Typ.re @@ -123,9 +123,11 @@ let ptr_kind_string = type static_length = option IntLit.t [@@deriving compare]; module T = { + type type_quals = {is_const: bool, is_volatile: bool} [@@deriving compare]; /** types for sil (structured) expressions */ - type t = + type t = {desc, quals: type_quals} [@@deriving compare] + and desc = | Tint ikind /** integer type */ | Tfloat fkind /** float type */ | Tvoid /** void type */ @@ -146,12 +148,33 @@ module T = { | NoTemplate | Template (QualifiedCppName.t, list (option t)) [@@deriving compare]; + let equal_desc = [%compare.equal : desc]; + let equal_quals = [%compare.equal : type_quals]; let equal = [%compare.equal : t]; let hash = Hashtbl.hash; }; include T; +let mk_type_quals ::default=? ::is_const=? ::is_volatile=? () => { + let default_ = {is_const: false, is_volatile: false}; + let mk_aux ::default=default_ ::is_const=default.is_const ::is_volatile=default.is_volatile () => { + is_const, + is_volatile + }; + mk_aux ::?default ::?is_const ::?is_volatile () +}; + +let is_const {is_const} => is_const; + +let is_volatile {is_volatile} => is_volatile; + +let mk ::default=? ::quals=? desc :t => { + let default_ = {desc, quals: mk_type_quals ()}; + let mk_aux ::default=default_ ::quals=default.quals desc => {desc, quals}; + mk_aux ::?default ::?quals desc +}; + module Name = { type t = name [@@deriving compare]; let equal = [%compare.equal : t]; @@ -253,8 +276,8 @@ module Tbl = Hashtbl.Make T; /** Pretty print a type with all the details, using the C syntax. */ -let rec pp_full pe f => - fun +let rec pp_full pe f {desc} => + switch desc { | Tstruct tname => if (Pp.equal_print_kind pe.Pp.kind Pp.HTML) { F.fprintf f "%s" (Name.name tname |> Escape.escape_xml) @@ -266,17 +289,17 @@ let rec pp_full pe f => | Tvoid => F.fprintf f "void" | Tfun false => F.fprintf f "_fn_" | Tfun true => F.fprintf f "_fn_noreturn_" - | Tptr ((Tarray _ | Tfun _) as typ) pk => + | Tptr ({desc: Tarray _ | Tfun _} as typ) pk => F.fprintf f "%a(%s)" (pp_full pe) typ (ptr_kind_string pk) | Tptr typ pk => F.fprintf f "%a%s" (pp_full pe) typ (ptr_kind_string pk) - | Tarray typ static_len => { - let pp_array_static_len fmt => ( - fun - | Some static_len => IntLit.pp fmt static_len - | None => F.fprintf fmt "_" - ); - F.fprintf f "%a[%a]" (pp_full pe) typ pp_array_static_len static_len - }; + | Tarray typ static_len => + let pp_array_static_len fmt => ( + fun + | Some static_len => IntLit.pp fmt static_len + | None => F.fprintf fmt "_" + ); + F.fprintf f "%a[%a]" (pp_full pe) typ pp_array_static_len static_len + }; /** Pretty print a type. Do nothing by default. */ @@ -300,10 +323,11 @@ let d_full (t: t) => L.add_print_action (L.PTtyp_full, Obj.repr t); /** dump a list of types. */ let d_list (tl: list t) => L.add_print_action (L.PTtyp_list, Obj.repr tl); -let name = - fun +let name typ => + switch typ.desc { | Tstruct name => Some name - | _ => None; + | _ => None + }; let unsome s => fun @@ -315,21 +339,23 @@ let unsome s => /** turn a *T into a T. fails if [typ] is not a pointer type */ -let strip_ptr = - fun +let strip_ptr typ => + switch typ.desc { | Tptr t _ => t - | _ => assert false; + | _ => assert false + }; /** If an array type, return the type of the element. If not, return the default type if given, otherwise raise an exception */ -let array_elem default_opt => - fun +let array_elem default_opt typ => + switch typ.desc { | Tarray t_el _ => t_el - | _ => unsome "array_elem" default_opt; + | _ => unsome "array_elem" default_opt + }; let is_class_of_kind check_fun typ => - switch typ { + switch typ.desc { | Tstruct tname => check_fun tname | _ => false }; @@ -341,13 +367,13 @@ let is_cpp_class = is_class_of_kind Name.Cpp.is_class; let is_java_class = is_class_of_kind Name.Java.is_class; let rec is_array_of_cpp_class typ => - switch typ { + switch typ.desc { | Tarray typ _ => is_array_of_cpp_class typ | _ => is_cpp_class typ }; let is_pointer_to_cpp_class typ => - switch typ { + switch typ.desc { | Tptr t _ => is_cpp_class t | _ => false }; @@ -364,23 +390,23 @@ let is_block_type typ => has_block_prefix (to_string typ); /** Java types by name */ -let rec java_from_string = +let rec java_from_string: string => t = fun | "" - | "void" => Tvoid - | "int" => Tint IInt - | "byte" => Tint IShort - | "short" => Tint IShort - | "boolean" => Tint IBool - | "char" => Tint IChar - | "long" => Tint ILong - | "float" => Tfloat FFloat - | "double" => Tfloat FDouble + | "void" => mk Tvoid + | "int" => mk (Tint IInt) + | "byte" => mk (Tint IShort) + | "short" => mk (Tint IShort) + | "boolean" => mk (Tint IBool) + | "char" => mk (Tint IChar) + | "long" => mk (Tint ILong) + | "float" => mk (Tfloat FFloat) + | "double" => mk (Tfloat FDouble) | typ_str when String.contains typ_str '[' => { let stripped_typ = String.sub typ_str pos::0 len::(String.length typ_str - 2); - Tptr (Tarray (java_from_string stripped_typ) None) Pk_pointer + mk (Tptr (mk (Tarray (java_from_string stripped_typ) None)) Pk_pointer) } - | typ_str => Tstruct (Name.Java.from_string typ_str); + | typ_str => mk (Tstruct (Name.Java.from_string typ_str)); type typ = t [@@deriving compare]; @@ -950,11 +976,13 @@ module Procname = { /** Return the return type of [pname_java]. */ -let java_proc_return_typ pname_java => - switch (java_from_string (Procname.java_get_return_type pname_java)) { - | Tstruct _ as typ => Tptr typ Pk_pointer - | typ => typ - }; +let java_proc_return_typ pname_java :t => { + let typ = java_from_string (Procname.java_get_return_type pname_java); + switch typ.desc { + | Tstruct _ => mk (Tptr typ Pk_pointer) + | _ => typ + } +}; module Struct = { type field = (Fieldname.t, T.t, Annot.Item.t) [@@deriving compare]; @@ -1032,7 +1060,7 @@ module Struct = { /** the element typ of the final extensible array in the given typ, if any */ let rec get_extensible_array_element_typ ::lookup (typ: T.t) => - switch typ { + switch typ.desc { | Tarray typ _ => Some typ | Tstruct name => switch (lookup name) { @@ -1048,7 +1076,7 @@ module Struct = { /** If a struct type with field f, return the type of f. If not, return the default */ let fld_typ ::lookup ::default fn (typ: T.t) => - switch typ { + switch typ.desc { | Tstruct name => switch (lookup name) { | Some {fields} => @@ -1059,9 +1087,9 @@ module Struct = { | _ => default }; let get_field_type_and_annotation ::lookup fn (typ: T.t) => - switch typ { + switch typ.desc { | Tstruct name - | Tptr (Tstruct name) _ => + | Tptr {desc: Tstruct name} _ => switch (lookup name) { | Some {fields, statics} => List.find_map @@ -1073,7 +1101,7 @@ module Struct = { let objc_ref_counter_annot = [({Annot.class_name: "ref_counter", parameters: []}, false)]; /** Field used for objective-c reference counting */ - let objc_ref_counter_field = (Fieldname.hidden, T.Tint IInt, objc_ref_counter_annot); + let objc_ref_counter_field = (Fieldname.hidden, mk (T.Tint IInt), objc_ref_counter_annot); let is_objc_ref_counter_field (fld, _, a) => Fieldname.is_hidden fld && Annot.Item.equal a objc_ref_counter_annot; }; diff --git a/infer/src/IR/Typ.rei b/infer/src/IR/Typ.rei index 20d5771ef..f73bc2ffc 100644 --- a/infer/src/IR/Typ.rei +++ b/infer/src/IR/Typ.rei @@ -69,9 +69,21 @@ let equal_ptr_kind: ptr_kind => ptr_kind => bool; /** statically determined length of an array type, if any */ type static_length = option IntLit.t [@@deriving compare]; +type type_quals [@@deriving compare]; + +let mk_type_quals: + default::type_quals? => is_const::bool? => is_volatile::bool? => unit => type_quals; + +let is_const: type_quals => bool; + +let is_volatile: type_quals => bool; + + +/** types for sil (structured) expressions */ /** types for sil (structured) expressions */ -type t = +type t = {desc, quals: type_quals} [@@deriving compare] +and desc = | Tint ikind /** integer type */ | Tfloat fkind /** float type */ | Tvoid /** void type */ @@ -93,6 +105,10 @@ and template_spec_info = | Template (QualifiedCppName.t, list (option t)) [@@deriving compare]; + +/** Create Typ.t from given desc. if [default] is passed then use its value to set other fields such as quals */ +let mk: default::t? => quals::type_quals? => desc => t; + module Name: { /** Named types. */ @@ -160,6 +176,10 @@ module Name: { /** Equality for types. */ let equal: t => t => bool; +let equal_desc: desc => desc => bool; + +let equal_quals: type_quals => type_quals => bool; + /** Sets of types. */ module Set: Caml.Set.S with type elt = t; diff --git a/infer/src/backend/Attribute.ml b/infer/src/backend/Attribute.ml index be294545a..2bd6bf705 100644 --- a/infer/src/backend/Attribute.ml +++ b/infer/src/backend/Attribute.ml @@ -228,8 +228,8 @@ let find_arithmetic_problem tenv proc_node_session prop exp = let rec walk = function | Exp.Var _ -> () | Exp.UnOp (Unop.Neg, e, Some ( - (Typ.Tint - (Typ.IUChar | Typ.IUInt | Typ.IUShort | Typ.IULong | Typ.IULongLong) as typ))) -> + ({Typ.desc=Tint + (Typ.IUChar | Typ.IUInt | Typ.IUShort | Typ.IULong | Typ.IULongLong)} as typ))) -> uminus_unsigned := (e, typ) :: !uminus_unsigned | Exp.UnOp(_, e, _) -> walk e | Exp.BinOp(op, e1, e2) -> @@ -319,7 +319,7 @@ let find_equal_formal_path tenv e prop = match strexp with | Sil.Eexp (exp2, _) when Exp.equal exp2 e -> (match find_in_sigma exp1 seen_hpreds with - | Some vfs -> Some (Exp.Lfield (vfs, field, Typ.Tvoid)) + | Some vfs -> Some (Exp.Lfield (vfs, field, Typ.mk Tvoid)) | None -> None) | _ -> None) fields ~init:None | _ -> None) prop.Prop.sigma ~init:None in diff --git a/infer/src/backend/BuiltinDefn.ml b/infer/src/backend/BuiltinDefn.ml index f46c58635..8199f0222 100644 --- a/infer/src/backend/BuiltinDefn.ml +++ b/infer/src/backend/BuiltinDefn.ml @@ -41,13 +41,13 @@ let mk_empty_array_rearranged len = let extract_array_type typ = if (Config.curr_language_is Config.Java) then - match typ with - | Typ.Tptr (Typ.Tarray _ as arr, _) -> Some arr + match typ.Typ.desc with + | Typ.Tptr ({Typ.desc=Tarray _} as arr, _) -> Some arr | _ -> None else - match typ with - | Typ.Tarray _ as arr -> Some arr - | Typ.Tptr (elt, _) -> Some (Typ.Tarray (elt, None)) + match typ.Typ.desc with + | Typ.Tarray _ -> Some typ + | Typ.Tptr (elt, _) -> Some (Typ.mk ~default:typ (Tarray (elt, None))) | _ -> None (** Return a result from a procedure call. *) @@ -155,7 +155,7 @@ let create_type tenv n_lexp typ prop = prop | None -> let mhpred = - match typ with + match typ.Typ.desc with | Typ.Tptr (typ', _) -> let sexp = Sil.Estruct ([], Sil.inst_none) in let texp = Exp.Sizeof (typ', None, Subtype.subtypes) in @@ -237,7 +237,7 @@ let execute___instanceof_cast ~instof let val1, prop__ = check_arith_norm_exp tenv pname val1_ prop_ in let texp2, prop = check_arith_norm_exp tenv pname texp2_ prop__ in let is_cast_to_reference = - match typ1 with + match typ1.desc with | Typ.Tptr (_, Typ.Pk_reference) -> true | _ -> false in (* In Java, we throw an exception, in C++ we return 0 in case of a cast to a pointer, *) @@ -457,7 +457,7 @@ let execute___objc_counter_update { Builtin.pdesc; tenv; prop_; path; args; loc; } : Builtin.ret_typ = match args with - | [(lexp, (Typ.Tstruct _ as typ | Tptr (Tstruct _ as typ, _)))] -> + | [(lexp, ({Typ.desc=Tstruct _} as typ | {desc=Tptr ({desc=Tstruct _} as typ, _)}))] -> (* Assumes that lexp is a temp n$1 that has the value of the object. *) (* This is the case as a call f(o) it's translates as n$1=*&o; f(n$1) *) (* n$2 = *n$1.hidden *) @@ -480,7 +480,7 @@ let execute___objc_counter_update removed from the list of args. *) let get_suppress_npe_flag args = match args with - | (Exp.Const (Const.Cint i), Typ.Tint Typ.IBool):: args' when IntLit.isone i -> + | (Exp.Const (Const.Cint i), {Typ.desc=Tint Typ.IBool}):: args' when IntLit.isone i -> false, args' (* this is a CFRelease/CFRetain *) | _ -> true, args @@ -750,13 +750,13 @@ let execute_alloc mk can_return_null Exp.BinOp (bop, evaluate_char_sizeof e1', evaluate_char_sizeof e2') | Exp.Exn _ | Exp.Closure _ | Exp.Const _ | Exp.Cast _ | Exp.Lvar _ | Exp.Lfield _ | Exp.Lindex _ -> e - | Exp.Sizeof (Typ.Tarray (Typ.Tint ik, _), Some len, _) when Typ.ikind_is_char ik -> + | Exp.Sizeof ({Typ.desc=Tarray ({Typ.desc=Tint ik}, _)}, Some len, _) when Typ.ikind_is_char ik -> evaluate_char_sizeof len - | Exp.Sizeof (Typ.Tarray (Typ.Tint ik, Some len), None, _) when Typ.ikind_is_char ik -> + | Exp.Sizeof ({Typ.desc=Tarray ({Typ.desc=Tint ik}, Some len)}, None, _) when Typ.ikind_is_char ik -> evaluate_char_sizeof (Exp.Const (Const.Cint len)) | Exp.Sizeof _ -> e in let size_exp, procname = match args with - | [(Exp.Sizeof (Tstruct (ObjcClass _ as name) as s, len, subt), _)] -> + | [(Exp.Sizeof ({Typ.desc=Tstruct (ObjcClass _ as name)} as s, len, subt), _)] -> let struct_type = match AttributesTable.get_correct_type_from_objc_class_name name with | Some struct_type -> struct_type @@ -776,7 +776,7 @@ let execute_alloc mk can_return_null let n_size_exp' = evaluate_char_sizeof n_size_exp in Prop.exp_normalize_prop tenv prop n_size_exp', prop in let cnt_te = - Exp.Sizeof (Typ.Tarray (Typ.Tint Typ.IChar, None), Some size_exp', Subtype.exact) in + Exp.Sizeof (Typ.mk (Tarray (Typ.mk (Tint Typ.IChar), None)), Some size_exp', Subtype.exact) in let id_new = Ident.create_fresh Ident.kprimed in let exp_new = Exp.Var id_new in let ptsto_new = @@ -817,7 +817,7 @@ let execute___cxx_typeid ({ Builtin.pdesc; tenv; prop_; args; loc} as r) ~default:typ_ in let typ_string = Typ.to_string typ in let set_instr = - Sil.Store (field_exp, Typ.Tvoid, Exp.Const (Const.Cstr typ_string), loc) in + Sil.Store (field_exp, Typ.mk Tvoid, Exp.Const (Const.Cstr typ_string), loc) in SymExec.instrs ~mask_errors:true tenv pdesc [set_instr] res | _ -> res) | _ -> raise (Exceptions.Wrong_argument_number __POS__) @@ -933,7 +933,7 @@ let execute___infer_fail { Builtin.pdesc; tenv; prop_; path; args; loc; } | _ -> raise (Exceptions.Wrong_argument_number __POS__) in let set_instr = - Sil.Store (Exp.Lvar Sil.custom_error, Typ.Tvoid, Exp.Const (Const.Cstr error_str), loc) in + Sil.Store (Exp.Lvar Sil.custom_error, Typ.mk Tvoid, Exp.Const (Const.Cstr error_str), loc) in SymExec.instrs ~mask_errors:true tenv pdesc [set_instr] [(prop_, path)] (* translate builtin assertion failure *) @@ -946,18 +946,18 @@ let execute___assert_fail { Builtin.pdesc; tenv; prop_; path; args; loc; } | _ -> raise (Exceptions.Wrong_argument_number __POS__) in let set_instr = - Sil.Store (Exp.Lvar Sil.custom_error, Typ.Tvoid, Exp.Const (Const.Cstr error_str), loc) in + Sil.Store (Exp.Lvar Sil.custom_error, Typ.mk Tvoid, Exp.Const (Const.Cstr error_str), loc) in SymExec.instrs ~mask_errors:true tenv pdesc [set_instr] [(prop_, path)] let execute_objc_alloc_no_fail symb_state typ alloc_fun_opt { Builtin.pdesc; tenv; ret_id; loc; } = let alloc_fun = Exp.Const (Const.Cfun BuiltinDecl.__objc_alloc_no_fail) in - let ptr_typ = Typ.Tptr (typ, Typ.Pk_pointer) in + let ptr_typ = Typ.mk (Tptr (typ, Typ.Pk_pointer)) in let sizeof_typ = Exp.Sizeof (typ, None, Subtype.exact) in let alloc_fun_exp = match alloc_fun_opt with - | Some pname -> [Exp.Const (Const.Cfun pname), Typ.Tvoid] + | Some pname -> [Exp.Const (Const.Cfun pname), Typ.mk Tvoid] | None -> [] in let alloc_instr = Sil.Call @@ -969,7 +969,7 @@ let execute_objc_NSArray_alloc_no_fail builtin_args symb_state pname = let ret_typ = match builtin_args.Builtin.ret_id with | Some (_, typ) -> typ - | None -> Typ.Tptr (Tvoid, Pk_pointer) in + | None -> Typ.mk (Tptr (Typ.mk Tvoid, Pk_pointer)) in execute_objc_alloc_no_fail symb_state ret_typ (Some pname) builtin_args let execute_NSArray_arrayWithObjects_count builtin_args = @@ -988,7 +988,7 @@ let execute_objc_NSDictionary_alloc_no_fail symb_state pname builtin_args = let ret_typ = match builtin_args.Builtin.ret_id with | Some (_, typ) -> typ - | None -> Typ.Tptr (Tvoid, Pk_pointer) in + | None -> Typ.mk (Tptr (Typ.mk Tvoid, Pk_pointer)) in execute_objc_alloc_no_fail symb_state ret_typ (Some pname) builtin_args let execute___objc_dictionary_literal builtin_args = diff --git a/infer/src/backend/abs.ml b/infer/src/backend/abs.ml index c86edb0e6..b1eaef384 100644 --- a/infer/src/backend/abs.ml +++ b/infer/src/backend/abs.ml @@ -407,17 +407,17 @@ let mk_rules_for_dll tenv (para : Sil.hpara_dll) : rule list = (****************** Start of Predicate Discovery ******************) let typ_get_recursive_flds tenv typ_exp = let filter typ (_, (t: Typ.t), _) = - match t with + match t.desc with | Tstruct _ | Tint _ | Tfloat _ | Tvoid | Tfun _ -> false - | Tptr (Tstruct _ as typ', _) -> + | Tptr ({desc=Tstruct _} as typ', _) -> Typ.equal typ' typ | Tptr _ | Tarray _ -> false in match typ_exp with | Exp.Sizeof (typ, _, _) -> ( - match typ with + match typ.desc with | Tstruct name -> ( match Tenv.lookup tenv name with | Some { fields } -> List.map ~f:fst3 (List.filter ~f:(filter typ) fields) @@ -988,7 +988,7 @@ let remove_opt _prop = let cycle_has_weak_or_unretained_or_assign_field tenv cycle = (* returns items annotation for field fn in struct t *) let get_item_annotation (t: Typ.t) fn = - match t with + match t.desc with | Tstruct name -> ( let equal_fn (fn', _, _) = Fieldname.equal fn fn' in match Tenv.lookup tenv name with diff --git a/infer/src/backend/absarray.ml b/infer/src/backend/absarray.ml index 141379fbb..5213fd273 100644 --- a/infer/src/backend/absarray.ml +++ b/infer/src/backend/absarray.ml @@ -71,7 +71,7 @@ end = struct L.d_str "t: "; Typ.d_full t; L.d_ln (); assert false in - match se, t, syn_offs with + match se, t.desc, syn_offs with | _, _, [] -> (se, t) | Sil.Estruct (fsel, _), Tstruct name, Field (fld, _) :: syn_offs' -> ( match Tenv.lookup tenv name with @@ -92,7 +92,7 @@ end = struct (** Replace a strexp at the given syntactic offset list *) let rec replace_strexp_at_syn_offsets tenv se (t: Typ.t) syn_offs update = - match se, t, syn_offs with + match se, t.desc, syn_offs with | _, _, [] -> update se | Sil.Estruct (fsel, inst), Tstruct name, Field (fld, _) :: syn_offs' -> ( @@ -163,7 +163,7 @@ end = struct let path = (root, offs') in if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found else begin - match se, typ with + match se, typ.desc with | Sil.Estruct (fsel, _), Tstruct name -> ( match Tenv.lookup tenv name with | Some { fields } -> @@ -442,8 +442,8 @@ let keep_only_indices tenv (** If the type is array, check whether we should do abstraction *) -let array_typ_can_abstract = function - | Typ.Tarray (Typ.Tptr (Typ.Tfun _, _), _) -> false (* don't abstract arrays of pointers *) +let array_typ_can_abstract {Typ.desc} = match desc with + | Tarray ({desc=Tptr ({desc=Tfun _}, _)}, _) -> false (* don't abstract arrays of pointers *) | _ -> true (** This function checks whether we can apply an abstraction to a strexp *) @@ -540,7 +540,7 @@ let check_after_array_abstraction tenv prop = let rec check_se root offs typ = function | Sil.Eexp _ -> () | Sil.Earray (_, esel, _) -> (* check that no more than 2 elements are in the array *) - let typ_elem = Typ.array_elem (Some Typ.Tvoid) typ in + let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ in if List.length esel > 2 && array_typ_can_abstract typ then if List.for_all ~f:(check_index root offs) esel then () else report_error prop @@ -549,11 +549,11 @@ let check_after_array_abstraction tenv prop = esel | Sil.Estruct (fsel, _) -> List.iter ~f:(fun (f, se) -> - let typ_f = Typ.Struct.fld_typ ~lookup ~default:Tvoid f typ in + let typ_f = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f typ in check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in let check_hpred = function | Sil.Hpointsto (root, se, texp) -> - let typ = Exp.texp_to_typ (Some Typ.Tvoid) texp in + let typ = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp in check_se root [] typ se | Sil.Hlseg _ | Sil.Hdllseg _ -> () in let check_sigma sigma = List.iter ~f:check_hpred sigma in diff --git a/infer/src/backend/dom.ml b/infer/src/backend/dom.ml index c3ce080b6..ca61c2fa1 100644 --- a/infer/src/backend/dom.ml +++ b/infer/src/backend/dom.ml @@ -995,13 +995,14 @@ and static_length_partial_join l1 l2 = and dynamic_length_partial_join l1 l2 = option_partial_join (fun len1 len2 -> Some (length_partial_join len1 len2)) l1 l2 -and typ_partial_join t1 t2 = match t1, t2 with - | Typ.Tptr (t1, pk1), Typ.Tptr (t2, pk2) when Typ.equal_ptr_kind pk1 pk2 -> - Typ.Tptr (typ_partial_join t1 t2, pk1) - | Typ.Tarray (typ1, len1), Typ.Tarray (typ2, len2) -> +and typ_partial_join (t1 : Typ.t) (t2 : Typ.t) = match t1.desc, t2.desc with + | Typ.Tptr (t1, pk1), Typ.Tptr (t2, pk2) + when Typ.equal_ptr_kind pk1 pk2 && Typ.equal_quals t1.quals t2.quals -> + Typ.mk ~default:t1 (Tptr (typ_partial_join t1 t2, pk1)) (* quals are the same for t1 and t2 *) + | Typ.Tarray (typ1, len1), Typ.Tarray (typ2, len2) when Typ.equal_quals typ1.quals typ2.quals -> let t = typ_partial_join typ1 typ2 in let len = static_length_partial_join len1 len2 in - Typ.Tarray (t, len) + Typ.mk ~default:t1 (Tarray (t, len)) (* quals are the same for t1 and t2 *) | _ when Typ.equal t1 t2 -> t1 (* common case *) | _ -> L.d_str "typ_partial_join no match "; diff --git a/infer/src/backend/dotty.ml b/infer/src/backend/dotty.ml index 7c44305e3..55ab9aae7 100644 --- a/infer/src/backend/dotty.ml +++ b/infer/src/backend/dotty.ml @@ -298,7 +298,7 @@ let rec dotty_mk_node pe sigma = let n = !dotty_state_count in incr dotty_state_count; let do_hpred_lambda exp_color = function - | (Sil.Hpointsto (e, Sil.Earray (e', l, _), Exp.Sizeof (Typ.Tarray (t, _), _, _)), lambda) -> + | (Sil.Hpointsto (e, Sil.Earray (e', l, _), Exp.Sizeof ({Typ.desc=Tarray (t, _)}, _, _)), lambda) -> incr dotty_state_count; (* increment once more n+1 is the box for the array *) let e_color_str = color_to_str (exp_color e) in let e_color_str'= color_to_str (exp_color e') in diff --git a/infer/src/backend/errdesc.ml b/infer/src/backend/errdesc.ml index e17ef79e3..640d0f0c8 100644 --- a/infer/src/backend/errdesc.ml +++ b/infer/src/backend/errdesc.ml @@ -511,9 +511,9 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = (Pvar.is_local pvar || Pvar.is_global pvar) && not (Pvar.is_frontend_tmp pvar) && match hpred_typ_opt, find_typ_without_ptr prop pvar with - | Some (Exp.Sizeof (t1, _, _)), Some (Exp.Sizeof (Typ.Tptr (t2, _), _, _)) -> + | Some (Exp.Sizeof (t1, _, _)), Some (Exp.Sizeof ({Typ.desc=Tptr (t2, _)}, _, _)) -> Typ.equal t1 t2 - | Some (Exp.Sizeof (Typ.Tint _, _, _)), Some (Exp.Sizeof (Typ.Tint _, _, _)) + | Some (Exp.Sizeof ({Typ.desc=Tint _}, _, _)), Some (Exp.Sizeof ({Typ.desc=Tint _}, _, _)) when is_file -> (* must be a file opened with "open" *) true | _ -> false in @@ -581,7 +581,7 @@ let vpath_find tenv prop _exp : DExp.t option * Typ.t option = (match lexp with | Exp.Lvar pv -> let typo = match texp with - | Exp.Sizeof (Tstruct name, _, _) -> ( + | Exp.Sizeof ({Typ.desc=Tstruct name}, _, _) -> ( match Tenv.lookup tenv name with | Some {fields} -> List.find ~f:(fun (f', _, _) -> Fieldname.equal f' f) fields |> diff --git a/infer/src/backend/interproc.ml b/infer/src/backend/interproc.ml index 22851f7a9..fa5303a45 100644 --- a/infer/src/backend/interproc.ml +++ b/infer/src/backend/interproc.ml @@ -664,7 +664,7 @@ let report_context_leaks pname sigma tenv = | Some path -> path | None -> assert false (* a path must exist in order for a leak to be reported *) in let err_desc = - Errdesc.explain_context_leak pname (Typ.Tstruct name) fld_name leak_path in + Errdesc.explain_context_leak pname (Typ.mk (Tstruct name)) fld_name leak_path in let exn = Exceptions.Context_leak (err_desc, __POS__) in Reporting.log_error pname exn) context_exps in @@ -672,7 +672,7 @@ let report_context_leaks pname sigma tenv = let context_exps = List.fold ~f:(fun exps hpred -> match hpred with - | Sil.Hpointsto (_, Eexp (exp, _), Sizeof (Tptr (Tstruct name, _), _, _)) + | Sil.Hpointsto (_, Eexp (exp, _), Sizeof ({desc=Tptr ({desc=Tstruct name}, _)}, _, _)) when not (Exp.is_null_literal exp) && AndroidFramework.is_context tenv name && not (AndroidFramework.is_application tenv name) -> diff --git a/infer/src/backend/preanal.ml b/infer/src/backend/preanal.ml index 9ad592faf..55df2de96 100644 --- a/infer/src/backend/preanal.ml +++ b/infer/src/backend/preanal.ml @@ -30,7 +30,7 @@ let add_dispatch_calls pdesc cg tenv = when call_flags_is_dispatch call_flags -> (* the frontend should not populate the list of targets *) assert (List.is_empty call_flags.CallFlags.cf_targets); - let receiver_typ_no_ptr = match receiver_typ with + let receiver_typ_no_ptr = match receiver_typ.Typ.desc with | Typ.Tptr (typ', _) -> typ' | _ -> diff --git a/infer/src/backend/prop.ml b/infer/src/backend/prop.ml index ecdc067c4..16761180f 100644 --- a/infer/src/backend/prop.ml +++ b/infer/src/backend/prop.ml @@ -466,12 +466,12 @@ let rec create_strexp_of_type tenv struct_init_mode (typ : Typ.t) len inst : Sil if Config.curr_language_is Config.Java && Sil.equal_inst inst Sil.Ialloc then - match typ with + match typ.desc with | Tfloat _ -> Exp.Const (Cfloat 0.0) | _ -> Exp.zero else create_fresh_var () in - match typ, len with + match typ.desc, len with | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _), None -> Eexp (init_value (), inst) | Tstruct name, _ -> ( @@ -529,7 +529,7 @@ let rec pi_sorted_remove_redundant (pi : pi) = match pi with let sigma_get_unsigned_exps sigma = let uexps = ref [] in let do_hpred (hpred : Sil.hpred) = match hpred with - | Hpointsto (_, Eexp (e, _), Sizeof (Tint ik, _, _)) + | Hpointsto (_, Eexp (e, _), Sizeof ({desc=Tint ik}, _, _)) when Typ.ikind_is_unsigned ik -> uexps := e :: !uexps | _ -> () in @@ -541,13 +541,13 @@ let sigma_get_unsigned_exps sigma = to ensure the soundness of this collapsing. *) let exp_collapse_consecutive_indices_prop (typ : Typ.t) exp = let typ_is_base (typ1 : Typ.t) = - match typ1 with + match typ1.desc with | Tint _ | Tfloat _ | Tstruct _ | Tvoid | Tfun _ -> true | _ -> false in let typ_is_one_step_from_base = - match typ with + match typ.desc with | Tptr (t, _) | Tarray (t, _) -> typ_is_base t | _ -> @@ -712,10 +712,10 @@ module Normalize = struct Closure { c with captured_vars; } | Const _ -> e - | Sizeof (Tarray (Tint ik, _), Some l, _) + | Sizeof ({desc=Tarray ({desc=Tint ik}, _)}, Some l, _) when Typ.ikind_is_char ik && Config.curr_language_is Config.Clang -> eval l - | Sizeof (Tarray (Tint ik, Some l), _, _) + | Sizeof ({desc=Tarray ({desc=Tint ik}, Some l)}, _, _) when Typ.ikind_is_char ik && Config.curr_language_is Config.Clang -> Const (Cint l) | Sizeof _ -> @@ -991,11 +991,11 @@ module Normalize = struct Exp.int (IntLit.div n m) | Const (Cfloat v), Const (Cfloat w) -> Exp.float (v /.w) - | Sizeof (Tarray (elt, _), Some len, _), Sizeof (elt2, None, _) + | Sizeof ({desc=Tarray (elt, _)}, Some len, _), Sizeof (elt2, None, _) (* pattern: sizeof(elt[len]) / sizeof(elt) = len *) when Typ.equal elt elt2 -> len - | Sizeof (Tarray (elt, Some len), None, _), Sizeof (elt2, None, _) + | Sizeof ({desc=Tarray (elt, Some len)}, None, _), Sizeof (elt2, None, _) (* pattern: sizeof(elt[len]) / sizeof(elt) = len *) when Typ.equal elt elt2 -> Const (Cint len) @@ -1372,28 +1372,28 @@ module Normalize = struct let normalized_cnt = strexp_normalize tenv sub cnt in let normalized_te = texp_normalize tenv sub te in begin match normalized_cnt, normalized_te with - | Earray (Exp.Sizeof _ as size, [], inst), Sizeof (Tarray _, _, _) -> + | Earray (Exp.Sizeof _ as size, [], inst), Sizeof ({desc=Tarray _}, _, _) -> (* check for an empty array whose size expression is (Sizeof type), and turn the array into a strexp of the given type *) let hpred' = mk_ptsto_exp tenv Fld_init (root, size, None) inst in replace_hpred hpred' | Earray (BinOp (Mult, Sizeof (t, None, st1), x), esel, inst), - Sizeof (Tarray (elt, _) as arr, _, _) when Typ.equal t elt -> + Sizeof ({desc=Tarray (elt, _)} as arr, _, _) when Typ.equal t elt -> let len = Some x in let hpred' = mk_ptsto_exp tenv Fld_init (root, Sizeof (arr, len, st1), None) inst in replace_hpred (replace_array_contents hpred' esel) | Earray (BinOp (Mult, x, Sizeof (t, None, st1)), esel, inst), - Sizeof (Tarray (elt, _) as arr, _, _) when Typ.equal t elt -> + Sizeof ({desc=Tarray (elt, _)} as arr, _, _) when Typ.equal t elt -> let len = Some x in let hpred' = mk_ptsto_exp tenv Fld_init (root, Sizeof (arr, len, st1), None) inst in replace_hpred (replace_array_contents hpred' esel) | Earray (BinOp (Mult, Sizeof (t, Some len, st1), x), esel, inst), - Sizeof (Tarray (elt, _) as arr, _, _) when Typ.equal t elt -> + Sizeof ({desc=Tarray (elt, _)} as arr, _, _) when Typ.equal t elt -> let len = Some (Exp.BinOp(Mult, x, len)) in let hpred' = mk_ptsto_exp tenv Fld_init (root, Sizeof (arr, len, st1), None) inst in replace_hpred (replace_array_contents hpred' esel) | Earray (BinOp (Mult, x, Sizeof (t, Some len, st1)), esel, inst), - Sizeof (Tarray (elt, _) as arr, _, _) when Typ.equal t elt -> + Sizeof ({desc=Tarray (elt, _)} as arr, _, _) when Typ.equal t elt -> let len = Some (Exp.BinOp(Mult, x, len)) in let hpred' = mk_ptsto_exp tenv Fld_init (root, Sizeof (arr, len, st1), None) inst in replace_hpred (replace_array_contents hpred' esel) diff --git a/infer/src/backend/prover.ml b/infer/src/backend/prover.ml index 566956c69..76fd2566d 100644 --- a/infer/src/backend/prover.ml +++ b/infer/src/backend/prover.ml @@ -37,7 +37,7 @@ let rec remove_redundancy have_same_key acc = function else remove_redundancy have_same_key (x:: acc) l let rec is_java_class tenv (typ: Typ.t) = - match typ with + match typ.desc with | Tstruct name -> Typ.Name.Java.is_class name | Tarray (inner_typ, _) | Tptr (inner_typ, _) -> is_java_class tenv inner_typ | _ -> false @@ -170,7 +170,7 @@ end = struct end (** Return true if the two types have sizes which can be compared *) -let type_size_comparable t1 t2 = match t1, t2 with +let type_size_comparable t1 t2 = match t1.Typ.desc, t2.Typ.desc with | Typ.Tint _, Typ.Tint _ -> true | _ -> false @@ -187,7 +187,7 @@ let type_size_compare t1 t2 = let n1 = ik_size ik1 in let n2 = ik_size ik2 in n1 - n2 in - match t1, t2 with + match t1.Typ.desc, t2.Typ.desc with | Typ.Tint ik1, Typ.Tint ik2 -> Some (ik_compare ik1 ik2) | _ -> None @@ -380,7 +380,7 @@ end = struct let add_lt_minus1_e e = lts := (Exp.minus_one, e)::!lts in let type_opt_is_unsigned = function - | Some Typ.Tint ik -> Typ.ikind_is_unsigned ik + | Some {Typ.desc=Tint ik} -> Typ.ikind_is_unsigned ik | _ -> false in let type_of_texp = function | Exp.Sizeof (t, _, _) -> Some t @@ -400,7 +400,7 @@ end = struct List.iter ~f:(fun (f, se) -> strexp_extract (se, get_field_type f)) fsel | Sil.Earray (len, isel, _), t -> let elt_t = match t with - | Some Typ.Tarray (t, _) -> Some t + | Some {Typ.desc=Tarray (t, _)} -> Some t | _ -> None in add_lt_minus1_e len; List.iter ~f:(fun (idx, se) -> @@ -1339,11 +1339,12 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 : sexp_imply tenv source calc_index_frame calc_missing subs se1' se2 typ2 | Sil.Earray (len, _, _), Sil.Eexp (_, inst) -> let se2' = Sil.Earray (len, [(Exp.zero, se2)], inst) in - let typ2' = Typ.Tarray (typ2, None) in + let typ2' = Typ.mk (Tarray (typ2, None)) in (* In the sexp_imply, struct_imply, array_imply, and sexp_imply_nolhs functions, the typ2 argument is only used by eventually passing its value to Typ.Struct.fld, Exp.Lfield, Typ.Struct.fld, or Typ.array_elem. None of these are sensitive to the length field - of Tarray, so forgetting the length of typ2' here is not a problem. *) + of Tarray, so forgetting the length of typ2' here is not a problem. Not one of those + functions use typ.quals either *) sexp_imply tenv source true calc_missing subs se1 se2' typ2' (* calculate index_frame because the rhs is a singleton array *) | _ -> d_impl_err ("sexp_imply not implemented", subs, (EXC_FALSE_SEXPS (se1, se2))); @@ -1357,7 +1358,7 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Fie begin match Fieldname.compare f1 f2 with | 0 -> - let typ' = Typ.Struct.fld_typ ~lookup ~default:Typ.Tvoid f2 typ2 in + let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in let subs', se_frame, se_missing = sexp_imply tenv (Exp.Lfield (source, f2, typ2)) false calc_missing subs se1 se2 typ' in let subs'', fld_frame, fld_missing = struct_imply tenv source calc_missing subs' fsel1' fsel2' typ2 in @@ -1372,7 +1373,7 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Fie let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs fsel1' fsel2 typ2 in subs', ((f1, se1) :: fld_frame), fld_missing | _ -> - let typ' = Typ.Struct.fld_typ ~lookup ~default:Typ.Tvoid f2 typ2 in + let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in let subs' = sexp_imply_nolhs tenv (Exp.Lfield (source, f2, typ2)) calc_missing subs se2 typ' in let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs' fsel1 fsel2' typ2 in @@ -1380,7 +1381,7 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Fie subs', fld_frame, fld_missing' end | [], (f2, se2) :: fsel2' -> - let typ' = Typ.Struct.fld_typ ~lookup ~default:Typ.Tvoid f2 typ2 in + let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in let subs' = sexp_imply_nolhs tenv (Exp.Lfield (source, f2, typ2)) calc_missing subs se2 typ' in let subs'', fld_frame, fld_missing = struct_imply tenv source calc_missing subs' [] fsel2' typ2 in subs'', fld_frame, (f2, se2):: fld_missing @@ -1388,7 +1389,7 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Fie and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2 : subst2 * ((Exp.t * Sil.strexp) list) * ((Exp.t * Sil.strexp) list) = - let typ_elem = Typ.array_elem (Some Typ.Tvoid) typ2 in + let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ2 in match esel1, esel2 with | _,[] -> subs, esel1, [] | (e1, se1) :: esel1', (e2, se2) :: esel2' -> @@ -1498,7 +1499,7 @@ let expand_hpred_pointer = | Sil.Hpointsto (Lfield (adr_base, fld, adr_typ), cnt, cnt_texp) -> let cnt_texp' = match - match adr_typ with + match adr_typ.desc with | Tstruct name -> ( match Tenv.lookup tenv name with | Some _ -> @@ -1518,7 +1519,7 @@ let expand_hpred_pointer = incr count ; let fields = [(fld, cnt_typ, Annot.Item.empty)] in ignore (Tenv.mk_struct tenv ~fields name) ; - Exp.Sizeof (Tstruct name, len, st) + Exp.Sizeof (Typ.mk (Tstruct name), len, st) | _ -> (* type of struct at adr_base and of contents are both unknown: give up *) raise (Failure "expand_hpred_pointer: Unexpected non-sizeof type in Lfield") in @@ -1526,7 +1527,7 @@ let expand_hpred_pointer = expand true true hpred' | Sil.Hpointsto (Exp.Lindex (e, ind), se, t) -> let t' = match t with - | Exp.Sizeof (t_, len, st) -> Exp.Sizeof (Typ.Tarray (t_, None), len, st) + | Exp.Sizeof (t_, len, st) -> Exp.Sizeof (Typ.mk (Tarray (t_, None)), len, st) | _ -> raise (Failure "expand_hpred_pointer: Unexpected non-sizeof type in Lindex") in let len = match t' with | Exp.Sizeof (_, Some len, _) -> len @@ -1547,7 +1548,7 @@ struct (** check that t1 and t2 are the same primitive type *) let check_subtype_basic_type t1 t2 = - match t2 with + match t2.Typ.desc with | Typ.Tint Typ.IInt | Typ.Tint Typ.IBool | Typ.Tint Typ.IChar | Typ.Tfloat Typ.FDouble | Typ.Tfloat Typ.FFloat | Typ.Tint Typ.ILong @@ -1556,7 +1557,7 @@ struct (** check if t1 is a subtype of t2, in Java *) let rec check_subtype_java tenv (t1: Typ.t) (t2: Typ.t) = - match t1, t2 with + match t1.Typ.desc, t2.Typ.desc with | Tstruct (JavaClass _ as cn1), Tstruct (JavaClass _ as cn2) -> Subtype.is_known_subtype tenv cn1 cn2 | Tarray (dom_type1, _), Tarray (dom_type2, _) -> @@ -1580,7 +1581,7 @@ struct | _ -> false let rec case_analysis_type tenv ((t1: Typ.t), st1) ((t2: Typ.t), st2) = - match t1, t2 with + match t1.desc, t2.desc with | Tstruct (JavaClass _ as cn1), Tstruct (JavaClass _ as cn2) -> Subtype.case_analysis tenv (cn1, st1) (cn2, st2) | Tstruct (JavaClass _ as cn1), Tarray _ @@ -1642,7 +1643,7 @@ let cast_exception tenv texp1 texp2 e1 subs = Note: [pname] wil never be included in the returned result *) let get_overrides_of tenv supertype pname = let typ_has_method pname (typ: Typ.t) = - match typ with + match typ.desc with | Tstruct name -> ( match Tenv.lookup tenv name with | Some { methods } -> @@ -1652,7 +1653,7 @@ let get_overrides_of tenv supertype pname = ) | _ -> false in let gather_overrides tname _ overrides_acc = - let typ = Typ.Tstruct tname in + let typ = Typ.mk (Tstruct tname) in (* TODO shouldn't really create type here...*) (* get all types in the type environment that are non-reflexive subtypes of [supertype] *) if not (Typ.equal typ supertype) && Subtyping_check.check_subtype tenv typ supertype then (* only select the ones that implement [pname] as overrides *) @@ -1677,7 +1678,7 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing = let types_subject_to_dynamic_cast = match texp1, texp2 with | Exp.Sizeof (typ1, _, _), Exp.Sizeof (typ2, _, _) -> ( - match typ1, typ2 with + match typ1.desc, typ2.desc with | (Tstruct _ | Tarray _), (Tstruct _ | Tarray _) -> is_java_class tenv typ1 || (Typ.is_cpp_class typ1 && Typ.is_cpp_class typ2) @@ -1742,7 +1743,7 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2 | _ -> false in if List.exists ~f:filter sigma2 then !sub_opt else None in let add_subtype () = match texp1, texp2, se1, se2 with - | Exp.Sizeof (Tptr (t1, _), None, _), Exp.Sizeof (Tptr (t2, _), None, _), + | Exp.Sizeof ({desc=Tptr (t1, _)}, None, _), Exp.Sizeof ({desc=Tptr (t2, _)}, None, _), Sil.Eexp (e1', _), Sil.Eexp (e2', _) when not (is_allocated_lhs e1') -> begin @@ -1783,7 +1784,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 (match Prop.prop_iter_current tenv iter1' with | Sil.Hpointsto (e1, se1, texp1), _ -> (try - let typ2 = Exp.texp_to_typ (Some Typ.Tvoid) texp2 in + let typ2 = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp2 in let typing_frame, typing_missing = texp_imply tenv subs texp1 texp2 e1 calc_missing in let se1' = sexp_imply_preprocess se1 texp1 se2 in let subs', fld_frame, fld_missing = sexp_imply tenv e1 calc_index_frame calc_missing subs se1' se2 typ2 in @@ -1988,10 +1989,10 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * let const_string_texp = match !Config.curr_language with | Config.Clang -> - Exp.Sizeof (Typ.Tarray (Typ.Tint Typ.IChar, Some len), None, Subtype.exact) + Exp.Sizeof (Typ.mk (Tarray (Typ.mk (Tint Typ.IChar), Some len)), None, Subtype.exact) | Config.Java -> let object_type = Typ.Name.Java.from_string "java.lang.String" in - Exp.Sizeof (Tstruct object_type, None, Subtype.exact) in + Exp.Sizeof (Typ.mk (Tstruct object_type), None, Subtype.exact) in Sil.Hpointsto (root, sexp, const_string_texp) in let mk_constant_class_hpred s = (* creat an hpred from a constant class *) let root = Exp.Const (Const.Cclass (Ident.string_to_name s)) in @@ -2001,7 +2002,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * Sil.Eexp ((Exp.Const (Const.Cstr s), Sil.Inone)))], Sil.inst_none) in let class_texp = let class_type = Typ.Name.Java.from_string "java.lang.Class" in - Exp.Sizeof (Tstruct class_type, None, Subtype.exact) in + Exp.Sizeof (Typ.mk (Tstruct class_type), None, Subtype.exact) in Sil.Hpointsto (root, sexp, class_texp) in try (match move_primed_lhs_from_front subs sigma2 with @@ -2036,7 +2037,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * | None -> let subs' = match hpred2' with | Sil.Hpointsto (e2, se2, te2) -> - let typ2 = Exp.texp_to_typ (Some Typ.Tvoid) te2 in + let typ2 = Exp.texp_to_typ (Some (Typ.mk Tvoid)) te2 in sexp_imply_nolhs tenv e2 calc_missing subs se2 typ2 | _ -> subs in ProverState.add_missing_sigma [hpred2']; diff --git a/infer/src/backend/rearrange.ml b/infer/src/backend/rearrange.ml index 45a3cfbe4..f81b29fa9 100644 --- a/infer/src/backend/rearrange.ml +++ b/infer/src/backend/rearrange.ml @@ -100,7 +100,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp L.d_str "create_struct_values type:"; Typ.d_full t; L.d_str " off: "; Sil.d_offset_list off; L.d_ln(); raise (Exceptions.Bad_footprint pos) in - match t, off with + match t.desc, off with | Tstruct _, [] -> ([], Sil.Estruct ([], inst), t) | Tstruct name, (Off_fld (f, _)) :: off' -> ( @@ -133,7 +133,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp let e' = Sil.array_clean_new_index footprint_part e in let len = Exp.Var (new_id ()) in let se = Sil.Earray (len, [(e', se')], inst) in - let res_t = Typ.Tarray (res_t', None) in + let res_t = Typ.mk (Tarray (res_t', None)) in (Sil.Aeq (e, e') :: atoms', se, res_t) | Tarray (t', len_), off -> let len = match len_ with @@ -149,7 +149,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp pname tenv orig_prop footprint_part kind max_stamp t' off' inst in let e' = Sil.array_clean_new_index footprint_part e in let se = Sil.Earray (len, [(e', se')], inst) in - let res_t = Typ.Tarray (res_t', len_) in + let res_t = Typ.mk ~default:t (Tarray (res_t', len_)) in (Sil.Aeq(e, e') :: atoms', se, res_t) | (Sil.Off_fld _) :: _ -> assert false @@ -159,16 +159,16 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp ([], Sil.Eexp (Exp.Var id, inst), t) | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _), (Off_index e) :: off' -> (* In this case, we lift t to the t array. *) - let t' = match t with - | Typ.Tptr(t', _) -> t' - | _ -> t in + let t', mk_typ_f = match t.Typ.desc with + | Typ.Tptr(t', _) -> t', (function desc -> Typ.mk ~default:t desc) + | _ -> t, fun desc -> Typ.mk desc in let len = Exp.Var (new_id ()) in let atoms', se', res_t' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst in let e' = Sil.array_clean_new_index footprint_part e in let se = Sil.Earray (len, [(e', se')], inst) in - let res_t = Typ.Tarray (res_t', None) in + let res_t = mk_typ_f (Tarray (res_t', None)) in (Sil.Aeq(e, e') :: atoms', se, res_t) | Tint _, _ | Tfloat _, _ | Tvoid, _ | Tfun _, _ | Tptr _, _ -> fail t off __POS__ @@ -194,7 +194,7 @@ let rec _strexp_extend_values let new_id () = incr max_stamp; Ident.create kind !max_stamp in - match off, se, typ with + match off, se, typ.desc with | [], Sil.Eexp _, _ | [], Sil.Estruct _, _ -> [([], se, typ)] @@ -261,7 +261,7 @@ let rec _strexp_extend_values if Config.type_size then Exp.one (* Exp.Sizeof (typ, Subtype.exact) *) else Exp.Var (new_id ()) in let se_new = Sil.Earray (len, [(Exp.zero, se)], inst) in - let typ_new = Typ.Tarray (typ, None) in + let typ_new = Typ.mk (Tarray (typ, None)) in _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off inst | (Off_index e) :: off', Sil.Earray (len, esel, inst_arr), Tarray (typ', len_for_typ') -> ( @@ -277,7 +277,7 @@ let rec _strexp_extend_values if (Typ.equal res_typ' typ') || Int.equal (List.length res_esel') 1 then ( res_atoms' , Sil.Earray (len, res_esel', inst_arr) - , Typ.Tarray (res_typ', len_for_typ') ) + , Typ.mk ~default:typ (Tarray (res_typ', len_for_typ')) ) :: acc else raise (Exceptions.Bad_footprint __POS__) in @@ -286,7 +286,7 @@ let rec _strexp_extend_values array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp len esel - len_for_typ' typ' + len_for_typ' typ' typ e off' inst_arr inst ) | _, _, _ -> @@ -295,7 +295,7 @@ let rec _strexp_extend_values and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp array_len array_cont - typ_array_len typ_cont + typ_array_len typ_cont typ_array index off inst_arr inst = let check_sound t' = @@ -310,7 +310,7 @@ and array_case_analysis_index pname tenv orig_prop if index_in_array then let array_default = Sil.Earray (array_len, array_cont, inst_arr) in - let typ_default = Typ.Tarray (typ_cont, typ_array_len) in + let typ_default = Typ.mk ~default:typ_array (Tarray (typ_cont, typ_array_len)) in [([], array_default, typ_default)] else if !Config.footprint then begin let atoms, elem_se, elem_typ = @@ -319,7 +319,7 @@ and array_case_analysis_index pname tenv orig_prop check_sound elem_typ; let cont_new = List.sort ~cmp:[%compare: Exp.t * Sil.strexp] ((index, elem_se):: array_cont) in let array_new = Sil.Earray (array_len, cont_new, inst_arr) in - let typ_new = Typ.Tarray (elem_typ, typ_array_len) in + let typ_new = Typ.mk ~default:typ_array (Tarray (elem_typ, typ_array_len)) in [(atoms, array_new, typ_new)] end else begin @@ -333,7 +333,7 @@ and array_case_analysis_index pname tenv orig_prop let cont_new = List.sort ~cmp:[%compare: Exp.t * Sil.strexp] ((index, elem_se):: array_cont) in let array_new = Sil.Earray (array_len, cont_new, inst_arr) in - let typ_new = Typ.Tarray (elem_typ, typ_array_len) in + let typ_new = Typ.mk ~default:typ_array (Tarray (elem_typ, typ_array_len)) in [(atoms, array_new, typ_new)] end in let rec handle_case acc isel_seen_rev = function @@ -349,7 +349,7 @@ and array_case_analysis_index pname tenv orig_prop let atoms_new = Sil.Aeq (index, i) :: atoms' in let isel_new = list_rev_and_concat isel_seen_rev ((i, se'):: isel_unseen) in let array_new = Sil.Earray (array_len, isel_new, inst_arr) in - let typ_new = Typ.Tarray (typ', typ_array_len) in + let typ_new = Typ.mk ~default:typ_array (Tarray (typ', typ_array_len)) in (atoms_new, array_new, typ_new):: acc') ~init:[] atoms_se_typ_list in @@ -443,7 +443,7 @@ let mk_ptsto_exp_footprint let st = match !Config.curr_language with | Config.Clang -> Subtype.exact | Config.Java -> Subtype.subtypes in - let create_ptsto footprint_part off0 = match root, off0, typ with + let create_ptsto footprint_part off0 = match root, off0, typ.Typ.desc with | Exp.Lvar pvar, [], Typ.Tfun _ -> let fun_name = Typ.Procname.from_string_c_fun (Mangled.to_string (Pvar.get_name pvar)) in let fun_exp = Exp.Const (Const.Cfun fun_name) in @@ -738,7 +738,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc = let match_on_field_type typ flds = match String.rsplit2 guarded_by_str0 ~on:'.' with | Some (class_part, field_part) -> - let typ_matches_guarded_by _ = function + let typ_matches_guarded_by _ {Typ.desc} = match desc with | Typ.Tptr (ptr_typ, _) -> String.is_suffix ~suffix:class_part (Typ.to_string ptr_typ); | _ -> @@ -763,35 +763,35 @@ let add_guarded_by_constraints tenv prop lexp pdesc = List.find_map ~f:(function [@warning "-57"] (* FIXME: silenced warning may be legit *) - | Sil.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof (typ, _, _)) - | Sil.Hpointsto (_, Sil.Eexp (Const (Cclass clazz) as lhs_exp, _), Exp.Sizeof (typ, _, _)) - when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) -> - Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ) - | Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof (typ, _, _)) -> - begin - (* first, try to find a field that exactly matches the guarded-by string *) - match get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds with - | None when guarded_by_str_is_this guarded_by_str0 -> - (* if the guarded-by string is "OuterClass.this", look for "this$n" for some n. - note that this is a bit sketchy when there are mutliple this$n's, but there's - nothing we can do to disambiguate them. *) - get_fld_strexp_and_typ - typ - (fun f _ -> Fieldname.java_is_outer_instance f) - flds - | None -> - (* can't find an exact match. try a different convention. *) - match_on_field_type typ flds - | Some _ as res_opt -> - res_opt - end - | Sil.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof (typ, _, _)) - when (guarded_by_str_is_current_class_this guarded_by_str0 pname || - guarded_by_str_is_super_class_this guarded_by_str0 pname - ) && Pvar.is_this pvar -> - Some (rhs_exp, typ) - | _ -> - None) + | Sil.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof (typ, _, _)) + | Sil.Hpointsto (_, Sil.Eexp (Const (Cclass clazz) as lhs_exp, _), Exp.Sizeof (typ, _, _)) + when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) -> + Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ) + | Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof (typ, _, _)) -> + begin + (* first, try to find a field that exactly matches the guarded-by string *) + match get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds with + | None when guarded_by_str_is_this guarded_by_str0 -> + (* if the guarded-by string is "OuterClass.this", look for "this$n" for some n. + note that this is a bit sketchy when there are mutliple this$n's, but there's + nothing we can do to disambiguate them. *) + get_fld_strexp_and_typ + typ + (fun f _ -> Fieldname.java_is_outer_instance f) + flds + | None -> + (* can't find an exact match. try a different convention. *) + match_on_field_type typ flds + | Some _ as res_opt -> + res_opt + end + | Sil.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof (typ, _, _)) + when (guarded_by_str_is_current_class_this guarded_by_str0 pname || + guarded_by_str_is_super_class_this guarded_by_str0 pname + ) && Pvar.is_this pvar -> + Some (rhs_exp, typ) + | _ -> + None) sigma in (* warn if the access to [lexp] is not protected by the [guarded_by_fld_str] lock *) let enforce_guarded_access_ accessed_fld guarded_by_str prop = @@ -814,7 +814,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc = let rec is_read_write_lock typ = let str_is_read_write_lock str = String.is_suffix ~suffix:"ReadWriteUpdateLock" str || String.is_suffix ~suffix:"ReadWriteLock" str in - match typ with + match typ.Typ.desc with | Typ.Tstruct name -> str_is_read_write_lock (Typ.Name.name name) | Typ.Tptr (typ, _) -> is_read_write_lock typ | _ -> false in @@ -1128,7 +1128,7 @@ let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter p (** find the type at the offset from the given type expression, if any *) let type_at_offset tenv texp off = let rec strip_offset (off: Sil.offset list) (typ: Typ.t) = - match off, typ with + match off, typ.desc with | [], _ -> Some typ | (Off_fld (f, _)) :: off', Tstruct name -> ( match Tenv.lookup tenv name with @@ -1184,22 +1184,22 @@ let rec iter_rearrange inst: (Sil.offset list) Prop.prop_iter list = let rec root_typ_of_offsets = function | Sil.Off_fld (f, fld_typ) :: _ -> ( - match fld_typ with - | Tstruct _ as struct_typ -> + match fld_typ.desc with + | Tstruct _ -> (* access through field: get the struct type from the field *) if Config.trace_rearrange then begin L.d_increase_indent 1; L.d_str "iter_rearrange: root of lexp accesses field "; L.d_strln (Fieldname.to_string f); - L.d_str " struct type from field: "; Typ.d_full struct_typ; L.d_ln(); + L.d_str " struct type from field: "; Typ.d_full fld_typ; L.d_ln(); L.d_decrease_indent 1; L.d_ln(); end; - struct_typ + fld_typ | _ -> typ_from_instr ) | Sil.Off_index _ :: off -> - Typ.Tarray (root_typ_of_offsets off, None) + Typ.mk (Tarray (root_typ_of_offsets off, None)) | _ -> typ_from_instr in let typ = root_typ_of_offsets (Sil.exp_get_offsets lexp) in @@ -1286,7 +1286,7 @@ let is_weak_captured_var pdesc var_name = match pname with | Block _ -> let is_weak_captured (var, typ) = - match typ with + match typ.Typ.desc with | Typ.Tptr (_, Pk_objc_weak) -> String.equal var_name (Mangled.to_string var) | _ -> false in diff --git a/infer/src/backend/symExec.ml b/infer/src/backend/symExec.ml index 6548cee09..58152287d 100644 --- a/infer/src/backend/symExec.ml +++ b/infer/src/backend/symExec.ml @@ -27,7 +27,7 @@ let unroll_type tenv (typ: Typ.t) (off: Sil.offset) = L.d_str "Type : "; Typ.d_full typ; L.d_ln (); raise (Exceptions.Bad_footprint __POS__) in - match (typ, off) with + match (typ.desc, off) with | Tstruct name, Off_fld (fld, _) -> ( match Tenv.lookup tenv name with | Some { fields; statics } -> ( @@ -91,7 +91,7 @@ let rec apply_offlist L.d_str "offlist : "; Sil.d_offset_list offlist; L.d_ln (); L.d_str "type : "; Typ.d_full typ; L.d_ln (); L.d_str "prop : "; Prop.d_prop p; L.d_ln (); L.d_ln () in - match offlist, strexp, typ with + match offlist, strexp, typ.Typ.desc with | [], Sil.Eexp (e, inst_curr), _ -> let inst_is_uninitialized = function | Sil.Ialloc -> @@ -183,7 +183,7 @@ let rec apply_offlist then (idx_ese', res_se') else ese in let res_se = Sil.Earray (len, List.map ~f:replace_ese esel, inst1) in - let res_t = Typ.Tarray (res_t', len') in + let res_t = Typ.mk ~default:typ (Tarray (res_t', len')) in (res_e', res_se, res_t, res_pred_insts_op') | None -> (* return a nondeterministic value if the index is not found after rearrangement *) @@ -520,7 +520,7 @@ let resolve_typename prop receiver_exp = | _ :: hpreds -> loop hpreds in loop prop.Prop.sigma in match typexp_opt with - | Some (Exp.Sizeof (Tstruct name, _, _)) -> Some name + | Some (Exp.Sizeof ({desc=Tstruct name}, _, _)) -> Some name | _ -> None (** If the dynamic type of the receiver actual T_actual is a subtype of the reciever type T_formal @@ -535,7 +535,7 @@ let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Typ.Procna begin let name = Typ.Procname.java_get_class_type_name pname_java in match Tenv.lookup tenv name with - | Some _ -> Typ.Tptr (Tstruct name, Pk_pointer) + | Some _ -> Typ.mk (Typ.Tptr (Typ.mk (Tstruct name), Pk_pointer)) | None -> fallback_typ end | _ -> @@ -855,7 +855,7 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nullable_annot typ ca then prop (* don't assume nonnull if the procedure is annotated with @Nullable *) else - match typ with + match typ.Typ.desc with | Typ.Tptr _ -> Prop.conjoin_neq tenv exp Exp.zero prop | _ -> prop in let add_tainted_post ret_exp callee_pname prop = @@ -892,7 +892,7 @@ let add_taint prop lhs_id rhs_exp pname tenv = else prop in match rhs_exp with - | Exp.Lfield (_, fieldname, (Tstruct typname | Tptr (Tstruct typname, _))) -> + | Exp.Lfield (_, fieldname, ({desc=Tstruct typname} | {desc=Tptr ({desc=Tstruct typname}, _)})) -> begin match Tenv.lookup tenv typname with | Some struct_typ -> add_attribute_if_field_tainted prop fieldname struct_typ @@ -1309,8 +1309,8 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call else if !Config.footprint then let prop', abduced_strexp = - match actual_typ with - | Typ.Tptr ((Tstruct _) as typ, _) -> + match actual_typ.Typ.desc with + | Typ.Tptr ({desc=Tstruct _} as typ, _) -> (* for struct types passed by reference, do abduction on the fields of the struct *) add_struct_value_to_footprint tenv abduced_ref_pv typ prop @@ -1319,10 +1319,10 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call let (prop', fresh_fp_var) = add_to_footprint tenv abduced_ref_pv typ prop in prop', Sil.Eexp (fresh_fp_var, Sil.Inone) - | typ -> + | _ -> failwith ("No need for abduction on non-pointer type " ^ - (Typ.to_string typ)) in + (Typ.to_string actual_typ)) in (* replace [actual] |-> _ with [actual] |-> [fresh_fp_var] *) let filtered_sigma = List.map @@ -1440,7 +1440,7 @@ and unknown_or_scan_call ~is_scan ret_type_option ret_annots let actuals_by_ref = List.filter_mapi ~f:(fun i actual -> match actual with - | (Exp.Lvar _ as e, (Typ.Tptr _ as t)) -> Some (e, t, i) + | (Exp.Lvar _ as e, ({Typ.desc=Tptr _} as t)) -> Some (e, t, i) | _ -> None) args in let has_nullable_annot = Annotations.ia_is_nullable ret_annots in @@ -1536,7 +1536,7 @@ and sym_exec_objc_getter field_name ret_typ tenv ret_id pdesc pname loc args pro | Some (ret_id, _) -> ret_id | None -> assert false in match args with - | [(lexp, (Typ.Tstruct _ as typ | Tptr (Tstruct _ as typ, _)))] -> + | [(lexp, ({Typ.desc=Tstruct _} as typ | {desc=Tptr ({desc=Tstruct _} as typ, _)}))] -> let field_access_exp = Exp.Lfield (lexp, field_name, typ) in execute_load ~report_deref_errors:false pname pdesc tenv ret_id field_access_exp ret_typ loc prop @@ -1546,7 +1546,7 @@ and sym_exec_objc_setter field_name _ tenv _ pdesc pname loc args prop = L.d_strln ("No custom setter found. Executing the ObjC builtin setter with ivar "^ (Fieldname.to_string field_name)^"."); match args with - | (lexp1, (Typ.Tstruct _ as typ1 | Tptr (typ1, _))) :: (lexp2, typ2) :: _ -> + | (lexp1, ({Typ.desc=Tstruct _} as typ1 | {Typ.desc=Tptr (typ1, _)})) :: (lexp2, typ2) :: _ -> let field_access_exp = Exp.Lfield (lexp1, field_name, typ1) in execute_store ~report_deref_errors:false pname pdesc tenv field_access_exp typ2 lexp2 loc prop | _ -> raise (Exceptions.Wrong_argument_number __POS__) @@ -1570,7 +1570,7 @@ and proc_call summary {Builtin.pdesc; tenv; prop_= pre; path; ret_id; args= actu let ret_typ = Specs.get_ret_type summary in let check_return_value_ignored () = (* check if the return value of the call is ignored, and issue a warning *) - let is_ignored = match ret_typ, ret_id with + let is_ignored = match ret_typ.Typ.desc, ret_id with | Typ.Tvoid, _ -> false | _, None -> true | _, Some (id, _) -> Errdesc.id_is_assigned_then_dead (State.get_node ()) id in diff --git a/infer/src/backend/tabulation.ml b/infer/src/backend/tabulation.ml index 7c0da830e..78e2b17d2 100644 --- a/infer/src/backend/tabulation.ml +++ b/infer/src/backend/tabulation.ml @@ -470,7 +470,7 @@ let texp_star tenv texp1 texp2 = | 0 -> ftal_sub ftal1' ftal2' | _ -> ftal_sub ftal1 ftal2' end in let typ_star (t1: Typ.t) (t2: Typ.t) = - match t1, t2 with + match t1.desc, t2.desc with | Tstruct name1, Tstruct name2 when Typ.Name.is_same_type name1 name2 -> ( match Tenv.lookup tenv name1, Tenv.lookup tenv name2 with @@ -634,7 +634,7 @@ let prop_get_exn_name pname prop = let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in let rec search_exn e = function | [] -> None - | Sil.Hpointsto (e1, _, Sizeof (Tstruct name, _, _)) :: _ + | Sil.Hpointsto (e1, _, Sizeof ({desc=Tstruct name}, _, _)) :: _ when Exp.equal e1 e -> Some name | _ :: tl -> search_exn e tl in diff --git a/infer/src/bufferoverrun/bufferOverrunChecker.ml b/infer/src/bufferoverrun/bufferOverrunChecker.ml index 07d6d3806..b2140a644 100644 --- a/infer/src/bufferoverrun/bufferOverrunChecker.ml +++ b/infer/src/bufferoverrun/bufferOverrunChecker.ml @@ -41,7 +41,7 @@ struct | Exp.BinOp (Binop.Mult, Exp.Sizeof (typ, _, _), size) | Exp.BinOp (Binop.Mult, size, Exp.Sizeof (typ, _, _)) -> (typ, size) | Exp.Sizeof (typ, _, _) -> (typ, Exp.one) - | x -> (Typ.Tint Typ.IChar, x) + | x -> (Typ.mk (Tint Typ.IChar), x) let model_malloc : Typ.Procname.t -> (Ident.t * Typ.t) option -> (Exp.t * Typ.t) list -> CFG.node @@ -50,7 +50,7 @@ struct match ret with | Some (id, _) -> let set_uninitialized typ loc mem = - match typ with + match typ.Typ.desc with | Typ.Tint _ | Typ.Tfloat _ -> Dom.Mem.weak_update_heap loc Dom.Val.top_itv mem @@ -125,7 +125,7 @@ struct let loc = Loc.of_allocsite (Sem.get_allocsite pname node inst_num dimension) in - match typ with + match typ.Typ.desc with | Typ.Tarray (typ, Some len) -> declare_array pname node loc typ len ~inst_num ~dimension:(dimension + 1) mem @@ -152,7 +152,7 @@ struct mem |> Dom.Mem.find_heap loc |> Dom.Val.get_all_locs |> PowLoc.choose in let field = Loc.append_field loc fn in - match typ with + match typ.Typ.desc with | Typ.Tint _ | Typ.Tfloat _ -> let v = Dom.Val.make_sym pname sym_num in @@ -166,7 +166,7 @@ struct (Dom.Mem.add_heap field v mem, sym_num + 4) | _ -> (mem, sym_num) in - match typ with + match typ.Typ.desc with | Typ.Tstruct typename -> (match Tenv.lookup tenv typename with | Some str -> @@ -179,7 +179,7 @@ struct = fun pdesc tenv node inst_num mem -> let pname = Procdesc.get_proc_name pdesc in let add_formal (mem, inst_num, sym_num) (pvar, typ) = - match typ with + match typ.Typ.desc with | Typ.Tint _ -> let v = Dom.Val.make_sym pname sym_num in let mem = Dom.Mem.add_heap (Loc.of_pvar pvar) v mem in @@ -233,7 +233,7 @@ struct = fun mem { pdesc; tenv; extras } node instr -> let pname = Procdesc.get_proc_name pdesc in let try_decl_arr (mem, inst_num) (pvar, typ) = - match typ with + match typ.Typ.desc with | Typ.Tarray (typ, Some len) -> let loc = Loc.of_var (Var.of_pvar pvar) in let mem = diff --git a/infer/src/bufferoverrun/bufferOverrunSemantics.ml b/infer/src/bufferoverrun/bufferOverrunSemantics.ml index 7c4fe2b7b..27042d1e2 100644 --- a/infer/src/bufferoverrun/bufferOverrunSemantics.ml +++ b/infer/src/bufferoverrun/bufferOverrunSemantics.ml @@ -43,15 +43,15 @@ struct | Typ.FDouble | Typ.FLongDouble -> 8 (* NOTE: assume 32bit machine *) - let rec sizeof : Typ.t -> int - = function - | Typ.Tint ikind -> sizeof_ikind ikind - | Typ.Tfloat fkind -> sizeof_fkind fkind - | Typ.Tvoid -> 1 - | Typ.Tptr (_, _) -> 4 - | Typ.Tstruct _ -> 4 (* TODO *) - | Typ.Tarray (typ, Some ilit) -> sizeof typ * IntLit.to_int ilit - | _ -> 4 + let rec sizeof (typ : Typ.t) : int = + match typ.desc with + | Typ.Tint ikind -> sizeof_ikind ikind + | Typ.Tfloat fkind -> sizeof_fkind fkind + | Typ.Tvoid -> 1 + | Typ.Tptr (_, _) -> 4 + | Typ.Tstruct _ -> 4 (* TODO *) + | Typ.Tarray (typ, Some ilit) -> sizeof typ * IntLit.to_int ilit + | _ -> 4 let rec must_alias : Exp.t -> Exp.t -> Mem.astate -> bool = fun e1 e2 m -> @@ -372,8 +372,8 @@ struct add_pair_val v1' v2' pairs in let add_pair_ptr typ v1 v2 pairs = - match typ with - | Typ.Tptr (Typ.Tstruct typename, _) -> + match typ.Typ.desc with + | Typ.Tptr ({desc=Tstruct typename}, _) -> (match Tenv.lookup tenv typename with | Some str -> let fns = List.map ~f:get_field_name str.Typ.Struct.fields in diff --git a/infer/src/checkers/ThreadSafety.ml b/infer/src/checkers/ThreadSafety.ml index d7af7118f..06205e00f 100644 --- a/infer/src/checkers/ThreadSafety.ml +++ b/infer/src/checkers/ThreadSafety.ml @@ -192,7 +192,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let is_safe_access access prefix_path tenv = match access, AccessPath.Raw.get_typ prefix_path tenv with | AccessPath.FieldAccess fieldname, - Some (Typ.Tstruct typename | Tptr (Tstruct typename, _)) -> + Some ({Typ.desc=Tstruct typename} | {desc=Tptr ({desc=Tstruct typename}, _)}) -> begin match Tenv.lookup tenv typename with | Some struct_typ -> @@ -257,7 +257,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match List.rev accesses, AccessPath.Raw.get_typ (AccessPath.Raw.truncate access_path) tenv with | AccessPath.FieldAccess fieldname :: _, - Some (Typ.Tstruct typename | Tptr (Tstruct typename, _)) -> + Some {Typ.desc=Tstruct typename | Tptr ({Typ.desc=Tstruct typename}, _)} -> begin match Tenv.lookup tenv typename with | Some struct_typ -> @@ -482,8 +482,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct is_annotated_synchronized base_typename container_field tenv | [AccessPath.FieldAccess container_field] -> begin - match base_typ with - | Typ.Tstruct base_typename | Tptr (Tstruct base_typename, _) -> + match base_typ.Typ.desc with + | Typ.Tstruct base_typename | Tptr ({Typ.desc=Tstruct base_typename}, _) -> is_annotated_synchronized base_typename container_field tenv | _ -> false @@ -557,7 +557,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | Sil.Call (Some (ret_id, _), Const (Cfun callee_pname), (target_exp, target_typ) :: (Exp.Sizeof (cast_typ, _, _), _) :: _ , _, _) when Typ.Procname.equal callee_pname BuiltinDecl.__cast -> - let lhs_access_path = AccessPath.of_id ret_id (Typ.Tptr (cast_typ, Pk_pointer)) in + let lhs_access_path = AccessPath.of_id ret_id (Typ.mk (Tptr (cast_typ, Pk_pointer))) in let attribute_map = propagate_attributes lhs_access_path target_exp target_typ ~f_resolve_id astate.attribute_map extras in @@ -710,7 +710,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct astate in begin match ret_opt with - | Some (_, (Typ.Tint ILong | Tfloat FDouble)) -> + | Some (_, {Typ.desc=Tint ILong | Tfloat FDouble}) -> (* writes to longs and doubles are not guaranteed to be atomic in Java, so don't bother tracking whether a returned long or float value is functional *) astate_callee diff --git a/infer/src/checkers/accessPath.ml b/infer/src/checkers/accessPath.ml index b3db1771a..ae7941ef2 100644 --- a/infer/src/checkers/accessPath.ml +++ b/infer/src/checkers/accessPath.ml @@ -112,7 +112,7 @@ let of_exp exp0 typ0 ~(f_resolve_id : Var.t -> Raw.t option) = of_exp_ root_exp root_exp_typ (field_access :: accesses) acc | Exp.Lindex (root_exp, _) -> let array_access = ArrayAccess typ in - let array_typ = Typ.Tarray (typ, None) in + let array_typ = Typ.mk (Tarray (typ, None)) in of_exp_ root_exp array_typ (array_access :: accesses) acc | Exp.Cast (cast_typ, cast_exp) -> of_exp_ cast_exp cast_typ [] acc diff --git a/infer/src/checkers/addressTaken.ml b/infer/src/checkers/addressTaken.ml index 7fc880634..751d71735 100644 --- a/infer/src/checkers/addressTaken.ml +++ b/infer/src/checkers/addressTaken.ml @@ -31,11 +31,11 @@ module TransferFunctions (CFG : ProcCfg.S) = struct astate let exec_instr astate _ _ = function - | Sil.Store (_, Tptr _, rhs_exp, _) -> + | Sil.Store (_, {desc=Tptr _}, rhs_exp, _) -> add_address_taken_pvars rhs_exp astate | Sil.Call (_, _, actuals, _, _) -> let add_actual_by_ref astate_acc = function - | actual_exp, Typ.Tptr _ -> add_address_taken_pvars actual_exp astate_acc + | actual_exp, {Typ.desc=Tptr _} -> add_address_taken_pvars actual_exp astate_acc | _ -> astate_acc in List.fold ~f:add_actual_by_ref ~init:astate actuals | Sil.Store _ | Load _ | Prune _ | Nullify _ | Abstract _ | Remove_temps _ diff --git a/infer/src/checkers/checkers.ml b/infer/src/checkers/checkers.ml index 8b652a2ed..b9fbc5a48 100644 --- a/infer/src/checkers/checkers.ml +++ b/infer/src/checkers/checkers.ml @@ -201,8 +201,8 @@ let callback_check_write_to_parcel_java let expr_match () = Exp.is_this this_expr in let type_match () = let class_name = Typ.Name.Java.from_string "android.os.Parcelable" in - match this_type with - | Typ.Tptr (Tstruct name, _) | Tstruct name -> + match this_type.Typ.desc with + | Typ.Tptr ({desc=Tstruct name}, _) | Tstruct name -> PatternMatch.is_immediate_subtype tenv name class_name | _ -> false in method_match () && expr_match () && type_match () in @@ -213,8 +213,8 @@ let callback_check_write_to_parcel_java proc_desc pname_java ["android.os.Parcel"] in let parcel_constructors tenv typ = - match typ with - | Typ.Tptr (Tstruct name, _) -> ( + match typ.Typ.desc with + | Typ.Tptr ({desc=Tstruct name}, _) -> ( match Tenv.lookup tenv name with | Some { methods } -> List.filter ~f:is_parcel_constructor methods | None -> [] @@ -325,11 +325,11 @@ let callback_monitor_nullcheck { Callbacks.proc_desc; idenv; summary } = let formals = Procdesc.get_formals proc_desc in let class_formals = let is_class_type (p, typ) = - match typ with + match typ.Typ.desc with | Typ.Tptr _ when String.equal (Mangled.to_string p) "this" -> false (* no need to null check 'this' *) | Typ.Tstruct _ -> true - | Typ.Tptr (Typ.Tstruct _, _) -> true + | Typ.Tptr ({desc=Tstruct _}, _) -> true | _ -> false in List.filter ~f:is_class_type formals in List.map ~f:fst class_formals) in diff --git a/infer/src/checkers/copyPropagation.ml b/infer/src/checkers/copyPropagation.ml index b6587e94a..3c723701c 100644 --- a/infer/src/checkers/copyPropagation.ml +++ b/infer/src/checkers/copyPropagation.ml @@ -99,7 +99,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let kill_ret_id (id,_) = Domain.kill_copies_with_var (Var.of_id id) astate in let kill_actuals_by_ref astate_acc = function - | (Exp.Lvar pvar, Typ.Tptr _) -> Domain.kill_copies_with_var (Var.of_pvar pvar) astate_acc + | (Exp.Lvar pvar, {Typ.desc=Tptr _}) -> Domain.kill_copies_with_var (Var.of_pvar pvar) astate_acc | _ -> astate_acc in let astate' = Option.value_map ~f:kill_ret_id ~default:astate ret_id in if Config.curr_language_is Config.Java diff --git a/infer/src/checkers/fragmentRetainsViewChecker.ml b/infer/src/checkers/fragmentRetainsViewChecker.ml index f38a5f2db..cd916ad73 100644 --- a/infer/src/checkers/fragmentRetainsViewChecker.ml +++ b/infer/src/checkers/fragmentRetainsViewChecker.ml @@ -26,8 +26,8 @@ let callback_fragment_retains_view_java (* TODO: complain if onDestroyView is not defined, yet the Fragment has View fields *) (* TODO: handle fields nullified in callees in the same file *) let is_on_destroy_view = String.equal (Typ.Procname.java_get_method pname_java) "onDestroyView" in - let fld_typ_is_view = function - | Typ.Tptr (Tstruct tname, _) -> AndroidFramework.is_view tenv tname + let fld_typ_is_view typ = match typ.Typ.desc with + | Typ.Tptr ({desc=Tstruct tname}, _) -> AndroidFramework.is_view tenv tname | _ -> false in (* is [fldname] a View type declared by [class_typename]? *) let is_declared_view_typ class_typename (fldname, fld_typ, _) = @@ -47,7 +47,7 @@ let callback_fragment_retains_view_java ~f:(fun (fname, fld_typ, _) -> if not (Fieldname.Set.mem fname fields_nullified) then report_error - (Tstruct class_typename) fname fld_typ summary proc_desc) + (Typ.mk (Tstruct class_typename)) fname fld_typ summary proc_desc) declared_view_fields | _ -> () end diff --git a/infer/src/checkers/patternMatch.ml b/infer/src/checkers/patternMatch.ml index f50f0f38d..a14f52b84 100644 --- a/infer/src/checkers/patternMatch.ml +++ b/infer/src/checkers/patternMatch.ml @@ -25,8 +25,8 @@ type taint_spec = { } let type_is_object typ = - match typ with - | Typ.Tptr (Tstruct name, _) -> Typ.Name.equal name Typ.Name.Java.java_lang_object + match typ.Typ.desc with + | Tptr ({desc=Tstruct name}, _) -> Typ.Name.equal name Typ.Name.Java.java_lang_object | _ -> false let java_proc_name_with_class_method pn_java class_with_path method_name = @@ -74,8 +74,8 @@ let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals | _ -> None let type_get_direct_supertypes tenv (typ: Typ.t) = - match typ with - | Tptr (Tstruct name, _) + match typ.desc with + | Tptr ({desc=Tstruct name}, _) | Tstruct name -> ( match Tenv.lookup tenv name with | Some { supers } -> supers @@ -84,13 +84,13 @@ let type_get_direct_supertypes tenv (typ: Typ.t) = | _ -> [] -let type_get_class_name = function +let type_get_class_name {Typ.desc} = match desc with | Typ.Tptr (typ, _) -> Typ.name typ | _ -> None let type_get_annotation tenv (typ: Typ.t): Annot.Item.t option = - match typ with - | Tptr (Tstruct name, _) + match typ.desc with + | Tptr ({desc=Tstruct name}, _) | Tstruct name -> ( match Tenv.lookup tenv name with | Some { annots } -> Some annots @@ -112,7 +112,7 @@ let type_has_supertype let supers = type_get_direct_supertypes tenv typ in let match_supertype cn = let match_name () = Typ.Name.equal cn class_name in - let has_indirect_supertype () = has_supertype (Typ.Tstruct cn) (Typ.Set.add typ visited) in + let has_indirect_supertype () = has_supertype (Typ.mk (Tstruct cn)) (Typ.Set.add typ visited) in (match_name () || has_indirect_supertype ()) in List.exists ~f:match_supertype supers in has_supertype typ Typ.Set.empty @@ -121,7 +121,8 @@ let type_is_nested_in_direct_supertype tenv t n = let is_nested_in cn1 cn2 = String.is_prefix ~prefix:(Typ.Name.name cn1 ^ "$") (Typ.Name.name cn2) in List.exists ~f:(is_nested_in n) (type_get_direct_supertypes tenv t) -let rec get_type_name = function +let rec get_type_name {Typ.desc} = + match desc with | Typ.Tstruct name -> Typ.Name.name name | Typ.Tptr (t, _) -> get_type_name t @@ -130,8 +131,8 @@ let rec get_type_name = function let get_field_type_name tenv (typ: Typ.t) (fieldname: Fieldname.t): string option = - match typ with - | Tstruct name | Tptr (Tstruct name, _) -> ( + match typ.desc with + | Tstruct name | Tptr ({desc=Tstruct name}, _) -> ( match Tenv.lookup tenv name with | Some { fields } -> ( match List.find @@ -245,10 +246,10 @@ let get_java_method_call_formal_signature = function let type_is_class typ = - match typ with - | Typ.Tptr (Typ.Tstruct _, _) -> true - | Typ.Tptr (Typ.Tarray _, _) -> true - | Typ.Tstruct _ -> true + match typ.Typ.desc with + | Tptr ({desc=Tstruct _}, _) -> true + | Tptr ({desc=Tarray _}, _) -> true + | Tstruct _ -> true | _ -> false let initializer_classes = @@ -349,7 +350,7 @@ let override_exists f tenv proc_name = let type_name = Typ.Name.Java.from_string (Typ.Procname.java_get_class_name proc_name_java) in List.exists ~f:(super_type_exists tenv) - (type_get_direct_supertypes tenv (Typ.Tstruct type_name)) + (type_get_direct_supertypes tenv (Typ.mk (Tstruct type_name))) | _ -> false (* Only java supported at the moment *) diff --git a/infer/src/clang/CType.ml b/infer/src/clang/CType.ml index d3102f31a..00dd7c5b9 100644 --- a/infer/src/clang/CType.ml +++ b/infer/src/clang/CType.ml @@ -14,15 +14,15 @@ open! IStd module L = Logging let add_pointer_to_typ typ = - Typ.Tptr(typ, Typ.Pk_pointer) + Typ.mk (Tptr(typ, Typ.Pk_pointer)) let remove_pointer_to_typ typ = - match typ with + match typ.Typ.desc with | Typ.Tptr(typ, Typ.Pk_pointer) -> typ | _ -> typ let objc_classname_of_type typ = - match typ with + match typ.Typ.desc with | Typ.Tstruct name -> name | Typ.Tfun _ -> Typ.Name.Objc.from_string CFrontend_config.objc_object | _ -> @@ -31,8 +31,8 @@ let objc_classname_of_type typ = Typ.Name.Objc.from_string "undefined" let is_class typ = - match typ with - | Typ.Tptr (Tstruct name, _) -> + match typ.Typ.desc with + | Typ.Tptr ({desc=Tstruct name}, _) -> String.equal (Typ.Name.name name) CFrontend_config.objc_class | _ -> false diff --git a/infer/src/clang/CType_decl.ml b/infer/src/clang/CType_decl.ml index 128bddf92..7d7fab2ec 100644 --- a/infer/src/clang/CType_decl.ml +++ b/infer/src/clang/CType_decl.ml @@ -158,15 +158,16 @@ and get_superclass_list_cpp tenv decl = let get_super_field super_decl = get_record_typename ~tenv super_decl in List.map ~f:get_super_field base_decls -and get_record_struct_type tenv definition_decl = +and get_record_struct_type tenv definition_decl : Typ.t = let open Clang_ast_t in match definition_decl with | ClassTemplateSpecializationDecl (_, _, _, type_ptr, _, _, record_decl_info, _, _) | CXXRecordDecl (_, _, _, type_ptr, _, _, record_decl_info, _) | RecordDecl (_, _, _, type_ptr, _, _, record_decl_info) -> let sil_typename = get_record_typename ~tenv definition_decl in + let sil_type = Typ.mk (Tstruct sil_typename) in (match Tenv.lookup tenv sil_typename with - | Some _ -> Typ.Tstruct sil_typename (* just reuse what is already in tenv *) + | Some _ -> sil_type (* just reuse what is already in tenv *) | None -> let is_complete_definition = record_decl_info.Clang_ast_t.rdi_is_complete_definition in let extra_fields = @@ -177,7 +178,7 @@ and get_record_struct_type tenv definition_decl = if Typ.Name.Cpp.is_class sil_typename then Annot.Class.cpp else Annot.Item.empty (* No annotations for structs *) in if is_complete_definition then ( - CAst_utils.update_sil_types_map type_ptr (Typ.Tstruct sil_typename); + CAst_utils.update_sil_types_map type_ptr sil_type; let non_statics = get_struct_fields tenv definition_decl in let fields = CGeneral_utils.append_no_duplicates_fields non_statics extra_fields in let statics = [] in (* Note: We treat static field same as global variables *) @@ -186,16 +187,14 @@ and get_record_struct_type tenv definition_decl = let specialization = get_template_specialization tenv definition_decl in Tenv.mk_struct tenv ~fields ~statics ~methods ~supers ~annots ~specialization sil_typename |> ignore; - let sil_type = Typ.Tstruct sil_typename in CAst_utils.update_sil_types_map type_ptr sil_type; sil_type ) else ( (* There is no definition for that struct in whole translation unit. Put empty struct into tenv to prevent backend problems *) ignore (Tenv.mk_struct tenv ~fields:extra_fields sil_typename); - let tvar_type = Typ.Tstruct sil_typename in - CAst_utils.update_sil_types_map type_ptr tvar_type; - tvar_type)) + CAst_utils.update_sil_types_map type_ptr sil_type; + sil_type)) | _ -> assert false and add_types_from_decl_to_tenv tenv decl = @@ -220,8 +219,8 @@ let get_type_from_expr_info ei tenv = type_ptr_to_sil_type tenv tp let class_from_pointer_type tenv type_ptr = - match type_ptr_to_sil_type tenv type_ptr with - | Typ.Tptr(Typ.Tstruct typename, _) -> typename + match (type_ptr_to_sil_type tenv type_ptr).Typ.desc with + | Tptr({desc=Tstruct typename}, _) -> typename | _ -> assert false let get_class_type_np tenv expr_info obj_c_message_expr_info = diff --git a/infer/src/clang/cArithmetic_trans.ml b/infer/src/clang/cArithmetic_trans.ml index 3747dec96..031c41568 100644 --- a/infer/src/clang/cArithmetic_trans.ml +++ b/infer/src/clang/cArithmetic_trans.ml @@ -26,7 +26,7 @@ let assignment_arc_mode e1 typ e2 loc rhs_owning_method is_e1_decl = let mk_call procname e t = let bi_retain = Exp.Const (Const.Cfun procname) in Sil.Call (None, bi_retain, [(e, t)], loc, CallFlags.default) in - match typ with + match typ.Typ.desc with | Typ.Tptr (_, Typ.Pk_pointer) when not rhs_owning_method && not is_e1_decl -> (* for __strong e1 = e2 the semantics is*) (* retain(e2); tmp=e1; e1=e2; release(tmp); *) diff --git a/infer/src/clang/cEnum_decl.ml b/infer/src/clang/cEnum_decl.ml index 80f877f8b..5ffe1a970 100644 --- a/infer/src/clang/cEnum_decl.ml +++ b/infer/src/clang/cEnum_decl.ml @@ -44,7 +44,7 @@ let enum_decl decl = match decl with | EnumDecl (_, _, _, type_ptr, decl_list, _, _) -> add_enum_constants_to_map (List.rev decl_list); - let sil_type = Typ.Tint Typ.IInt in + let sil_type = Typ.mk (Typ.Tint Typ.IInt) in CAst_utils.update_sil_types_map type_ptr sil_type; sil_type diff --git a/infer/src/clang/cField_decl.ml b/infer/src/clang/cField_decl.ml index 1b7658b29..47f38d360 100644 --- a/infer/src/clang/cField_decl.ml +++ b/infer/src/clang/cField_decl.ml @@ -37,7 +37,7 @@ let fields_superclass tenv interface_decl_info = let build_sil_field type_ptr_to_sil_type tenv field_name type_ptr prop_attributes = let prop_atts = List.map ~f:Clang_ast_j.string_of_property_attribute prop_attributes in let annotation_from_type t = - match t with + match t.Typ.desc with | Typ.Tptr (_, Typ.Pk_objc_weak) -> [Config.weak] | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained) -> [Config.unsafe_unret] | _ -> [] in @@ -87,8 +87,8 @@ let add_missing_fields tenv class_name missing_fields = | _ -> () let modelled_fields_in_classes = - [("NSData", "_bytes", Typ.Tptr (Typ.Tvoid, Typ.Pk_pointer)); - ("NSArray", "elementData", Typ.Tint Typ.IInt)] + [("NSData", "_bytes", Typ.mk (Tptr (Typ.mk Tvoid, Typ.Pk_pointer))); + ("NSArray", "elementData", Typ.mk (Tint Typ.IInt))] let modelled_field class_name_info = let modelled_field_in_class res (class_name, field_name, typ) = diff --git a/infer/src/clang/cMethod_trans.ml b/infer/src/clang/cMethod_trans.ml index 037882ff3..07718d99d 100644 --- a/infer/src/clang/cMethod_trans.ml +++ b/infer/src/clang/cMethod_trans.ml @@ -62,8 +62,8 @@ let get_class_param function_method_decl_info = let should_add_return_param return_type ~is_objc_method = - match return_type with - | Typ.Tstruct _ -> not is_objc_method + match return_type.Typ.desc with + | Tstruct _ -> not is_objc_method | _ -> false let is_objc_method function_method_decl_info = @@ -112,8 +112,8 @@ let get_parameters trans_unit_ctx tenv function_method_decl_info = let _, mangled = CGeneral_utils.get_var_name_mangled name_info var_decl_info in let param_typ = CType_decl.type_ptr_to_sil_type tenv qt.Clang_ast_t.qt_type_ptr in let qt_type_ptr = - match param_typ with - | Typ.Tstruct _ when CGeneral_utils.is_cpp_translation trans_unit_ctx -> + match param_typ.Typ.desc with + | Tstruct _ when CGeneral_utils.is_cpp_translation trans_unit_ctx -> Ast_expressions.create_reference_type qt.Clang_ast_t.qt_type_ptr | _ -> qt.Clang_ast_t.qt_type_ptr in (mangled, {qt with qt_type_ptr}) @@ -127,7 +127,7 @@ let get_return_val_and_param_types tenv function_method_decl_info = let return_typ = CType_decl.type_ptr_to_sil_type tenv return_type_ptr in let is_objc_method = is_objc_method function_method_decl_info in if should_add_return_param return_typ ~is_objc_method then - Ast_expressions.create_void_type, Some (Typ.Tptr (return_typ, Typ.Pk_pointer)) + Ast_expressions.create_void_type, Some (CType.add_pointer_to_typ return_typ) else return_type_ptr, None let build_method_signature trans_unit_ctx tenv decl_info procname function_method_decl_info @@ -263,7 +263,7 @@ let get_class_name_method_call_from_receiver_kind context obj_c_message_expr_inf (CType.objc_classname_of_type sil_type) | `Instance -> (match act_params with - | (_, Typ.Tptr(t, _)):: _ + | (_, {Typ.desc=Tptr(t, _)}):: _ | (_, t):: _ -> CType.objc_classname_of_type t | _ -> assert false) | `SuperInstance ->get_superclass_curr_class_objc context @@ -442,7 +442,7 @@ let create_external_procdesc cfg proc_name is_objc_inst_method type_opt = (match type_opt with | Some (ret_type, arg_types) -> ret_type, List.map ~f:(fun typ -> (Mangled.from_string "x", typ)) arg_types - | None -> Typ.Tvoid, []) in + | None -> Typ.mk Typ.Tvoid, []) in let loc = Location.dummy in let proc_attributes = { (ProcAttributes.default proc_name Config.Clang) with diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index ab69d2292..562fb262d 100644 --- a/infer/src/clang/cTrans.ml +++ b/infer/src/clang/cTrans.ml @@ -74,7 +74,7 @@ struct not (CTrans_utils.is_owning_name method_name) && ObjcInterface_decl.is_pointer_to_objc_class typ then let fname = BuiltinDecl.__set_autorelease_attribute in - let ret_id = Some (Ident.create_fresh Ident.knormal, Typ.Tvoid) in + let ret_id = Some (Ident.create_fresh Ident.knormal, Typ.mk Typ.Tvoid) in (* TODO(jjb): change ret_id to None? *) let stmt_call = Sil.Call (ret_id, Exp.Const (Const.Cfun fname), [(exp, typ)], sil_loc, CallFlags.default) in @@ -118,7 +118,7 @@ struct Logging.out_debug "-----> field: '%s'\n" (Fieldname.to_string fn)) fields; let block_typename = Typ.Name.Objc.from_string block_name in ignore (Tenv.mk_struct tenv ~fields block_typename); - let block_type = Typ.Tstruct block_typename in + let block_type = Typ.mk (Typ.Tstruct block_typename) in let trans_res = CTrans_utils.alloc_trans trans_state loc (Ast_expressions.dummy_stmt_info ()) block_type true None in @@ -128,7 +128,7 @@ struct let mblock = Mangled.from_string block_name in let block_var = Pvar.mk mblock procname in let declare_block_local = - Sil.Declare_locals ([(block_var, Typ.Tptr (block_type, Typ.Pk_pointer))], loc) in + Sil.Declare_locals ([(block_var, CType.add_pointer_to_typ block_type)], loc) in let set_instr = Sil.Store (Exp.Lvar block_var, block_type, Exp.Var id_block, loc) in let create_field_exp (var, typ) = let id = Ident.create_fresh Ident.knormal in @@ -158,7 +158,7 @@ struct match es with | [] -> [] | (Exp.Closure {name; captured_vars}, - (Typ.Tptr((Typ.Tfun _), _ ) as t)) :: es' -> + ({Typ.desc=Tptr({Typ.desc=Tfun _}, _ )} as t)) :: es' -> let app = let function_name = make_function_name t name in let args = List.map ~f:(make_arg t) captured_vars in @@ -207,23 +207,23 @@ struct try f trans_state stmt with Self.SelfClassException class_name -> - let typ = Typ.Tstruct class_name in + let typ = Typ.mk (Tstruct class_name) in { empty_res_trans with - exps = [(Exp.Sizeof (typ, None, Subtype.exact), Tint IULong)] } + exps = [Exp.Sizeof (typ, None, Subtype.exact), Typ.mk (Tint IULong)] } - let add_reference_if_glvalue typ expr_info = + let add_reference_if_glvalue (typ : Typ.t) expr_info = (* glvalue definition per C++11:*) (* http://en.cppreference.com/w/cpp/language/value_category *) let is_glvalue = match expr_info.Clang_ast_t.ei_value_kind with | `LValue | `XValue -> true | `RValue -> false in - match is_glvalue, typ with - | true, Typ.Tptr (_, Typ.Pk_reference) -> + match is_glvalue, typ.desc with + | true, Tptr (_, Pk_reference) -> (* reference of reference is not allowed in C++ - it's most likely frontend *) (* trying to add same reference to same type twice*) (* this is hacky and should be fixed (t9838691) *) typ - | true, _ -> Typ.Tptr (typ, Typ.Pk_reference) + | true, _ -> Typ.mk (Tptr (typ, Pk_reference)) | _ -> typ (** Execute translation and then possibly adjust the type of the result of translation: @@ -273,14 +273,14 @@ struct Procdesc.append_locals procdesc [(Pvar.get_name pvar, typ)]; Exp.Lvar pvar, typ - let create_call_instr trans_state return_type function_sil params_sil sil_loc + let create_call_instr trans_state (return_type : Typ.t) function_sil params_sil sil_loc call_flags ~is_objc_method = - let ret_id = if (Typ.equal return_type Typ.Tvoid) then None + let ret_id = if (Typ.equal_desc return_type.desc Typ.Tvoid) then None else Some (Ident.create_fresh Ident.knormal, return_type) in let ret_id', params, initd_exps, ret_exps = (* Assumption: should_add_return_param will return true only for struct types *) if CMethod_trans.should_add_return_param return_type ~is_objc_method then - let param_type = Typ.Tptr (return_type, Typ.Pk_pointer) in + let param_type = Typ.mk (Typ.Tptr (return_type, Typ.Pk_pointer)) in let var_exp = match trans_state.var_exp_typ with | Some (exp, _) -> exp | _ -> @@ -391,7 +391,7 @@ struct let cxxScalarValueInitExpr_trans trans_state expr_info = let typ = CType_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in (* constant will be different depending on type *) - let zero_opt = match typ with + let zero_opt = match typ.desc with | Typ.Tfloat _ | Typ.Tptr _ | Typ.Tint _ -> Some (Sil.zero_value_of_numerical_type typ) | Typ.Tvoid -> None | _ -> Some (Exp.Const (Const.Cint IntLit.zero)) in @@ -493,13 +493,13 @@ struct let field_typ = CType_decl.type_ptr_to_sil_type context.tenv type_ptr in let (obj_sil, class_typ) = extract_exp_from_list pre_trans_result.exps "WARNING: in Field dereference we expect to know the object\n" in - let is_pointer_typ = match class_typ with + let is_pointer_typ = match class_typ.desc with | Typ.Tptr _ -> true | _ -> false in let class_typ = - match class_typ with + match class_typ.desc with | Typ.Tptr (t, _) -> t - | t -> t in + | _ -> class_typ in Logging.out_debug "Type is '%s' @." (Typ.to_string class_typ); let field_name = CGeneral_utils.mk_class_field_name name_info in let field_exp = Exp.Lfield (obj_sil, field_name, class_typ) in @@ -549,12 +549,12 @@ struct | [] -> [], [] (* We need to add a dereference before a method call to find null dereferences when *) (* calling a method with null *) - | [(exp, Typ.Tptr (typ, _) )] when decl_kind <> `CXXConstructor -> + | [(exp, {Typ.desc=Tptr (typ, _)})] when decl_kind <> `CXXConstructor -> let no_id = Ident.create_none () in let extra_instrs = [Sil.Load (no_id, exp, typ, sil_loc)] in pre_trans_result.exps, extra_instrs - | [(_, Typ.Tptr _ )] -> pre_trans_result.exps, [] - | [(sil, typ)] -> [(sil, Typ.Tptr (typ, Typ.Pk_reference))], [] + | [(_, {Typ.desc=Tptr _})] -> pre_trans_result.exps, [] + | [(sil, typ)] -> [(sil, Typ.mk (Tptr (typ, Typ.Pk_reference)))], [] | _ -> assert false ) else @@ -625,10 +625,10 @@ struct let _, _, type_ptr = CAst_utils.get_info_from_decl_ref decl_ref in let ast_typ = CType_decl.type_ptr_to_sil_type context.tenv type_ptr in let typ = - match ast_typ with + match ast_typ.Typ.desc with | Tstruct _ when decl_ref.dr_kind = `ParmVar -> if CGeneral_utils.is_cpp_translation context.translation_unit_context then - Typ.Tptr (ast_typ, Pk_reference) + Typ.mk (Tptr (ast_typ, Pk_reference)) else ast_typ | _ -> ast_typ in let procname = Procdesc.get_proc_name context.procdesc in @@ -641,12 +641,12 @@ struct if (CType.is_class typ) then raise (Self.SelfClassException class_typename) else - let typ = CType.add_pointer_to_typ (Typ.Tstruct class_typename) in + let typ = CType.add_pointer_to_typ (Typ.mk (Tstruct class_typename)) in [(var_exp, typ)] else [(var_exp, typ)] in Logging.out_debug "\n\n PVAR ='%s'\n\n" (Pvar.to_string pvar); let res_trans = { empty_res_trans with exps } in - match typ with + match typ.desc with | Tptr (_, Pk_reference) -> (* dereference pvar due to the behavior of reference types in clang's AST *) dereference_value_from_result sil_loc res_trans ~strip_pointer:false @@ -876,7 +876,7 @@ struct (Logging.out_debug "ERROR: stmt_list and res_trans_par.exps must have same size\n"; assert false) in let act_params = if is_cf_retain_release then - (Exp.Const (Const.Cint IntLit.one), Typ.Tint Typ.IBool) :: act_params + (Exp.Const (Const.Cint IntLit.one), Typ.mk (Tint Typ.IBool)) :: act_params else act_params in let res_trans_call = let cast_trans_fun = cast_trans act_params sil_loc function_type in @@ -973,7 +973,7 @@ struct let class_type = CType_decl.get_type_from_expr_info ei context.CContext.tenv in Procdesc.append_locals procdesc [(Pvar.get_name pvar, class_type)]; Exp.Lvar pvar, class_type in - let this_type = Typ.Tptr (class_type, Typ.Pk_pointer) in + let this_type = CType.add_pointer_to_typ class_type in let this_res_trans = { empty_res_trans with exps = [(var_exp, this_type)]; initd_exps = [var_exp]; @@ -983,13 +983,13 @@ struct to be extra Load instruction before returning the trans_result of constructorExpr. There is no LValueToRvalue cast in the AST afterwards since clang doesn't know that class type is translated as pointer type. It gets added here instead. *) - let extra_res_trans = match class_type with + let extra_res_trans = match class_type.desc with | Typ.Tptr _ -> dereference_value_from_result sil_loc tmp_res_trans ~strip_pointer:false | _ -> tmp_res_trans in let res_trans_callee = decl_ref_trans trans_state this_res_trans si decl_ref ~is_constructor_init:false in let res_trans = cxx_method_construct_call_trans trans_state_pri res_trans_callee - params_stmt si Typ.Tvoid false extra_res_trans in + params_stmt si (Typ.mk Tvoid) false extra_res_trans in { res_trans with exps=extra_res_trans.exps } and cxx_destructor_call_trans trans_state si this_res_trans class_type_ptr = @@ -997,7 +997,7 @@ struct let res_trans_callee = destructor_deref_trans trans_state this_res_trans class_type_ptr si in let is_cpp_call_virtual = res_trans_callee.is_cpp_call_virtual in if res_trans_callee.exps <> [] then - cxx_method_construct_call_trans trans_state_pri res_trans_callee [] si Typ.Tvoid + cxx_method_construct_call_trans trans_state_pri res_trans_callee [] si (Typ.mk Tvoid) is_cpp_call_virtual empty_res_trans else empty_res_trans @@ -1202,7 +1202,7 @@ struct Logging.out_debug " No short-circuit condition\n"; let res_trans_cond = if is_null_stmt cond then { - empty_res_trans with exps = [(Exp.Const (Const.Cint IntLit.one), (Typ.Tint Typ.IBool))] + empty_res_trans with exps = [(Exp.Const (Const.Cint IntLit.one), Typ.mk (Tint Typ.IBool))] } (* Assumption: If it's a null_stmt, it is a loop with no bound, so we set condition to 1 *) else @@ -1613,7 +1613,7 @@ struct and initListExpr_trans trans_state stmt_info expr_info stmts = let context = trans_state.context in let tenv = context.tenv in - let is_array typ = match typ with | Typ.Tarray _ -> true | _ -> false in + let is_array typ = match typ.Typ.desc with | Typ.Tarray _ -> true | _ -> false in let (var_exp, typ) = match trans_state.var_exp_typ with | Some var_exp_typ -> var_exp_typ @@ -1906,7 +1906,7 @@ struct let pvar = Pvar.mk (Mangled.from_string name) procname in let id = Ident.create_fresh Ident.knormal in let instr = Sil.Load (id, Exp.Lvar pvar, ret_param_typ, sil_loc) in - let ret_typ = match ret_param_typ with Typ.Tptr (t, _) -> t | _ -> assert false in + let ret_typ = match ret_param_typ.desc with Typ.Tptr (t, _) -> t | _ -> assert false in Exp.Var id, ret_typ, [instr] | None -> Exp.Lvar (Procdesc.get_ret_var procdesc), ret_type, [] in @@ -2003,7 +2003,7 @@ struct let context = trans_state.context in let sil_loc = CLocation.get_sil_location stmt_info context in let fname = BuiltinDecl.__objc_release_autorelease_pool in - let ret_id = Some (Ident.create_fresh Ident.knormal, Typ.Tvoid) in + let ret_id = Some (Ident.create_fresh Ident.knormal, Typ.mk Tvoid) in (* TODO(jjb): change ret_id to None? *) let autorelease_pool_vars = CVar_decl.compute_autorelease_pool_vars context stmts in let stmt_call = @@ -2068,7 +2068,7 @@ struct | _ -> assert false and initListExpr_initializers_trans trans_state var_exp n stmts typ is_dyn_array stmt_info = - let (var_exp_inside, typ_inside) = match typ with + let (var_exp_inside, typ_inside) = match typ.Typ.desc with | Typ.Tarray (t, _) when Typ.is_array_of_cpp_class typ -> Exp.Lindex (var_exp, Exp.Const (Const.Cint (IntLit.of_int n))), t | _ when is_dyn_array -> @@ -2129,7 +2129,7 @@ struct let stmt_opt = CAst_utils.get_stmt_opt cxx_new_expr_info.Clang_ast_t.xnei_initializer_expr in let trans_state_init = { trans_state_pri with succ_nodes = []; } in let var_exp_typ = match res_trans_new.exps with - | [var_exp, Typ.Tptr (t, _)] -> (var_exp, t) + | [var_exp, {Typ.desc=Tptr (t, _)}] -> (var_exp, t) | _ -> assert false in (* Need a new stmt_info for the translation of the initializer, so that it can create nodes *) (* if it needs to, with the same stmt_info it doesn't work. *) @@ -2224,14 +2224,14 @@ struct let tenv = context.CContext.tenv in let sil_loc = CLocation.get_sil_location stmt_info context in let cast_type = CType_decl.type_ptr_to_sil_type tenv cast_type_ptr in - let sizeof_expr = match cast_type with + let sizeof_expr = match cast_type.desc with | Typ.Tptr (typ, _) -> Exp.Sizeof (typ, None, subtypes) | _ -> assert false in let builtin = Exp.Const (Const.Cfun BuiltinDecl.__cast) in let stmt = match stmts with [stmt] -> stmt | _ -> assert false in let res_trans_stmt = exec_with_glvalue_as_reference instruction trans_state' stmt in let exp = match res_trans_stmt.exps with | [e] -> e | _ -> assert false in - let args = [exp; (sizeof_expr, Typ.Tvoid)] in + let args = [exp; (sizeof_expr, Typ.mk Tvoid)] in let ret_id = Ident.create_fresh Ident.knormal in let call = Sil.Call (Some (ret_id, cast_type), builtin, args, sil_loc, CallFlags.default) in let res_ex = Exp.Var ret_id in @@ -2272,7 +2272,7 @@ struct and cxxPseudoDestructorExpr_trans () = let fun_name = Typ.Procname.from_string_c_fun CFrontend_config.infer_skip_fun in - { empty_res_trans with exps = [(Exp.Const (Const.Cfun fun_name), Typ.Tvoid)] } + { empty_res_trans with exps = [(Exp.Const (Const.Cfun fun_name), Typ.mk Tvoid)] } and cxxTypeidExpr_trans trans_state stmt_info stmts expr_info = let tenv = trans_state.context.CContext.tenv in @@ -2288,12 +2288,13 @@ struct let fun_name = BuiltinDecl.__cxx_typeid in let sil_fun = Exp.Const (Const.Cfun fun_name) in let ret_id = Ident.create_fresh Ident.knormal in - let type_info_objc = (Exp.Sizeof (typ, None, Subtype.exact), Typ.Tvoid) in + let void_typ = Typ.mk Tvoid in + let type_info_objc = (Exp.Sizeof (typ, None, Subtype.exact), void_typ) in let field_name_decl = CAst_utils.make_qual_name_decl ["type_info"; "std"] "__type_name" in let field_name = CGeneral_utils.mk_class_field_name field_name_decl in let ret_exp = Exp.Var ret_id in let field_exp = Exp.Lfield (ret_exp, field_name, typ) in - let args = type_info_objc :: (field_exp, Typ.Tvoid) :: res_trans_subexpr.exps in + let args = type_info_objc :: (field_exp, void_typ) :: res_trans_subexpr.exps in let call_instr = Sil.Call (Some (ret_id, typ), sil_fun, args, sil_loc, CallFlags.default) in let res_trans_call = { empty_res_trans with instrs = [call_instr]; @@ -2616,7 +2617,7 @@ struct implicitValueInitExpr_trans trans_state expr_info | GenericSelectionExpr _ (* to be fixed when we dump the right info in the ast *) | SizeOfPackExpr _ -> - { empty_res_trans with exps = [(Exp.get_undefined false, Typ.Tvoid)] } + { empty_res_trans with exps = [(Exp.get_undefined false, Typ.mk Tvoid)] } | GCCAsmStmt (stmt_info, stmts) -> gccAsmStmt_trans trans_state stmt_info stmts @@ -2683,7 +2684,7 @@ struct "WARNING: There should be one expression for 'this' in constructor. \n" in (* Hack: Strip pointer from type here since cxxConstructExpr_trans expects it this way *) (* it will add pointer back before making it a parameter to a call *) - let class_typ = match this_typ with Typ.Tptr (t, _) -> t | _ -> assert false in + let class_typ = match this_typ.Typ.desc with Tptr (t, _) -> t | _ -> assert false in { this_res_trans with exps = [this_exp, class_typ] } | `Member (decl_ref) -> decl_ref_trans trans_state' this_res_trans child_stmt_info decl_ref diff --git a/infer/src/clang/cTrans_utils.ml b/infer/src/clang/cTrans_utils.ml index 99f994159..fa68edcc0 100644 --- a/infer/src/clang/cTrans_utils.ml +++ b/infer/src/clang/cTrans_utils.ml @@ -25,7 +25,7 @@ let extract_item_from_singleton l warning_string failure_val = | [item] -> item | _ -> Logging.err_debug "%s" warning_string; failure_val -let dummy_exp = (Exp.minus_one, Typ.Tint Typ.IInt) +let dummy_exp = (Exp.minus_one, Typ.mk (Tint Typ.IInt)) (* Extract the element of a singleton list. If the list is not a singleton *) (* Gives a warning and return -1 as standard value indicating something *) @@ -294,20 +294,20 @@ end (** This function handles ObjC new/alloc and C++ new calls *) let create_alloc_instrs sil_loc function_type fname size_exp_opt procname_opt = let function_type, function_type_np = - match function_type with - | Typ.Tptr (styp, Typ.Pk_pointer) - | Typ.Tptr (styp, Typ.Pk_objc_weak) - | Typ.Tptr (styp, Typ.Pk_objc_unsafe_unretained) - | Typ.Tptr (styp, Typ.Pk_objc_autoreleasing) -> + match function_type.Typ.desc with + | Tptr (styp, Typ.Pk_pointer) + | Tptr (styp, Typ.Pk_objc_weak) + | Tptr (styp, Typ.Pk_objc_unsafe_unretained) + | Tptr (styp, Typ.Pk_objc_autoreleasing) -> function_type, styp - | _ -> Typ.Tptr (function_type, Typ.Pk_pointer), function_type in + | _ -> CType.add_pointer_to_typ function_type, function_type in let sizeof_exp_ = Exp.Sizeof (function_type_np, None, Subtype.exact) in let sizeof_exp = match size_exp_opt with | Some exp -> Exp.BinOp (Binop.Mult, sizeof_exp_, exp) | None -> sizeof_exp_ in - let exp = (sizeof_exp, Typ.Tint Typ.IULong) in + let exp = (sizeof_exp, Typ.mk (Tint Typ.IULong)) in let procname_arg = match procname_opt with - | Some procname -> [Exp.Const (Const.Cfun (procname)), Typ.Tvoid] + | Some procname -> [Exp.Const (Const.Cfun (procname)), Typ.mk Tvoid] | None -> [] in let args = exp :: procname_arg in let ret_id = Ident.create_fresh Ident.knormal in @@ -379,7 +379,7 @@ let create_cast_instrs exp cast_from_typ cast_to_typ sil_loc = let typ = CType.remove_pointer_to_typ cast_to_typ in let sizeof_exp = Exp.Sizeof (typ, None, Subtype.exact) in let pname = BuiltinDecl.__objc_cast in - let args = [(exp, cast_from_typ); (sizeof_exp, Typ.Tint Typ.IULong)] in + let args = [(exp, cast_from_typ); (sizeof_exp, Typ.mk (Tint Typ.IULong))] in let stmt_call = Sil.Call (ret_id_typ, Exp.Const (Const.Cfun pname), args, sil_loc, CallFlags.default) in (stmt_call, Exp.Var ret_id) @@ -401,7 +401,7 @@ let dereference_var_sil (exp, typ) sil_loc = assigned to it *) let dereference_value_from_result sil_loc trans_result ~strip_pointer = let (obj_sil, class_typ) = extract_exp_from_list trans_result.exps "" in - let typ_no_ptr = match class_typ with | Typ.Tptr (typ, _) -> typ | _ -> assert false in + let typ_no_ptr = match class_typ.Typ.desc with | Tptr (typ, _) -> typ | _ -> assert false in let cast_typ = if strip_pointer then typ_no_ptr else class_typ in let cast_inst, cast_exp = dereference_var_sil (obj_sil, cast_typ) sil_loc in { trans_result with @@ -445,7 +445,7 @@ let cast_operation trans_state cast_kind exps cast_typ sil_loc is_objc_bridged = let trans_assertion_failure sil_loc (context : CContext.t) = let assert_fail_builtin = Exp.Const (Const.Cfun BuiltinDecl.__infer_fail) in - let args = [Exp.Const (Const.Cstr Config.default_failure_name), Typ.Tvoid] in + let args = [Exp.Const (Const.Cstr Config.default_failure_name), Typ.mk Tvoid] in let call_instr = Sil.Call (None, assert_fail_builtin, args, sil_loc, CallFlags.default) in let exit_node = Procdesc.get_exit_node (CContext.get_procdesc context) and failure_node = @@ -581,7 +581,7 @@ struct let typ, self_expr, ins = let t' = CType.add_pointer_to_typ - (Typ.Tstruct (CContext.get_curr_class_typename context)) in + (Typ.mk (Tstruct (CContext.get_curr_class_typename context))) in let e = Exp.Lvar (Pvar.mk (Mangled.from_string CFrontend_config.self) procname) in let id = Ident.create_fresh Ident.knormal in t', Exp.Var id, [Sil.Load (id, e, t', loc)] in @@ -658,7 +658,8 @@ let rec contains_opaque_value_expr s = (* checks if a unary operator is a logic negation applied to integers*) let is_logical_negation_of_int tenv ei uoi = - match CType_decl.type_ptr_to_sil_type tenv ei.Clang_ast_t.ei_type_ptr, uoi.Clang_ast_t.uoi_kind with + match (CType_decl.type_ptr_to_sil_type tenv ei.Clang_ast_t.ei_type_ptr).desc, + uoi.Clang_ast_t.uoi_kind with | Typ.Tint _,`LNot -> true | _, _ -> false @@ -710,8 +711,8 @@ let is_block_enumerate_function mei = let var_or_zero_in_init_list tenv e typ ~return_zero:return_zero = let rec var_or_zero_in_init_list' e typ tns = let open CGeneral_utils in - match typ with - | Typ.Tstruct tn -> ( + match typ.Typ.desc with + | Tstruct tn -> ( match Tenv.lookup tenv tn with | Some { fields } -> let lh_exprs = @@ -722,7 +723,7 @@ let var_or_zero_in_init_list tenv e typ ~return_zero:return_zero = | None -> assert false ) - | Typ.Tarray (arrtyp, Some n) -> + | Tarray (arrtyp, Some n) -> let size = IntLit.to_int n in let indices = list_range 0 (size - 1) in let index_constants = @@ -733,10 +734,10 @@ let var_or_zero_in_init_list tenv e typ ~return_zero:return_zero = let exp_types = zip lh_exprs lh_types in List.map ~f:(fun (e, t) -> List.concat (var_or_zero_in_init_list' e t tns)) exp_types - | Typ.Tint _ | Typ.Tfloat _ | Typ.Tptr _ -> + | Tint _ | Tfloat _ | Tptr _ -> let exp = if return_zero then Sil.zero_value_of_numerical_type typ else e in [ [(exp, typ)] ] - | Typ.Tfun _ | Typ.Tvoid | Typ.Tarray _ -> assert false in + | Tfun _ | Tvoid | Tarray _ -> assert false in List.concat (var_or_zero_in_init_list' e typ String.Set.empty) (* diff --git a/infer/src/clang/cType_to_sil_type.ml b/infer/src/clang/cType_to_sil_type.ml index e8d8f329e..7c0afc33a 100644 --- a/infer/src/clang/cType_to_sil_type.ml +++ b/infer/src/clang/cType_to_sil_type.ml @@ -15,42 +15,42 @@ let get_builtin_objc_typename builtin_type = | `ObjCClass -> Typ.Name.C.from_string CFrontend_config.objc_class let get_builtin_objc_type builtin_type = - let typ = Typ.Tstruct (get_builtin_objc_typename builtin_type) in + let typ = Typ.mk (Tstruct (get_builtin_objc_typename builtin_type)) in match builtin_type with | `ObjCId -> typ - | `ObjCClass -> Typ.Tptr (typ, Typ.Pk_pointer) + | `ObjCClass -> Typ.mk (Tptr (typ, Typ.Pk_pointer)) let sil_type_of_builtin_type_kind builtin_type_kind = match builtin_type_kind with - | `Void -> Typ.Tvoid - | `Bool -> Typ.Tint Typ.IBool - | `Char_U -> Typ.Tint Typ.IUChar - | `UChar -> Typ.Tint Typ.IUChar - | `WChar_U -> Typ.Tint Typ.IUChar - | `Char_S -> Typ.Tint Typ.IChar - | `SChar -> Typ.Tint Typ.ISChar + | `Void -> Typ.mk Tvoid + | `Bool -> Typ.mk (Tint IBool) + | `Char_U -> Typ.mk (Tint IUChar) + | `UChar -> Typ.mk (Tint IUChar) + | `WChar_U -> Typ.mk (Tint IUChar) + | `Char_S -> Typ.mk (Tint IChar) + | `SChar -> Typ.mk (Tint ISChar) | `WChar_S | `Char16 - | `Char32 -> Typ.Tint Typ.IChar + | `Char32 -> Typ.mk (Tint IChar) | `UShort - | `Short -> Typ.Tint Typ.IShort + | `Short -> Typ.mk (Tint IShort) | `UInt - | `UInt128 -> Typ.Tint Typ.IUInt - | `ULong -> Typ.Tint Typ.IULong - | `ULongLong -> Typ.Tint Typ.IULongLong + | `UInt128 -> Typ.mk (Tint IUInt) + | `ULong -> Typ.mk (Tint IULong) + | `ULongLong -> Typ.mk (Tint IULongLong) | `Int - | `Int128 -> Typ.Tint Typ.IInt - | `Long -> Typ.Tint Typ.ILong - | `LongLong -> Typ.Tint Typ.ILongLong - | `Half -> Typ.Tint Typ.IShort (*?*) - | `Float -> Typ.Tfloat Typ.FFloat - | `Double -> Typ.Tfloat Typ.FDouble - | `LongDouble -> Typ.Tfloat Typ.FLongDouble - | `NullPtr -> Typ.Tint Typ.IInt + | `Int128 -> Typ.mk (Tint IInt) + | `Long -> Typ.mk (Tint ILong) + | `LongLong -> Typ.mk (Tint ILongLong) + | `Half -> Typ.mk (Tint IShort) (*?*) + | `Float -> Typ.mk (Tfloat FFloat) + | `Double -> Typ.mk (Tfloat FDouble) + | `LongDouble -> Typ.mk (Tfloat FLongDouble) + | `NullPtr -> Typ.mk (Tint IInt) | `ObjCId -> get_builtin_objc_type `ObjCId | `ObjCClass -> get_builtin_objc_type `ObjCClass - | _ -> Typ.Tvoid + | _ -> Typ.mk Tvoid let pointer_attribute_of_objc_attribute attr_info = match attr_info.Clang_ast_t.ati_lifetime with @@ -62,7 +62,7 @@ let pointer_attribute_of_objc_attribute attr_info = let rec build_array_type translate_decl tenv type_ptr n_opt = let array_type = type_ptr_to_sil_type translate_decl tenv type_ptr in let len = Option.map ~f:(fun n -> IntLit.of_int64 (Int64.of_int n)) n_opt in - Typ.Tarray (array_type, len) + Typ.mk (Tarray (array_type, len)) and sil_type_of_attr_type translate_decl tenv type_info attr_info = match type_info.Clang_ast_t.ti_desugared_type with @@ -70,14 +70,14 @@ and sil_type_of_attr_type translate_decl tenv type_info attr_info = (match CAst_utils.get_type type_ptr with | Some Clang_ast_t.ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr}) -> let typ = type_ptr_to_sil_type translate_decl tenv qt_type_ptr in - Typ.Tptr (typ, pointer_attribute_of_objc_attribute attr_info) + Typ.mk (Tptr (typ, pointer_attribute_of_objc_attribute attr_info)) | _ -> type_ptr_to_sil_type translate_decl tenv type_ptr) - | None -> Typ.Tvoid + | None -> Typ.mk Tvoid -and sil_type_of_c_type translate_decl tenv c_type = +and sil_type_of_c_type translate_decl tenv c_type : Typ.t = let open Clang_ast_t in match c_type with - | NoneType _ -> Typ.Tvoid + | NoneType _ -> Typ.mk Tvoid | BuiltinType (_, builtin_type_kind) -> sil_type_of_builtin_type_kind builtin_type_kind | PointerType (_, {Clang_ast_t.qt_type_ptr}) @@ -85,12 +85,12 @@ and sil_type_of_c_type translate_decl tenv c_type = let typ = type_ptr_to_sil_type translate_decl tenv qt_type_ptr in if Typ.equal typ (get_builtin_objc_type `ObjCClass) then typ - else Typ.Tptr (typ, Typ.Pk_pointer) + else Typ.mk (Tptr (typ, Typ.Pk_pointer)) | ObjCObjectType (_, objc_object_type_info) -> type_ptr_to_sil_type translate_decl tenv objc_object_type_info.Clang_ast_t.base_type | BlockPointerType (_, type_ptr) -> let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in - Typ.Tptr (typ, Typ.Pk_pointer) + Typ.mk (Tptr (typ, Typ.Pk_pointer)) | IncompleteArrayType (_, type_ptr) | DependentSizedArrayType (_, type_ptr) | VariableArrayType (_, type_ptr) -> @@ -99,7 +99,7 @@ and sil_type_of_c_type translate_decl tenv c_type = build_array_type translate_decl tenv type_ptr (Some n) | FunctionProtoType _ | FunctionNoProtoType _ -> - Typ.Tfun false + Typ.mk (Tfun false) | ParenType (_, type_ptr) -> type_ptr_to_sil_type translate_decl tenv type_ptr | DecayedType (_, type_ptr) -> @@ -110,20 +110,20 @@ and sil_type_of_c_type translate_decl tenv c_type = | ElaboratedType (type_info) -> (match type_info.Clang_ast_t.ti_desugared_type with Some type_ptr -> type_ptr_to_sil_type translate_decl tenv type_ptr - | None -> Typ.Tvoid) + | None -> Typ.mk Tvoid) | ObjCInterfaceType (_, pointer) -> decl_ptr_to_sil_type translate_decl tenv pointer | RValueReferenceType (_, {Clang_ast_t.qt_type_ptr}) | LValueReferenceType (_, {Clang_ast_t.qt_type_ptr}) -> let typ = type_ptr_to_sil_type translate_decl tenv qt_type_ptr in - Typ.Tptr (typ, Typ.Pk_reference) + Typ.mk (Tptr (typ, Typ.Pk_reference)) | AttributedType (type_info, attr_info) -> sil_type_of_attr_type translate_decl tenv type_info attr_info | _ -> (* TypedefType, etc *) let type_info = Clang_ast_proj.get_type_tuple c_type in match type_info.Clang_ast_t.ti_desugared_type with | Some typ -> type_ptr_to_sil_type translate_decl tenv typ - | None -> Typ.Tvoid + | None -> Typ.mk Tvoid and decl_ptr_to_sil_type translate_decl tenv decl_ptr = let open Clang_ast_t in @@ -143,11 +143,11 @@ and decl_ptr_to_sil_type translate_decl tenv decl_ptr = | Some _ -> Logging.err_debug "Warning: Wrong decl found for pointer %s " (Clang_ast_j.string_of_pointer decl_ptr); - Typ.Tvoid + Typ.mk Tvoid | None -> Logging.err_debug "Warning: Decl pointer %s not found." (Clang_ast_j.string_of_pointer decl_ptr); - Typ.Tvoid + Typ.mk Tvoid and clang_type_ptr_to_sil_type translate_decl tenv type_ptr = try @@ -158,7 +158,7 @@ and clang_type_ptr_to_sil_type translate_decl tenv type_ptr = let sil_type = sil_type_of_c_type translate_decl tenv c_type in CAst_utils.update_sil_types_map type_ptr sil_type; sil_type - | _ -> Typ.Tvoid) + | _ -> Typ.mk Tvoid) and type_ptr_to_sil_type translate_decl tenv type_ptr = match type_ptr with @@ -166,12 +166,12 @@ and type_ptr_to_sil_type translate_decl tenv type_ptr = | Clang_ast_extend.Builtin kind -> sil_type_of_builtin_type_kind kind | Clang_ast_extend.PointerOf typ -> let sil_typ = type_ptr_to_sil_type translate_decl tenv typ in - Typ.Tptr (sil_typ, Typ.Pk_pointer) + Typ.mk (Tptr (sil_typ, Pk_pointer)) | Clang_ast_extend.ReferenceOf typ -> let sil_typ = type_ptr_to_sil_type translate_decl tenv typ in - Typ.Tptr (sil_typ, Typ.Pk_reference) + Typ.mk (Tptr (sil_typ, Pk_reference)) | Clang_ast_extend.ClassType typename -> - Typ.Tstruct typename + Typ.mk (Tstruct typename) | Clang_ast_extend.DeclPtr ptr -> decl_ptr_to_sil_type translate_decl tenv ptr - | Clang_ast_extend.ErrorType -> Typ.Tvoid + | Clang_ast_extend.ErrorType -> Typ.mk Tvoid | _ -> raise (invalid_arg "unknown variant for type_ptr") diff --git a/infer/src/clang/objcCategory_decl.ml b/infer/src/clang/objcCategory_decl.ml index f74c91ef7..1d9de7a8f 100644 --- a/infer/src/clang/objcCategory_decl.ml +++ b/infer/src/clang/objcCategory_decl.ml @@ -68,8 +68,9 @@ let get_base_class_name_from_category decl = let process_category type_ptr_to_sil_type tenv class_name decl_info decl_list = let decl_fields = CField_decl.get_fields type_ptr_to_sil_type tenv decl_list in let class_tn_name = Typ.Name.Objc.from_qual_name class_name in + let class_tn_type = Typ.mk (Typ.Tstruct class_tn_name) in let decl_key = Clang_ast_extend.DeclPtr decl_info.Clang_ast_t.di_pointer in - CAst_utils.update_sil_types_map decl_key (Typ.Tstruct class_tn_name); + CAst_utils.update_sil_types_map decl_key class_tn_type; (match Tenv.lookup tenv class_tn_name with | Some ({ fields } as struct_typ) -> let new_fields = CGeneral_utils.append_no_duplicates_fields decl_fields fields in @@ -78,7 +79,7 @@ let process_category type_ptr_to_sil_type tenv class_name decl_info decl_list = ~default:struct_typ ~fields:new_fields ~statics:[] ~methods:[] class_tn_name ); Logging.out_debug " Updating info for class '%a' in tenv\n" QualifiedCppName.pp class_name | _ -> ()); - Typ.Tstruct class_tn_name + class_tn_type let category_decl type_ptr_to_sil_type tenv decl = let open Clang_ast_t in diff --git a/infer/src/clang/objcInterface_decl.ml b/infer/src/clang/objcInterface_decl.ml index c75e8ea30..627fcae6e 100644 --- a/infer/src/clang/objcInterface_decl.ml +++ b/infer/src/clang/objcInterface_decl.ml @@ -19,8 +19,8 @@ open! IStd module L = Logging let is_pointer_to_objc_class typ = - match typ with - | Typ.Tptr (typ, _) when Typ.is_objc_class typ -> true + match typ.Typ.desc with + | Tptr (typ, _) when Typ.is_objc_class typ -> true | _ -> false let get_super_interface_decl otdi_super = @@ -78,8 +78,9 @@ let add_class_to_tenv type_ptr_to_sil_type tenv decl_info name_info decl_list oc let class_name = CAst_utils.get_qualified_name name_info in Logging.out_debug "ADDING: ObjCInterfaceDecl for '%a'\n" QualifiedCppName.pp class_name; let interface_name = Typ.Name.Objc.from_qual_name class_name in + let interface_type = Typ.mk (Tstruct interface_name) in let decl_key = Clang_ast_extend.DeclPtr decl_info.Clang_ast_t.di_pointer in - CAst_utils.update_sil_types_map decl_key (Typ.Tstruct interface_name); + CAst_utils.update_sil_types_map decl_key interface_type; let decl_supers, decl_fields = create_supers_fields type_ptr_to_sil_type tenv decl_list ocidi.Clang_ast_t.otdi_super @@ -113,7 +114,7 @@ let add_class_to_tenv type_ptr_to_sil_type tenv decl_info name_info decl_list oc Logging.out_debug " >>>OK. Found typ='%a'\n" (Typ.Struct.pp Pp.text interface_name) st | None -> Logging.out_debug " >>>NOT Found!!\n"); - Typ.Tstruct interface_name + interface_type (* Interface_type_info has the name of instance variables and the name of methods. *) let interface_declaration type_ptr_to_sil_type tenv decl = @@ -143,7 +144,7 @@ let interface_impl_declaration type_ptr_to_sil_type tenv decl = CField_decl.add_missing_fields tenv class_name fields; let class_tn_name = Typ.Name.Objc.from_qual_name class_name in let decl_key = Clang_ast_extend.DeclPtr decl_info.Clang_ast_t.di_pointer in - let class_typ = Typ.Tstruct class_tn_name in + let class_typ = Typ.mk (Tstruct class_tn_name) in CAst_utils.update_sil_types_map decl_key class_typ; class_typ | _ -> assert false diff --git a/infer/src/clang/objcProtocol_decl.ml b/infer/src/clang/objcProtocol_decl.ml index 7f9c9c07a..a3bb180dc 100644 --- a/infer/src/clang/objcProtocol_decl.ml +++ b/infer/src/clang/objcProtocol_decl.ml @@ -26,11 +26,12 @@ let protocol_decl type_ptr_to_sil_type tenv decl = (* It may turn out that we need a more specific treatment for protocols*) Logging.out_debug "ADDING: ObjCProtocolDecl for '%a'\n" QualifiedCppName.pp name; let protocol_name = Typ.Name.Objc.protocol_from_qual_name name in + let protocol_type = Typ.mk (Tstruct protocol_name) in let decl_key = Clang_ast_extend.DeclPtr decl_info.Clang_ast_t.di_pointer in - CAst_utils.update_sil_types_map decl_key (Typ.Tstruct protocol_name); + CAst_utils.update_sil_types_map decl_key protocol_type; ignore( Tenv.mk_struct tenv ~methods:[] protocol_name ); add_protocol_super type_ptr_to_sil_type tenv obj_c_protocol_decl_info; - Typ.Tstruct protocol_name + protocol_type | _ -> assert false let is_protocol decl = diff --git a/infer/src/eradicate/eradicateChecks.ml b/infer/src/eradicate/eradicateChecks.ml index 61b85314d..baef6e678 100644 --- a/infer/src/eradicate/eradicateChecks.ml +++ b/infer/src/eradicate/eradicateChecks.ml @@ -117,7 +117,7 @@ let check_condition tenv case_zero find_canonical_duplicate curr_pdesc (* That always happens in the bytecode generated by try-with-resources. *) let loc = Procdesc.Node.get_loc node in let throwable_found = ref false in - let typ_is_throwable = function + let typ_is_throwable {Typ.desc} = match desc with | Typ.Tstruct (Typ.JavaClass _ as name) -> String.equal (Typ.Name.name name) "java.lang.Throwable" | _ -> false in @@ -242,7 +242,7 @@ let check_constructor_initialization tenv if Typ.Procname.is_constructor curr_pname then begin match PatternMatch.get_this_type (Procdesc.get_attributes curr_pdesc) with - | Some (Tptr (Tstruct name as ts, _)) -> ( + | Some ({desc=Tptr ({desc=Tstruct name} as ts, _)}) -> ( match Tenv.lookup tenv name with | Some { fields } -> let do_field (fn, ft, _) = diff --git a/infer/src/eradicate/typeCheck.ml b/infer/src/eradicate/typeCheck.ml index 81ff96091..c8763fe6b 100644 --- a/infer/src/eradicate/typeCheck.ml +++ b/infer/src/eradicate/typeCheck.ml @@ -479,7 +479,7 @@ let typecheck_instr (* check if there are errors in exp1 *) let typecheck_expr_for_errors typestate1 exp1 loc1 : unit = - ignore (typecheck_expr_simple typestate1 exp1 Typ.Tvoid TypeOrigin.Undef loc1) in + ignore (typecheck_expr_simple typestate1 exp1 (Typ.mk Tvoid) TypeOrigin.Undef loc1) in match instr with | Sil.Remove_temps (idl, _) -> @@ -565,7 +565,7 @@ let typecheck_instr TypeState.add_id id ( - Typ.Tint (Typ.IInt), + Typ.mk (Tint (Typ.IInt)), TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.New, [loc] ) @@ -1006,7 +1006,7 @@ let typecheck_instr Pvar.mk (Mangled.from_string e_str) curr_pname in let e1 = Exp.Lvar pvar in let (typ, ta, _) = - typecheck_expr_simple typestate e1 Typ.Tvoid TypeOrigin.ONone loc in + typecheck_expr_simple typestate e1 (Typ.mk Tvoid) TypeOrigin.ONone loc in let range = (typ, ta, [loc]) in let typestate1 = TypeState.add pvar range typestate in typestate1, e1, EradicateChecks.From_containsKey @@ -1027,7 +1027,6 @@ let typecheck_instr | Exp.Lvar pvar -> pvar_apply loc handle_pvar typestate2 pvar | _ -> typestate2 in - begin match c with | Exp.BinOp (Binop.Eq, Exp.Const (Const.Cint i), e) | Exp.BinOp (Binop.Eq, e, Exp.Const (Const.Cint i)) when IntLit.iszero i -> @@ -1039,7 +1038,7 @@ let typecheck_instr typestate, e, EradicateChecks.From_condition in let e', typestate2 = convert_complex_exp_to_pvar node' false e1 typestate1 loc in let (typ, ta, _) = - typecheck_expr_simple typestate2 e' Typ.Tvoid TypeOrigin.ONone loc in + typecheck_expr_simple typestate2 e' (Typ.mk Tvoid) TypeOrigin.ONone loc in if checks.eradicate then EradicateChecks.check_zero tenv @@ -1086,7 +1085,7 @@ let typecheck_instr end in let e', typestate2 = convert_complex_exp_to_pvar node' false e1 typestate1 loc in let (typ, ta, _) = - typecheck_expr_simple typestate2 e' Typ.Tvoid TypeOrigin.ONone loc in + typecheck_expr_simple typestate2 e' (Typ.mk Tvoid) TypeOrigin.ONone loc in if checks.eradicate then EradicateChecks.check_nonzero tenv find_canonical_duplicate curr_pdesc diff --git a/infer/src/harness/harness.ml b/infer/src/harness/harness.ml index 69fcc29f1..56af19652 100644 --- a/infer/src/harness/harness.ml +++ b/infer/src/harness/harness.ml @@ -21,7 +21,7 @@ let try_create_lifecycle_trace name lifecycle_name lifecycle_procs tenv = | Typ.JavaClass _ -> if PatternMatch.is_subtype tenv name lifecycle_name && not (AndroidFramework.is_android_lib_class name) then - let ptr_to_struct_typ = Some (Typ.Tptr (Tstruct name, Pk_pointer)) in + let ptr_to_struct_typ = Some (Typ.mk (Tptr (Typ.mk (Tstruct name), Pk_pointer))) in List.fold ~f:(fun trace lifecycle_proc -> (* given a lifecycle subclass T, resolve the call T.lifecycle_proc() to the procname diff --git a/infer/src/harness/inhabit.ml b/infer/src/harness/inhabit.ml index 4f6d8e0e3..e33708c9c 100644 --- a/infer/src/harness/inhabit.ml +++ b/infer/src/harness/inhabit.ml @@ -74,7 +74,7 @@ let inhabit_alloc sizeof_typ sizeof_len ret_typ alloc_kind env = let call_instr = let fun_new = fun_exp_from_name alloc_kind in let sizeof_exp = Exp.Sizeof (sizeof_typ, sizeof_len, Subtype.exact) in - let args = [(sizeof_exp, Typ.Tptr (ret_typ, Typ.Pk_pointer))] in + let args = [(sizeof_exp, Typ.mk (Tptr (ret_typ, Typ.Pk_pointer)))] in Sil.Call (Some (retval, ret_typ), fun_new, args, env.pc, cf_alloc) in (inhabited_exp, env_add_instr call_instr env) @@ -83,19 +83,19 @@ let inhabit_alloc sizeof_typ sizeof_len ret_typ alloc_kind env = let rec inhabit_typ tenv typ cfg env = try (TypMap.find typ env.cache, env) with Not_found -> - let inhabit_internal typ env = match typ with - | Typ.Tptr (Typ.Tarray (inner_typ, Some _), Typ.Pk_pointer) -> + let inhabit_internal typ env = match typ.Typ.desc with + | Typ.Tptr ({desc=Tarray (inner_typ, Some _)}, Typ.Pk_pointer) -> let len = Exp.Const (Const.Cint (IntLit.one)) in - let arr_typ = Typ.Tarray (inner_typ, Some IntLit.one) in + let arr_typ = Typ.mk (Tarray (inner_typ, Some IntLit.one)) in inhabit_alloc arr_typ (Some len) typ BuiltinDecl.__new_array env - | Typ.Tptr (typ, Typ.Pk_pointer) as ptr_to_typ -> + | Typ.Tptr (typ, Typ.Pk_pointer) -> (* TODO (t4575417): this case does not work correctly for enums, but they are currently * broken in Infer anyway (see t4592290) *) let (allocated_obj_exp, env) = inhabit_alloc typ None typ BuiltinDecl.__new env in (* select methods that are constructors and won't force us into infinite recursion because * we are already inhabiting one of their argument types *) let get_all_suitable_constructors (typ: Typ.t) = - match typ with + match typ.desc with | Tstruct name when Typ.Name.is_class name -> ( match Tenv.lookup tenv name with | Some { methods } -> @@ -116,7 +116,7 @@ let rec inhabit_typ tenv typ cfg env = (* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to * nondeterministically call all possible constructors instead *) let env = - inhabit_constructor tenv constructor (allocated_obj_exp, ptr_to_typ) cfg env in + inhabit_constructor tenv constructor (allocated_obj_exp, typ) cfg env in (* try to get the unqualified name as a class (e.g., Object for java.lang.Object so we * we can use it as a descriptive local variable name in the harness *) let typ_class_name = @@ -133,14 +133,14 @@ let rec inhabit_typ tenv typ cfg env = let fresh_local_exp = Exp.Lvar (Pvar.mk typ_class_name (Typ.Procname.Java env.harness_name)) in let write_to_local_instr = - Sil.Store (fresh_local_exp, ptr_to_typ, allocated_obj_exp, env.pc) in + Sil.Store (fresh_local_exp, typ, allocated_obj_exp, env.pc) in let env' = env_add_instr write_to_local_instr env in let fresh_id = Ident.create_fresh Ident.knormal in - let read_from_local_instr = Sil.Load (fresh_id, fresh_local_exp, ptr_to_typ, env'.pc) in + let read_from_local_instr = Sil.Load (fresh_id, fresh_local_exp, typ, env'.pc) in (Exp.Var fresh_id, env_add_instr read_from_local_instr env') | Typ.Tint (_) -> (Exp.Const (Const.Cint (IntLit.zero)), env) | Typ.Tfloat (_) -> (Exp.Const (Const.Cfloat 0.0), env) - | typ -> + | _ -> L.err "Couldn't inhabit typ: %a@." (Typ.pp Pp.text) typ; assert false in let (inhabited_exp, env') = @@ -173,7 +173,7 @@ and inhabit_constructor tenv constr_name (allocated_obj, obj_type) cfg env = let inhabit_call_with_args procname procdesc args env = let retval = let ret_typ = Procdesc.get_ret_type procdesc in - let is_void = Typ.equal ret_typ Typ.Tvoid in + let is_void = Typ.equal_desc ret_typ.Typ.desc Typ.Tvoid in if is_void then None else Some (Ident.create_fresh Ident.knormal, ret_typ) in let call_instr = let fun_exp = fun_exp_from_name procname in diff --git a/infer/src/java/jTrans.ml b/infer/src/java/jTrans.ml index 215f6748e..e743edc22 100644 --- a/infer/src/java/jTrans.ml +++ b/infer/src/java/jTrans.ml @@ -175,7 +175,7 @@ let translate_locals program tenv formals bytecode jbir_code = Array.fold ~f:(fun accu jbir_var -> let var = Mangled.from_string (JBir.var_name_g jbir_var) in - collect accu (var, Typ.Tvoid)) + collect accu (var, Typ.mk Tvoid)) ~init:with_bytecode_vars (JBir.vars jbir_code) in snd with_jbir_vars @@ -426,13 +426,13 @@ let rec expression (context : JContext.t) pc expr = | JBir.Neg _ -> (instrs, Exp.UnOp (Unop.Neg, sil_ex, Some type_of_expr), type_of_expr) | JBir.ArrayLength -> let array_typ_no_ptr = - match type_of_ex with + match type_of_ex.Typ.desc with | Typ.Tptr (typ, _) -> typ | _ -> type_of_ex in let deref = create_sil_deref sil_ex array_typ_no_ptr loc in let args = [(sil_ex, type_of_ex)] in let ret_id = Ident.create_fresh Ident.knormal in - let ret_typ = Typ.Tint IInt in + let ret_typ = Typ.mk (Tint IInt) in let call_instr = Sil.Call (Some (ret_id, ret_typ), builtin_get_array_length, args, loc, CallFlags.default) in @@ -453,10 +453,10 @@ let rec expression (context : JContext.t) pc expr = | JBir.InstanceOf _ -> Exp.Const (Const.Cfun BuiltinDecl.__instanceof) | JBir.Cast _ -> Exp.Const (Const.Cfun BuiltinDecl.__cast) | _ -> assert false) in - let args = [(sil_ex, type_of_ex); (sizeof_expr, Typ.Tvoid)] in + let args = [(sil_ex, type_of_ex); (sizeof_expr, Typ.mk Tvoid)] in let ret_id = Ident.create_fresh Ident.knormal in let call = - Sil.Call (Some (ret_id, Tint IBool), builtin, args, loc, CallFlags.default) in + Sil.Call (Some (ret_id, Typ.mk (Tint IBool)), builtin, args, loc, CallFlags.default) in let res_ex = Exp.Var ret_id in (instrs @ [call], res_ex, type_of_expr) end @@ -467,7 +467,7 @@ let rec expression (context : JContext.t) pc expr = match binop with | JBir.ArrayLoad _ -> (* add an instruction that dereferences the array *) - let array_typ = Typ.Tarray (type_of_expr, None) in + let array_typ = Typ.mk (Tarray (type_of_expr, None)) in let deref_array_instr = create_sil_deref sil_ex1 array_typ loc in let id = Ident.create_fresh Ident.knormal in let load_instr = @@ -548,7 +548,7 @@ let method_invocation match sil_obj_expr with | Exp.Var _ when is_non_constructor_call && not Config.report_runtime_exceptions -> let obj_typ_no_ptr = - match sil_obj_type with + match sil_obj_type.Typ.desc with | Typ.Tptr (typ, _) -> typ | _ -> sil_obj_type in [create_sil_deref sil_obj_expr obj_typ_no_ptr loc] @@ -571,7 +571,7 @@ let method_invocation let callee_fun = Exp.Const (Const.Cfun callee_procname) in let return_type = match JBasics.ms_rtype ms with - | None -> Typ.Tvoid + | None -> Typ.mk Tvoid | Some vt -> JTransType.value_type program tenv vt in let call_ret_instrs sil_var = let ret_id = Ident.create_fresh Ident.knormal in @@ -621,7 +621,7 @@ let get_array_length context pc expr_list content_type = (instrs @ other_instrs, sil_len_expr :: other_exprs) in let (instrs, sil_len_exprs) = List.fold_right ~f:get_expr_instr expr_list ~init:([],[]) in let get_array_type_len sil_len_expr (content_type, _) = - (Typ.Tarray (content_type, None), Some sil_len_expr) in + (Typ.mk (Tarray (content_type, None)), Some sil_len_expr) in let array_type, array_len = List.fold_right ~f:get_array_type_len sil_len_exprs ~init:(content_type, None) in let array_size = Exp.Sizeof (array_type, array_len, Subtype.exact) in @@ -689,7 +689,7 @@ let assume_not_null loc sil_expr = let not_null_expr = Exp.BinOp (Binop.Ne, sil_expr, Exp.null) in let assume_call_flag = { CallFlags.default with CallFlags.cf_noreturn = true; } in - let call_args = [(not_null_expr, Typ.Tint Typ.IBool)] in + let call_args = [(not_null_expr, Typ.mk (Tint Typ.IBool))] in Sil.Call (None, builtin_infer_assume, call_args, loc, assume_call_flag) @@ -711,7 +711,7 @@ let rec instruction (context : JContext.t) pc instr : translation = let instrs, sil_expr, sil_type = expression context pc expr in let builtin_const = Exp.Const (Const.Cfun builtin) in let instr = Sil.Call (None, builtin_const, [(sil_expr, sil_type)], loc, CallFlags.default) in - let typ_no_ptr = match sil_type with + let typ_no_ptr = match sil_type.Typ.desc with | Typ.Tptr (typ, _) -> typ | _ -> sil_type in let deref_instr = create_sil_deref sil_expr typ_no_ptr loc in @@ -1009,7 +1009,7 @@ let rec instruction (context : JContext.t) pc instr : translation = and sizeof_expr = JTransType.sizeof_of_object_type program tenv object_type Subtype.subtypes_instof in let check_cast = Exp.Const (Const.Cfun BuiltinDecl.__instanceof) in - let args = [(sil_expr, sil_type); (sizeof_expr, Typ.Tvoid)] in + let args = [(sil_expr, sil_type); (sizeof_expr, Typ.mk Tvoid)] in let call = Sil.Call (Some (ret_id, ret_type), check_cast, args, loc, CallFlags.default) in let res_ex = Exp.Var ret_id in let is_instance_node = diff --git a/infer/src/java/jTransExn.ml b/infer/src/java/jTransExn.ml index 7c721eca0..258aeec42 100644 --- a/infer/src/java/jTransExn.ml +++ b/infer/src/java/jTransExn.ml @@ -65,16 +65,16 @@ let translate_exceptions (context : JContext.t) exit_nodes get_body_nodes handle | Some cn -> cn in match JTransType.get_class_type context.program (JContext.get_tenv context) class_name with - | Typ.Tptr (typ, _) -> typ + | {Typ.desc=Tptr (typ, _)} -> typ | _ -> assert false in let id_instanceof = Ident.create_fresh Ident.knormal in let instr_call_instanceof = let instanceof_builtin = Exp.Const (Const.Cfun BuiltinDecl.__instanceof) in let args = [ - (Exp.Var id_exn_val, Typ.Tptr(exn_type, Typ.Pk_pointer)); - (Exp.Sizeof (exn_type, None, Subtype.exact), Typ.Tvoid)] in + (Exp.Var id_exn_val, Typ.mk (Tptr(exn_type, Typ.Pk_pointer))); + (Exp.Sizeof (exn_type, None, Subtype.exact), Typ.mk Tvoid)] in Sil.Call - (Some (id_instanceof, Tint IBool), instanceof_builtin, args, loc, CallFlags.default) in + (Some (id_instanceof, Typ.mk (Tint IBool)), instanceof_builtin, args, loc, CallFlags.default) in let if_kind = Sil.Ik_switch in let instr_prune_true = Sil.Prune (Exp.Var id_instanceof, loc, true, if_kind) in let instr_prune_false = diff --git a/infer/src/java/jTransType.ml b/infer/src/java/jTransType.ml index 6cb673bd8..590abadb8 100644 --- a/infer/src/java/jTransType.ml +++ b/infer/src/java/jTransType.ml @@ -18,32 +18,32 @@ open Sawja_pack exception Type_tranlsation_error of string let basic_type = function - | `Int -> Typ.Tint Typ.IInt - | `Bool -> Typ.Tint Typ.IBool - | `Byte -> Typ.Tint Typ.IChar - | `Char -> Typ.Tint Typ.IChar - | `Double -> Typ.Tfloat Typ.FDouble - | `Float -> Typ.Tfloat Typ.FFloat - | `Long -> Typ.Tint Typ.ILong - | `Short -> Typ.Tint Typ.IShort + | `Int -> Typ.mk (Tint Typ.IInt) + | `Bool -> Typ.mk (Tint Typ.IBool) + | `Byte -> Typ.mk (Tint Typ.IChar) + | `Char -> Typ.mk (Tint Typ.IChar) + | `Double -> Typ.mk (Tfloat Typ.FDouble) + | `Float -> Typ.mk (Tfloat Typ.FFloat) + | `Long -> Typ.mk (Tint Typ.ILong) + | `Short -> Typ.mk (Tint Typ.IShort) let cast_type = function | JBir.F2I | JBir.L2I - | JBir.D2I -> Typ.Tint Typ.IInt + | JBir.D2I -> Typ.mk (Typ.Tint Typ.IInt) | JBir.D2L | JBir.F2L - | JBir.I2L -> Typ.Tint Typ.ILong + | JBir.I2L -> Typ.mk (Typ.Tint Typ.ILong) | JBir.I2F | JBir.L2F - | JBir.D2F -> Typ.Tfloat Typ.FFloat + | JBir.D2F -> Typ.mk (Typ.Tfloat Typ.FFloat) | JBir.L2D | JBir.F2D - | JBir.I2D -> Typ.Tfloat Typ.FDouble - | JBir.I2B -> Typ.Tint Typ.IBool - | JBir.I2C -> Typ.Tint Typ.IChar - | JBir.I2S -> Typ.Tint Typ.IShort + | JBir.I2D -> Typ.mk (Typ.Tfloat Typ.FDouble) + | JBir.I2B -> Typ.mk (Typ.Tint Typ.IBool) + | JBir.I2C -> Typ.mk (Typ.Tint Typ.IChar) + | JBir.I2S -> Typ.mk (Typ.Tint Typ.IShort) let const_type const = @@ -61,7 +61,7 @@ let typename_of_classname cn = Typ.Name.Java.from_string (JBasics.cn_name cn) -let rec get_named_type vt = +let rec get_named_type vt : Typ.t = match vt with | JBasics.TBasic bt -> basic_type bt | JBasics.TObject ot -> @@ -69,13 +69,14 @@ let rec get_named_type vt = match ot with | JBasics.TArray vt -> let content_type = get_named_type vt in - Typ.Tptr (Typ.Tarray (content_type, None), Typ.Pk_pointer) - | JBasics.TClass cn -> Typ.Tptr (Typ.Tstruct (typename_of_classname cn), Typ.Pk_pointer) + Typ.mk (Tptr (Typ.mk (Tarray (content_type, None)), Typ.Pk_pointer)) + | JBasics.TClass cn -> + Typ.mk (Tptr (Typ.mk (Tstruct (typename_of_classname cn)), Typ.Pk_pointer)) end let extract_cn_type_np typ = - match typ with + match typ.Typ.desc with | Typ.Tptr(vtyp, Typ.Pk_pointer) -> vtyp | _ -> typ @@ -83,12 +84,12 @@ let extract_cn_type_np typ = let rec create_array_type typ dim = if dim > 0 then let content_typ = create_array_type typ (dim - 1) in - Typ.Tptr(Typ.Tarray (content_typ, None), Typ.Pk_pointer) + Typ.mk (Tptr(Typ.mk (Tarray (content_typ, None)), Typ.Pk_pointer)) else typ let extract_cn_no_obj typ = - match typ with - | Typ.Tptr (Tstruct (JavaClass _ as name), Pk_pointer) -> + match typ.Typ.desc with + | Typ.Tptr ({desc=Tstruct (JavaClass _ as name)}, Pk_pointer) -> let class_name = JBasics.make_cn (Typ.Name.name name) in if JBasics.cn_equal class_name JBasics.java_lang_object then None else @@ -340,10 +341,10 @@ and get_class_struct_typ program tenv cn = let get_class_type_no_pointer program tenv cn = ignore (get_class_struct_typ program tenv cn); - Typ.Tstruct (typename_of_classname cn) + Typ.mk (Tstruct (typename_of_classname cn)) let get_class_type program tenv cn = - Typ.Tptr (get_class_type_no_pointer program tenv cn, Pk_pointer) + Typ.mk (Tptr (get_class_type_no_pointer program tenv cn, Pk_pointer)) (** return true if [field_name] is the autogenerated C.$assertionsDisabled field for class C *) let is_autogenerated_assert_field field_name = @@ -362,7 +363,8 @@ let is_closeable program tenv typ = let rec object_type program tenv ot = match ot with | JBasics.TClass cn -> get_class_type program tenv cn - | JBasics.TArray at -> Typ.Tptr (Typ.Tarray (value_type program tenv at, None), Typ.Pk_pointer) + | JBasics.TArray at -> + Typ.mk (Tptr (Typ.mk (Tarray (value_type program tenv at, None)), Typ.Pk_pointer)) (** translate a value type *) and value_type program tenv vt = @@ -373,7 +375,7 @@ and value_type program tenv vt = (** Translate object types into Exp.Sizeof expressions *) let sizeof_of_object_type program tenv ot subtypes = - match object_type program tenv ot with + match (object_type program tenv ot).Typ.desc with | Typ.Tptr (typ, _) -> Exp.Sizeof (typ, None, subtypes) | _ -> @@ -407,8 +409,8 @@ let get_var_type context var = let extract_array_type typ = - match typ with - | Typ.Tptr(Typ.Tarray (vtyp, _), Typ.Pk_pointer) -> vtyp + match typ.Typ.desc with + | Typ.Tptr({desc=Tarray (vtyp, _)}, Typ.Pk_pointer) -> vtyp | _ -> typ @@ -433,7 +435,7 @@ let rec expr_type (context : JContext.t) expr = specified in ms. *) let return_type program tenv ms = match JBasics.ms_rtype ms with - | None -> Typ.Tvoid + | None -> Typ.mk Tvoid | Some vt -> value_type program tenv vt diff --git a/infer/src/quandary/JavaTaintAnalysis.ml b/infer/src/quandary/JavaTaintAnalysis.ml index 739855162..c648d019c 100644 --- a/infer/src/quandary/JavaTaintAnalysis.ml +++ b/infer/src/quandary/JavaTaintAnalysis.ml @@ -24,8 +24,8 @@ include | _ -> assert false let handle_unknown_call pname ret_typ_opt actuals tenv = - let types_match typ class_string tenv = match typ with - | Typ.Tptr (Tstruct original_typename, _) -> + let types_match typ class_string tenv = match typ.Typ.desc with + | Typ.Tptr ({desc=Tstruct original_typename}, _) -> PatternMatch.supertype_exists tenv (fun typename _ -> String.equal (Typ.Name.name typename) class_string) @@ -45,10 +45,10 @@ include [] | _ when Typ.Procname.is_constructor pname -> [TaintSpec.Propagate_to_receiver] - | _, _, (Some Typ.Tvoid | None) when not is_static -> + | _, _, (Some {Typ.desc=Tvoid} | None) when not is_static -> (* for instance methods with no return value, propagate the taint to the receiver *) [TaintSpec.Propagate_to_receiver] - | classname, _, Some (Typ.Tptr _ | Tstruct _) -> + | classname, _, Some ({Typ.desc=Tptr _ | Tstruct _}) -> begin match actuals with | (_, receiver_typ) :: _ @@ -70,8 +70,8 @@ include failwithf "Non-Java procname %a in Java analysis@." Typ.Procname.pp pname let is_taintable_type typ= - match typ with - | Typ.Tptr (Tstruct (JavaClass typename), _) | Tstruct (JavaClass typename) -> + match typ.Typ.desc with + | Typ.Tptr ({desc=Tstruct (JavaClass typename)}, _) | Tstruct (JavaClass typename) -> begin match Mangled.to_string_full typename with | "android.content.Intent" diff --git a/infer/src/quandary/JavaTrace.ml b/infer/src/quandary/JavaTrace.ml index 6d4e2428b..478365006 100644 --- a/infer/src/quandary/JavaTrace.ml +++ b/infer/src/quandary/JavaTrace.ml @@ -85,8 +85,8 @@ module SourceKind = struct name, typ, None in let taint_formals_with_types type_strs kind formals = let taint_formal_with_types ((formal_name, formal_typ) as formal) = - let matches_classname = match formal_typ with - | Typ.Tptr (Tstruct typename, _) -> + let matches_classname = match formal_typ.Typ.desc with + | Tptr ({desc=Tstruct typename}, _) -> List.mem ~equal:String.equal type_strs (Typ.Name.name typename) | _ -> false in diff --git a/infer/src/quandary/TaintAnalysis.ml b/infer/src/quandary/TaintAnalysis.ml index 964d82057..a733ca3a7 100644 --- a/infer/src/quandary/TaintAnalysis.ml +++ b/infer/src/quandary/TaintAnalysis.ml @@ -203,9 +203,9 @@ module Make (TaintSpecification : TaintSpec.S) = struct match AccessPath.of_lhs_exp actual_exp actual_typ ~f_resolve_id with | Some actual_ap_raw -> let actual_ap = - let is_array_typ = match actual_typ with - | Typ.Tptr (Tarray _, _) (* T* [] (Java-style) *) - | Tptr (Tptr _, _) (* T** (C/C++ style 1) *) + let is_array_typ = match actual_typ.Typ.desc with + | Typ.Tptr ({desc=Tarray _}, _) (* T* [] (Java-style) *) + | Tptr ({desc=Tptr _}, _) (* T** (C/C++ style 1) *) | Tarray _ (* T[] C/C++ style 2 *) -> true | _ -> @@ -330,7 +330,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct astate | Sil.Store (Exp.Lvar lhs_pvar, _, rhs_exp, _) when Pvar.is_return lhs_pvar && Exp.is_null_literal rhs_exp && - Typ.equal Tvoid (Procdesc.get_ret_type proc_data.pdesc) -> + Typ.equal_desc Tvoid (Procdesc.get_ret_type proc_data.pdesc).desc -> (* similar to the case above; the Java frontend translates "return no exception" as `return null` in a void function *) astate diff --git a/infer/src/unit/BoundedCallTreeTests.ml b/infer/src/unit/BoundedCallTreeTests.ml index a89b30e24..b66a2f5e2 100644 --- a/infer/src/unit/BoundedCallTreeTests.ml +++ b/infer/src/unit/BoundedCallTreeTests.ml @@ -24,8 +24,8 @@ let tests = let initial = BoundedCallTree.Domain.empty in let f_proc_name = Typ.Procname.from_string_c_fun "f" in let g_proc_name = Typ.Procname.from_string_c_fun "g" in - let g_args = [((Exp.Const (Const.Cint (IntLit.one))), (Typ.Tint IInt))] in - let g_ret_id = Some (ident_of_str "r", Typ.Tint IInt) in + let g_args = [((Exp.Const (Const.Cint (IntLit.one))), (Typ.mk (Tint IInt)))] in + let g_ret_id = Some (ident_of_str "r", Typ.mk (Tint IInt)) in let class_name = "com.example.SomeClass" in let file_name = "SomeClass.java" in let trace = Stacktrace.make "java.lang.NullPointerException" diff --git a/infer/src/unit/TaintTests.ml b/infer/src/unit/TaintTests.ml index ff2de0281..e4a04298e 100644 --- a/infer/src/unit/TaintTests.ml +++ b/infer/src/unit/TaintTests.ml @@ -105,9 +105,9 @@ let tests = call_sink_with_exp (Exp.Var (ident_of_str actual_str)) in let assign_id_to_field root_str fld_str rhs_id_str = let rhs_exp = Exp.Var (ident_of_str rhs_id_str) in - make_store ~rhs_typ:Typ.Tvoid (Exp.Var (ident_of_str root_str)) fld_str ~rhs_exp in + make_store ~rhs_typ:(Typ.mk Tvoid) (Exp.Var (ident_of_str root_str)) fld_str ~rhs_exp in let read_field_to_id lhs_id_str root_str fld_str = - make_load_fld ~rhs_typ:Typ.Tvoid lhs_id_str fld_str (Exp.Var (ident_of_str root_str)) in + make_load_fld ~rhs_typ:(Typ.mk Tvoid) lhs_id_str fld_str (Exp.Var (ident_of_str root_str)) in let assert_empty = invariant "{ }" in (* hack: register an empty analyze_ondemand to prevent a crash because the callback is unset *) let analyze_ondemand _ summary _ = summary in @@ -257,7 +257,7 @@ let tests = "source -> sink via cast", [ assign_to_source "ret_id"; - cast_id_to_id "cast_id" Typ.Tvoid "ret_id"; + cast_id_to_id "cast_id" (Typ.mk Tvoid) "ret_id"; call_sink "cast_id"; invariant "{ ret_id$0 => (SOURCE -> SINK) }"; ]; diff --git a/infer/src/unit/TraceTests.ml b/infer/src/unit/TraceTests.ml index 364b552fe..8d977a487 100644 --- a/infer/src/unit/TraceTests.ml +++ b/infer/src/unit/TraceTests.ml @@ -113,7 +113,7 @@ let tests = let append = let append_ _ = let call_site = CallSite.dummy in - let footprint_ap = AccessPath.Exact (AccessPath.of_id (Ident.create_none ()) Typ.Tvoid) in + let footprint_ap = AccessPath.Exact (AccessPath.of_id (Ident.create_none ()) (Typ.mk Tvoid)) in let dummy_pdesc = Cfg.create_proc_desc (Cfg.create_cfg ()) diff --git a/infer/src/unit/accessPathTestUtils.ml b/infer/src/unit/accessPathTestUtils.ml index c635b54c7..1c88bb8be 100644 --- a/infer/src/unit/accessPathTestUtils.ml +++ b/infer/src/unit/accessPathTestUtils.ml @@ -12,7 +12,7 @@ open! IStd let make_var var_str = Pvar.mk (Mangled.from_string var_str) Typ.Procname.empty_block -let make_base ?(typ=Typ.Tvoid) base_str = +let make_base ?(typ=Typ.mk Tvoid) base_str = AccessPath.base_of_pvar (make_var base_str) typ let make_fieldname = Fieldname.Java.from_string diff --git a/infer/src/unit/accessPathTests.ml b/infer/src/unit/accessPathTests.ml index 8087616ee..181a12a69 100644 --- a/infer/src/unit/accessPathTests.ml +++ b/infer/src/unit/accessPathTests.ml @@ -21,8 +21,8 @@ let tests = let xFG = make_access_path "x" ["f"; "g";] in let yF = make_access_path "y" ["f"] in let xArr = - let dummy_typ = Typ.Tvoid in - let dummy_arr_typ = Typ.Tarray (dummy_typ, None) in + let dummy_typ = Typ.mk Tvoid in + let dummy_arr_typ = Typ.mk (Tarray (dummy_typ, None)) in let base = make_base "x" ~typ:dummy_arr_typ in base, [make_array_access dummy_typ] in @@ -74,7 +74,7 @@ let tests = let of_exp_test = let f_resolve_id _ = None in - let dummy_typ = Typ.Tvoid in + let dummy_typ = Typ.mk Tvoid in let check_make_ap exp expected_ap ~f_resolve_id = let make_ap exp = diff --git a/infer/src/unit/accessTreeTests.ml b/infer/src/unit/accessTreeTests.ml index 006782f7c..ceb11ce7d 100644 --- a/infer/src/unit/accessTreeTests.ml +++ b/infer/src/unit/accessTreeTests.ml @@ -70,7 +70,7 @@ let tests = let f = make_field_access "f" in let g = make_field_access "g" in - let array = make_array_access Typ.Tvoid in + let array = make_array_access (Typ.mk Tvoid) in let x = AccessPath.Exact (make_access_path "x" []) in let xF = AccessPath.Exact (make_access_path "x" ["f"]) in diff --git a/infer/src/unit/addressTakenTests.ml b/infer/src/unit/addressTakenTests.ml index f461fc2f2..7dd4119c8 100644 --- a/infer/src/unit/addressTakenTests.ml +++ b/infer/src/unit/addressTakenTests.ml @@ -17,9 +17,9 @@ let tests = let open OUnit2 in let open AnalyzerTester.StructuredSil in let assert_empty = invariant "{ }" in - let int_typ = Typ.Tint IInt in - let int_ptr_typ = Typ.Tptr (int_typ, Pk_pointer) in - let fun_ptr_typ = Typ.Tptr (Tfun false, Pk_pointer) in + let int_typ = Typ.mk (Tint IInt) in + let int_ptr_typ = Typ.mk (Tptr (int_typ, Pk_pointer)) in + let fun_ptr_typ = Typ.mk (Tptr (Typ.mk (Tfun false), Pk_pointer)) in let closure_exp captureds = let mk_captured_var str = (Exp.Var (ident_of_str str), pvar_of_str str, int_ptr_typ) in let captured_vars = List.map ~f:mk_captured_var captureds in diff --git a/infer/src/unit/analyzerTester.ml b/infer/src/unit/analyzerTester.ml index 42ba56017..6ff843e66 100644 --- a/infer/src/unit/analyzerTester.ml +++ b/infer/src/unit/analyzerTester.ml @@ -59,7 +59,7 @@ module StructuredSil = struct let pp_structured_program = pp_structured_instr_list - let dummy_typ = Typ.Tvoid + let dummy_typ = Typ.mk Tvoid let dummy_loc = Location.dummy let dummy_procname = Typ.Procname.empty_block @@ -132,7 +132,7 @@ module StructuredSil = struct let var_assign_int lhs rhs = let rhs_exp = Exp.int (IntLit.of_int rhs) in - let rhs_typ = Typ.Tint Typ.IInt in + let rhs_typ = Typ.mk (Tint Typ.IInt) in var_assign_exp ~rhs_typ lhs rhs_exp let var_assign_id ?(rhs_typ=dummy_typ) lhs rhs = diff --git a/infer/src/unit/livenessTests.ml b/infer/src/unit/livenessTests.ml index f18dd74a2..959f4f98d 100644 --- a/infer/src/unit/livenessTests.ml +++ b/infer/src/unit/livenessTests.ml @@ -18,7 +18,7 @@ let tests = let open OUnit2 in let open AnalyzerTester.StructuredSil in let assert_empty = invariant "{ }" in - let fun_ptr_typ = Typ.Tptr (Tfun false, Pk_pointer) in + let fun_ptr_typ = Typ.mk (Tptr (Typ.mk (Tfun false), Pk_pointer)) in let closure_exp captured_pvars = let mk_captured_var str = (Exp.Var (ident_of_str str), pvar_of_str str, dummy_typ) in let captured_vars = List.map ~f:mk_captured_var captured_pvars in @@ -97,7 +97,7 @@ let tests = "dead_after_call_with_retval", [ assert_empty; - call_unknown (Some ("y", Typ.Tint IInt)) []; + call_unknown (Some ("y", Typ.mk (Tint IInt))) []; invariant "{ y$0 }"; id_assign_id "x" "y"; ];