From 9108321d014109355520f4f859588a142f88dbf2 Mon Sep 17 00:00:00 2001
From: Thibault Martin <thi.martin.pro@pm.me>
Date: Wed, 13 Nov 2024 16:21:45 +0100
Subject: [PATCH] [kernel] Use a record for Cil_types.typ
Add a record with 2 fields : tnode and tattr
---
src/kernel_internals/typing/asm_contracts.ml | 4 +-
src/kernel_internals/typing/cabs2cil.ml | 506 ++++----
src/kernel_internals/typing/ghost_accesses.ml | 10 +-
src/kernel_internals/typing/infer_assigns.ml | 18 +-
src/kernel_internals/typing/logic_builtin.ml | 3 +-
src/kernel_internals/typing/mergecil.ml | 68 +-
src/kernel_internals/typing/oneret.ml | 6 +-
src/kernel_internals/typing/rmtmps.ml | 45 +-
.../typing/substitute_const_globals.ml | 5 +-
src/kernel_services/abstract_interp/base.ml | 13 +-
src/kernel_services/abstract_interp/cvalue.ml | 8 +-
.../abstract_interp/offsetmap.ml | 3 +-
src/kernel_services/analysis/bit_utils.ml | 73 +-
src/kernel_services/analysis/exn_flow.ml | 54 +-
.../ast_building/cil_builder.ml | 91 +-
src/kernel_services/ast_data/alarms.ml | 20 +-
src/kernel_services/ast_data/annotations.ml | 4 +-
src/kernel_services/ast_data/cil_types.ml | 40 +-
src/kernel_services/ast_data/globals.ml | 10 +-
.../ast_data/kernel_function.ml | 4 +-
src/kernel_services/ast_data/machine.ml | 14 +-
.../ast_printing/cil_printer.ml | 91 +-
.../ast_printing/cil_types_debug.ml | 31 +-
.../ast_printing/printer_tag.ml | 45 +-
src/kernel_services/ast_queries/ast_diff.ml | 60 +-
src/kernel_services/ast_queries/ast_info.ml | 44 +-
src/kernel_services/ast_queries/ast_info.mli | 6 +-
src/kernel_services/ast_queries/cil.ml | 1052 +++++++++--------
src/kernel_services/ast_queries/cil.mli | 31 +-
.../ast_queries/cil_builtins.ml | 28 +-
src/kernel_services/ast_queries/cil_const.ml | 73 +-
src/kernel_services/ast_queries/cil_const.mli | 56 +
.../ast_queries/cil_datatype.ml | 136 +--
.../ast_queries/cil_datatype.mli | 8 +-
src/kernel_services/ast_queries/file.ml | 18 +-
src/kernel_services/ast_queries/filecheck.ml | 18 +-
.../ast_queries/logic_const.ml | 2 +-
src/kernel_services/ast_queries/logic_env.ml | 4 +-
src/kernel_services/ast_queries/logic_to_c.ml | 10 +-
.../ast_queries/logic_typing.ml | 76 +-
.../ast_queries/logic_utils.ml | 73 +-
.../ast_transformations/filter.ml | 4 +-
.../ast_transformations/inline.ml | 4 +-
src/plugins/alias/src/abstract_state.ml | 4 +-
src/plugins/alias/src/simplified.ml | 4 +-
src/plugins/aorai/aorai_utils.ml | 14 +-
src/plugins/aorai/aorai_visitors.ml | 8 +-
src/plugins/aorai/data_for_aorai.ml | 10 +-
src/plugins/aorai/yaparser.mly | 7 +-
src/plugins/constant_propagation/api.ml | 18 +-
src/plugins/dive/build.ml | 6 +-
src/plugins/dive/node_range.ml | 6 +-
src/plugins/e-acsl/src/analyses/interval.ml | 14 +-
src/plugins/e-acsl/src/analyses/typing.ml | 62 +-
.../e-acsl/src/code_generator/assert.ml | 21 +-
.../e-acsl/src/code_generator/assigns.ml | 22 +-
.../e-acsl/src/code_generator/contract.ml | 2 +-
.../src/code_generator/global_observer.ml | 4 +-
src/plugins/e-acsl/src/code_generator/gmp.ml | 16 +-
.../e-acsl/src/code_generator/injector.ml | 5 +-
.../src/code_generator/logic_functions.ml | 26 +-
.../src/code_generator/memory_translate.ml | 6 +-
.../e-acsl/src/code_generator/smart_exp.ml | 6 +-
.../e-acsl/src/code_generator/smart_stmt.ml | 26 +-
.../e-acsl/src/code_generator/temporal.ml | 14 +-
.../src/code_generator/translate_ats.ml | 2 +-
.../src/code_generator/translate_terms.ml | 6 +-
src/plugins/e-acsl/src/libraries/builtins.ml | 8 +-
src/plugins/e-acsl/src/libraries/functions.ml | 36 +-
src/plugins/e-acsl/src/libraries/gmp_types.ml | 19 +-
.../e-acsl/src/libraries/interval_utils.ml | 16 +-
.../e-acsl/src/libraries/logic_aggr.ml | 6 +-
src/plugins/e-acsl/src/libraries/misc.ml | 4 +-
.../src/project_initializer/prepare_ast.ml | 5 +-
src/plugins/eva/alarmset.ml | 4 +-
src/plugins/eva/api/values_request.ml | 2 +-
src/plugins/eva/ast/eva_ast_builder.ml | 14 +-
src/plugins/eva/ast/eva_ast_typing.ml | 14 +-
src/plugins/eva/ast/eva_ast_utils.ml | 15 +-
src/plugins/eva/domains/apron/apron_domain.ml | 14 +-
src/plugins/eva/domains/cvalue/builtins.ml | 4 +-
.../eva/domains/cvalue/builtins_float.ml | 4 +-
.../eva/domains/cvalue/builtins_malloc.ml | 19 +-
.../eva/domains/cvalue/builtins_memory.ml | 10 +-
src/plugins/eva/domains/cvalue/cvalue_init.ml | 38 +-
.../eva/domains/multidim/abstract_offset.ml | 14 +-
src/plugins/eva/domains/multidim/multidim.ml | 4 +-
.../eva/domains/multidim/multidim_domain.ml | 6 +-
src/plugins/eva/domains/octagons.ml | 2 +-
src/plugins/eva/engine/evaluation.ml | 23 +-
src/plugins/eva/gui/register_gui.ml | 7 +-
src/plugins/eva/legacy/eval_op.ml | 4 +-
src/plugins/eva/legacy/eval_terms.ml | 39 +-
src/plugins/eva/utils/eval_typ.ml | 43 +-
src/plugins/eva/utils/export.ml | 4 +-
src/plugins/eva/utils/library_functions.ml | 12 +-
src/plugins/eva/utils/unit_tests.ml | 2 +-
src/plugins/eva/utils/widen.ml | 4 +-
src/plugins/eva/values/cvalue_backward.ml | 23 +-
src/plugins/eva/values/cvalue_forward.ml | 6 +-
src/plugins/eva/values/main_values.ml | 6 +-
src/plugins/eva/values/sign_value.ml | 4 +-
src/plugins/gui/design.ml | 12 +-
src/plugins/gui/gui_printers.ml | 26 +-
src/plugins/instantiate/basic_blocks.ml | 73 +-
src/plugins/instantiate/basic_blocks.mli | 3 -
src/plugins/instantiate/stdlib/basic_alloc.ml | 8 +-
src/plugins/instantiate/stdlib/calloc.ml | 20 +-
src/plugins/instantiate/stdlib/free.ml | 4 +-
src/plugins/instantiate/stdlib/malloc.ml | 10 +-
src/plugins/instantiate/string/mem_utils.ml | 6 +-
src/plugins/instantiate/string/memset.ml | 42 +-
.../api/external_instantiator_registration.ml | 10 +-
.../instantiate/tests/plugin/needs_global.ml | 8 +-
src/plugins/obfuscator/obfuscate.ml | 7 +-
src/plugins/pdg/build.ml | 4 +-
src/plugins/reduc/collect.ml | 10 +-
src/plugins/region/annot.ml | 4 +-
src/plugins/region/fields.ml | 4 +-
src/plugins/region/memory.ml | 2 +-
src/plugins/region/services.ml | 12 +-
src/plugins/rte/rte.ml | 10 +-
src/plugins/rte/visit.ml | 34 +-
src/plugins/server/kernel_ast.ml | 12 +-
src/plugins/slicing/gui/register_gui.ml | 4 +-
src/plugins/slicing/slicingMacros.ml | 4 +-
src/plugins/sparecode/globs.ml | 8 +-
src/plugins/variadic/classify.ml | 10 +-
src/plugins/variadic/environment.ml | 8 +-
src/plugins/variadic/extends.ml | 8 +-
src/plugins/variadic/format_typer.ml | 4 +-
src/plugins/variadic/generic.ml | 17 +-
src/plugins/variadic/standard.ml | 50 +-
src/plugins/wp/CodeSemantics.ml | 27 +-
src/plugins/wp/Layout.ml | 18 +-
src/plugins/wp/LogicSemantics.ml | 4 +-
src/plugins/wp/MemBytes.ml | 2 +-
src/plugins/wp/MemTyped.ml | 2 +-
src/plugins/wp/MemVar.ml | 12 +-
src/plugins/wp/MemoryContext.ml | 8 +-
src/plugins/wp/Why3Import.ml | 2 +-
src/plugins/wp/ctypes.ml | 55 +-
tests/cil/Change_formals.ml | 10 +-
tests/libc/check_libc_anonymous_tags.ml | 6 +-
tests/misc/exception.ml | 10 +-
tests/spec/model.ml | 2 +-
tests/syntax/ghost_cv_var_decl.ml | 6 +-
tests/syntax/transient_block.ml | 2 +-
148 files changed, 2163 insertions(+), 2050 deletions(-)
diff --git a/src/kernel_internals/typing/asm_contracts.ml b/src/kernel_internals/typing/asm_contracts.ml
index 004d7625ab6..25198e9ec44 100644
--- a/src/kernel_internals/typing/asm_contracts.ml
+++ b/src/kernel_internals/typing/asm_contracts.ml
@@ -102,8 +102,8 @@ let access_elts ~loc ?size tlv =
let extract_mem_term ~loc acc tlv =
match Logic_utils.unroll_type (Cil.typeOfTermLval tlv) with
- | Ctype (TPtr _ ) -> access_ptr_elts ~loc tlv :: acc
- | Ctype (TArray(_,e,_)) ->
+ | Ctype { tnode = TPtr _ } -> access_ptr_elts ~loc tlv :: acc
+ | Ctype { tnode = TArray (_,e) } ->
let size = Option.bind e (Cil.constFoldToInt ~machdep:true) in
access_elts ~loc ?size tlv :: acc
| _ -> acc
diff --git a/src/kernel_internals/typing/cabs2cil.ml b/src/kernel_internals/typing/cabs2cil.ml
index 8ca38fc5074..d227ff51cde 100644
--- a/src/kernel_internals/typing/cabs2cil.ml
+++ b/src/kernel_internals/typing/cabs2cil.ml
@@ -761,8 +761,8 @@ let isOldStyleVarArgTypeName n =
*)
let check_logical_operand e t =
let (source,_) = e.expr_loc in
- match Cil.unrollType t with
- | TInt(IBool, _) ->
+ match Cil.unrollTypeNode t with
+ | TInt IBool ->
Kernel.warning ~wkey:Kernel.wkey_cert_exp_46 ~source
"operand of bitwise operator has boolean type"
| _ ->
@@ -1145,7 +1145,7 @@ let gnu_body_result : (Cabs.statement * ((exp * typ) option ref)) ref
(*** When we do statements we need to know the current return type *)
let dummy_function = emptyFunction "@dummy@"
-let currentReturnType : typ ref = ref (TVoid([]))
+let currentReturnType : typ ref = ref voidType
let currentFunctionFDEC: fundec ref = ref dummy_function
let lastStructId = ref 0
@@ -1253,12 +1253,12 @@ let alphaConvertVarAndAddToEnv addtoenv vi =
let constFoldTypeVisitor = object
inherit nopCilVisitor
- method! vtype t: typ visitAction =
- match t with
- | TArray(bt, Some len, a) ->
+ method! vtype { tnode; tattr }: typ visitAction =
+ match tnode with
+ | TArray(bt, Some len) ->
let len' = constFold true len in
ChangeDoChildrenPost (
- TArray(bt, Some len', a),
+ mk_tarray ~tattr bt (Some len'),
(fun x -> x)
)
| _ -> DoChildren
@@ -1353,7 +1353,7 @@ let createCompInfo (iss: bool) (n: string) ~(norig: string) : compinfo * bool =
with Not_found -> begin
(* Create a compinfo. This will have "cdefined" false. *)
let res =
- Cil_const.mkCompInfo
+ mkCompInfo
iss n ~norig (fun _ -> None) (fc_stdlib_attribute [])
in
H.add compInfoNameEnv key res;
@@ -1378,7 +1378,7 @@ let createEnumInfo (n: string) ~(norig:string) : enuminfo * bool =
(* kind is either "struct" or "union" or "enum" and n is a name *)
-let findCompType ghost kind name attr =
+let findCompType ghost kind name tattr =
let makeForward () =
(* This is a forward reference, either because we have not seen this
* struct already or because we want to create a version with different
@@ -1387,19 +1387,19 @@ let findCompType ghost kind name attr =
let enum, isnew = createEnumInfo name ~norig:name in
if isnew then
cabsPushGlobal (GEnumTagDecl (enum, Current_loc.get ()));
- TEnum (enum, attr)
+ mk_tenum ~tattr enum
else
let iss = if kind = "struct" then true else false in
let self, isnew = createCompInfo iss name ~norig:name in
if isnew then
cabsPushGlobal (GCompTagDecl (self, Current_loc.get ()));
- TComp (self, attr)
+ mk_tcomp ~tattr self
in
try
let old, _ = lookupTypeNoError ghost kind name in (* already defined *)
let olda = typeAttrs old in
let equal =
- try List.for_all2 Cil_datatype.Attribute.equal olda attr
+ try List.for_all2 Cil_datatype.Attribute.equal olda tattr
with Invalid_argument _ -> false
in
if equal then old else makeForward ()
@@ -1449,18 +1449,10 @@ let integralPromotion = Cil.integralPromotion
exceptions, also listed in 6.3.2.1:2 *)
let dropQualifiers = Cil.type_remove_qualifier_attributes
-let is_scalar_type t =
- match unrollType t with
- | TInt _
- | TPtr _
- | TEnum _
- | TFloat _ -> true
- | _ -> false
-
(* A cast that is used for conditional expressions. Pointers are Ok.
Abort if invalid *)
let checkBool (ot : typ) (_ : exp) =
- if not (is_scalar_type ot) then
+ if not (Cil.isScalarType ot) then
abort_context "cannot cast expr of type %a into a boolean value"
Cil_datatype.Typ.pretty ot
@@ -2601,9 +2593,10 @@ let rec cabsTypeCombineAttributes what a0 t =
| _ ->
(* anything else: add a0 to existing attributes *)
let add (a: attributes) = combine a0 a in
- match t with
- | TVoid a -> TVoid (add a)
- | TInt (ik, a) ->
+ let tattr = add t.tattr in
+ match t.tnode with
+ | TVoid -> mk_tvoid ~tattr ()
+ | TInt ik ->
(* Here we have to watch for the mode attribute *)
(* sm: This stuff is to handle a GCC extension where you can request integers*)
(* of specific widths using the "mode" attribute syntax; for example: *)
@@ -2654,24 +2647,27 @@ let rec cabsTypeCombineAttributes what a0 t =
(ik, [])
a0
in
- TInt (ik', combine a0' a)
-
- | TFloat (fk, a) -> TFloat (fk, add a)
- | TEnum (enum, a) -> TEnum (enum, add a)
- | TPtr (t, a) -> TPtr (t, add a)
- | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
- | TComp (comp, a) -> TComp (comp, add a)
- | TNamed (t, a) -> TNamed (t, add a)
- | TBuiltin_va_list a -> TBuiltin_va_list (add a)
- | TArray (t, l, a) ->
+ mk_tint ~tattr:(combine a0' t.tattr) ik'
+
+ | TFloat fk -> mk_tfloat ~tattr fk
+ | TEnum enum -> mk_tenum ~tattr enum
+ | TPtr t -> mk_tptr ~tattr t
+ | TFun (t, args, isva) -> mk_tfun ~tattr t args isva
+ | TComp comp -> mk_tcomp ~tattr comp
+ | TNamed ti -> mk_tnamed ~tattr ti
+ | TBuiltin_va_list -> mk_tbuiltin ~tattr ()
+ | TArray (bt, l) ->
let att_elt, att_typ = Cil.splitArrayAttributes a0 in
- TArray (cabsArrayPushAttributes what att_elt t, l,
- combineAttributes what att_typ a)
+ let bt' = cabsArrayPushAttributes what att_elt bt in
+ let tattr = combineAttributes what att_typ t.tattr in
+ mk_tarray ~tattr bt' l
end
-and cabsArrayPushAttributes what al = function
- | TArray (bt, l, a) ->
- TArray (cabsArrayPushAttributes what al bt, l, a)
- | t -> cabsTypeCombineAttributes what al t
+and cabsArrayPushAttributes what al t =
+ match t.tnode with
+ | TArray (bt, l) ->
+ let bt' = cabsArrayPushAttributes what al bt in
+ mk_tarray ~tattr:t.tattr bt' l
+ | _ -> cabsTypeCombineAttributes what al t
let cabsTypeAddAttributes =
cabsTypeCombineAttributes CombineOther
@@ -2788,8 +2784,8 @@ let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool =
(* Let's mutate the formals vid's name attribute and type for function
prototypes. Logic specifications refer to the varinfo in this table. *)
begin
- match vi.vtype with
- | TFun (_,Some formals , _, _) ->
+ match vi.vtype.tnode with
+ | TFun (_,Some formals , _) ->
(try
let old_formals_env = getFormalsDecl oldvi in
List.iter2
@@ -2860,7 +2856,7 @@ let setupBuiltin ?(force_keep=false) name ?spec (resTyp, args_or_argtypes, isva)
in
Some funargs, List.map makeFormalsVarDecl funargs
in
- let typ = TFun(resTyp, funargs, isva, []) in
+ let typ = mk_tfun resTyp funargs isva in
let v = makeGlobalVar name typ in
ignore (alphaConvertVarAndAddToEnv true v);
(* Add it to the file as well *)
@@ -2910,14 +2906,16 @@ let vla_free_fun () =
let conditionalConversion (t2: typ) (t3: typ) : typ =
let tresult = (* ISO 6.5.15 *)
- match unrollType t2, unrollType t3 with
+ let t2' = unrollType t2 in
+ let t3' = unrollType t3 in
+ match t2'.tnode, t3'.tnode with
| (TInt _ | TEnum _ | TFloat _), (TInt _ | TEnum _ | TFloat _) ->
arithmeticConversion t2 t3
- | TComp (comp2,_), TComp (comp3,_)
+ | TComp comp2, TComp comp3
when comp2.ckey = comp3.ckey -> t2
- | TVoid _, TVoid _ -> t2
- | TPtr(_, _), TPtr(TVoid _, _) -> t2
- | TPtr(TVoid _, _), TPtr(_, _) -> t3
+ | TVoid, TVoid -> t2
+ | TPtr _, TPtr { tnode = TVoid } -> t2
+ | TPtr { tnode = TVoid }, TPtr _ -> t3
| TPtr _, TPtr _ when Cil_datatype.Typ.equal t2 t3 -> t2
| TPtr _, TInt _ -> t2 (* most likely comparison with 0 *)
| TInt _, TPtr _ -> t3 (* most likely comparison with 0 *)
@@ -2925,7 +2923,7 @@ let conditionalConversion (t2: typ) (t3: typ) : typ =
(* When we compare two pointers of different types, we combine them
* using the same algorithm when combining multiple declarations of
* a global *)
- | (TPtr _) as t2', (TPtr _ as t3') -> begin
+ | TPtr _, TPtr _ -> begin
try combineTypes CombineOther t2' t3'
with Cannot_combine msg -> begin
Kernel.warning ~current:true "A.QUESTION: %a does not match %a (%s)"
@@ -2940,7 +2938,7 @@ let conditionalConversion (t2: typ) (t3: typ) : typ =
tresult
let logicConditionalConversion t1 t2 =
- match unrollType t1, unrollType t2 with
+ match unrollTypeNode t1, unrollTypeNode t2 with
| TPtr _ , TInt _ | TInt _, TPtr _ ->
abort_context "invalid implicit conversion from %a to %a"
Cil_datatype.Typ.pretty t2 Cil_datatype.Typ.pretty t1
@@ -3068,7 +3066,7 @@ let rec collectInitializer
Kernel.debug ~dkey "Initializing object of type %a to %a"
Cil_datatype.Typ.pretty thistype Cil_printer.pp_exp e;
SingleInit e, thistype, Cil_datatype.Lval.Set.union r reads
- | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) ->
+ | { tnode = TArray (bt, leno); tattr }, CompoundPre (pMaxIdx, pArray) ->
Kernel.debug ~dkey
"Initialization of an array object of type %a with index max %d"
Cil_datatype.Typ.pretty thistype !pMaxIdx;
@@ -3148,7 +3146,7 @@ let rec collectInitializer
Kernel.error ~once:true ~current:true
"static initialization of flexible array members is an \
unsupported GNU extension";
- TArray (typ, None, at)
+ mk_tarray ~tattr typ None
end
else
begin
@@ -3157,7 +3155,7 @@ let rec collectInitializer
Kernel.error ~once:true ~current:true
"arrays of size zero not supported in C99@ \
(only allowed as compiler extensions)";
- TArray (typ, Some (integer ~loc len), at)
+ mk_tarray ~tattr typ (Some (integer ~loc len))
end
in
CompoundInit (newtype, (* collect [] endAt*)init),
@@ -3167,7 +3165,7 @@ let rec collectInitializer
(if len_used then newtype else thistype),
reads
- | TComp (comp, _) as t,
+ | { tnode = TComp comp } as t,
CompoundPre (pMaxIdx, pArray) when comp.cstruct ->
Kernel.debug ~dkey
"Initialization of an object of type %a with at least %d components"
@@ -3196,7 +3194,7 @@ let rec collectInitializer
collect 0 reads (Option.value ~default:[] comp.cfields) in
CompoundInit (thistype, init), thistype, reads
- | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct ->
+ | { tnode = TComp comp }, CompoundPre (pMaxIdx, pArray) when not comp.cstruct ->
Kernel.debug ~dkey
"Initialization of an object of type %a with at least %d components"
Cil_datatype.Typ.pretty thistype !pMaxIdx;
@@ -3323,7 +3321,7 @@ and normalSubobj (so: subobj) : unit =
advanceSubobj so
end else begin
let fst = List.hd nextflds
- and baseTyp = TComp (compinfo, []) in
+ and baseTyp = mk_tcomp compinfo in
so.soTyp <- Cil.typeOffset baseTyp fst;
so.soOff <- addOffset fst parOff
end
@@ -3387,8 +3385,8 @@ let fieldsToInit
(* if this field is an anonymous comp, search for the designator inside *)
else if prefix anonCompFieldName f.fname && not found
&& f.forig_name <> f.fname then
- match unrollType f.ftype with
- | TComp (comp, _) ->
+ match unrollTypeNode f.ftype with
+ | TComp comp ->
add_comp offset comp acc (* go deeper inside *)
| _ ->
abort_context "unnamed field type is not a struct/union"
@@ -3424,8 +3422,8 @@ let find_field_offset cond (fidlist: fieldinfo list) : offset =
| fid :: _ when cond fid ->
Field(fid, NoOffset)
| fid :: rest when prefix anonCompFieldName fid.fname -> begin
- match unrollType fid.ftype with
- | TComp (ci, _) ->
+ match unrollTypeNode fid.ftype with
+ | TComp ci ->
(try
let off = search (Option.value ~default:[] ci.cfields) in
Field(fid,off)
@@ -3479,20 +3477,20 @@ let convBinOp (bop: Cabs.binary_operator) : binop =
let allow_return_collapse ~tlv ~tf =
Cil_datatype.Typ.equal tlv tf ||
Kernel.DoCollapseCallCast.get () &&
- (match Cil.unrollType tlv, Cil.unrollType tf with
+ (match unrollTypeNode tlv, unrollTypeNode tf with
| TPtr _, TPtr _ -> true (* useful for malloc and others. Could be
restricted to void* -> any if needed *)
- | TInt (iklv, _), TInt (ikf, _) ->
+ | TInt iklv, TInt ikf ->
Cil.isSigned iklv = Cil.isSigned ikf &&
Cil.bitsSizeOfBitfield tlv = Cil.bitsSizeOf tf (* && *)
(* not (Cil.typeHasQualifier "volatile" tlv) *)
- | TFloat (fklv, _), TFloat (fkf, _) -> fklv = fkf
+ | TFloat fklv, TFloat fkf -> fklv = fkf
| _, _ -> false
)
let tcallres f =
- match unrollType (typeOf f) with
- | TFun (rt, _, _, _) -> rt
+ match unrollTypeNode (typeOf f) with
+ | TFun (rt, _, _) -> rt
| _ -> abort_context "Function call to a non-function"
let can_collapse vi vi' destlv cast f =
@@ -3930,22 +3928,23 @@ let append_chunk_to_annot ~ghost annot_chunk current_chunk =
let default_argument_promotion idx exp =
let name = "x_" ^ string_of_int idx in
- let arg_type = Cil.typeOf exp in
+ let arg_type = typeOf exp in
let typ =
- match Cil.unrollType arg_type with
- | TVoid _ -> voidType
- | TInt(k,_) when Cil.rank k < Cil.rank IInt ->
+ let t = unrollType arg_type in
+ match t.tnode with
+ | TVoid -> voidType
+ | TInt k when Cil.rank k < Cil.rank IInt ->
if intTypeIncluded k IInt then intType
else (* This may happen when char or short have the same size as int *)
uintType
- | TInt(k,_) -> TInt(k,[])
- | TFloat(FFloat,_) -> doubleType
- | TFloat(k,_) -> TFloat(k,[])
- | TPtr(t,_) | TArray(t,_,_) -> TPtr(t,[])
- | (TFun _) as t -> TPtr(t,[])
- | TComp(ci,_) -> TComp(ci,[])
- | TEnum(ei,_) -> TEnum(ei,[])
- | TBuiltin_va_list _ ->
+ | TInt ik -> mk_tint ik
+ | TFloat FFloat -> doubleType
+ | TFloat fk -> mk_tfloat fk
+ | TPtr t | TArray (t, _) -> mk_tptr t
+ | TFun _ -> mk_tptr t
+ | TComp ci -> mk_tcomp ci
+ | TEnum ei -> mk_tenum ei
+ | TBuiltin_va_list ->
abort_context "implicit prototype cannot have variadic arguments"
| TNamed _ -> assert false (* unrollType *)
in
@@ -4081,8 +4080,8 @@ let checkTypedefSize name typ =
and reports [Kernel.error] if they are found. *)
let rec checkRestrictQualifierDeep t =
if typeHasQualifier "restrict" t then
- match unrollType t with
- | TArray (bt, _, _) | TPtr (bt, _) ->
+ match unrollTypeNode t with
+ | TArray (bt, _) | TPtr bt ->
if isFunctionType bt then
Kernel.error ~once:true ~current:true
"function pointer type does not allow 'restrict' qualifier"
@@ -4091,10 +4090,10 @@ let rec checkRestrictQualifierDeep t =
| _ -> Kernel.error ~once:true ~current:true
"invalid usage of 'restrict' qualifier"
else
- match unrollType t with
- | TArray (bt, _, _) | TPtr (bt, _) ->
+ match unrollTypeNode t with
+ | TArray (bt, _) | TPtr bt ->
checkRestrictQualifierDeep bt
- | TFun (rt, args, _, _) ->
+ | TFun (rt, args, _) ->
checkRestrictQualifierDeep rt;
begin
match args with
@@ -4226,67 +4225,66 @@ let rec doSpecList loc ghost (suggestedAnonName: string)
(* And now try to make sense of it. See ISO 6.7.2 *)
let bt =
match sortedspecs with
- | [Cabs.Tvoid] -> TVoid []
- | [Cabs.Tchar] -> TInt(IChar, [])
- | [Cabs.Tbool] -> TInt(IBool, [])
- | [Cabs.Tsigned; Cabs.Tchar] -> TInt(ISChar, [])
- | [Cabs.Tunsigned; Cabs.Tchar] -> TInt(IUChar, [])
+ | [Cabs.Tvoid] -> voidType
+ | [Cabs.Tchar] -> charType
+ | [Cabs.Tbool] -> boolType
+ | [Cabs.Tsigned; Cabs.Tchar] -> scharType
+ | [Cabs.Tunsigned; Cabs.Tchar] -> ucharType
- | [Cabs.Tshort] -> TInt(IShort, [])
- | [Cabs.Tsigned; Cabs.Tshort] -> TInt(IShort, [])
- | [Cabs.Tshort; Cabs.Tint] -> TInt(IShort, [])
- | [Cabs.Tsigned; Cabs.Tshort; Cabs.Tint] -> TInt(IShort, [])
+ | [Cabs.Tshort]
+ | [Cabs.Tsigned; Cabs.Tshort]
+ | [Cabs.Tshort; Cabs.Tint]
+ | [Cabs.Tsigned; Cabs.Tshort; Cabs.Tint] -> shortType
- | [Cabs.Tunsigned; Cabs.Tshort] -> TInt(IUShort, [])
- | [Cabs.Tunsigned; Cabs.Tshort; Cabs.Tint] -> TInt(IUShort, [])
+ | [Cabs.Tunsigned; Cabs.Tshort]
+ | [Cabs.Tunsigned; Cabs.Tshort; Cabs.Tint] -> ushortType
| [] ->
Kernel.warning ~current:true ~wkey:Kernel.wkey_implicit_int
"type specifier missing, defaults to 'int'; ISO C99 and later do not \
support implicit int";
- TInt(IInt, [])
- | [Cabs.Tint] -> TInt(IInt, [])
- | [Cabs.Tsigned] -> TInt(IInt, [])
- | [Cabs.Tsigned; Cabs.Tint] -> TInt(IInt, [])
+ intType
+ | [Cabs.Tint]
+ | [Cabs.Tsigned]
+ | [Cabs.Tsigned; Cabs.Tint] -> intType
- | [Cabs.Tunsigned] -> TInt(IUInt, [])
- | [Cabs.Tunsigned; Cabs.Tint] -> TInt(IUInt, [])
+ | [Cabs.Tunsigned]
+ | [Cabs.Tunsigned; Cabs.Tint] -> uintType
- | [Cabs.Tlong] -> TInt(ILong, [])
- | [Cabs.Tsigned; Cabs.Tlong] -> TInt(ILong, [])
- | [Cabs.Tlong; Cabs.Tint] -> TInt(ILong, [])
- | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tint] -> TInt(ILong, [])
+ | [Cabs.Tlong]
+ | [Cabs.Tsigned; Cabs.Tlong]
+ | [Cabs.Tlong; Cabs.Tint]
+ | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tint] -> longType
- | [Cabs.Tunsigned; Cabs.Tlong] -> TInt(IULong, [])
- | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tint] -> TInt(IULong, [])
+ | [Cabs.Tunsigned; Cabs.Tlong]
+ | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tint] -> ulongType
- | [Cabs.Tlong; Cabs.Tlong] -> TInt(ILongLong, [])
- | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tlong] -> TInt(ILongLong, [])
- | [Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> TInt(ILongLong, [])
- | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> TInt(ILongLong, [])
+ | [Cabs.Tlong; Cabs.Tlong]
+ | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tlong]
+ | [Cabs.Tlong; Cabs.Tlong; Cabs.Tint]
+ | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> longLongType
- | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tlong] -> TInt(IULongLong, [])
- | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> TInt(IULongLong, [])
+ | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tlong]
+ | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> ulongLongType
(* int64 is to support MSVC *)
- | [Cabs.Tint64] -> TInt(ILongLong, [])
- | [Cabs.Tsigned; Cabs.Tint64] -> TInt(ILongLong, [])
+ | [Cabs.Tint64]
+ | [Cabs.Tsigned; Cabs.Tint64] -> longLongType
- | [Cabs.Tunsigned; Cabs.Tint64] -> TInt(IULongLong, [])
+ | [Cabs.Tunsigned; Cabs.Tint64] -> ulongLongType
- | [Cabs.Tfloat] -> TFloat(FFloat, [])
- | [Cabs.Tdouble] -> TFloat(FDouble, [])
+ | [Cabs.Tfloat] -> floatType
+ | [Cabs.Tdouble] -> doubleType
- | [Cabs.Tlong; Cabs.Tdouble] -> TFloat(FLongDouble, [])
+ | [Cabs.Tlong; Cabs.Tdouble] -> longDoubleType
(* Now the other type specifiers *)
| [Cabs.Tnamed "__builtin_va_list"]
- when Machine.has_builtin_va_list () ->
- TBuiltin_va_list []
+ when Machine.has_builtin_va_list () -> mk_tbuiltin ()
| [Cabs.Tnamed "__fc_builtin_size_t"] -> Machine.sizeof_type ()
| [Cabs.Tnamed n] ->
(match lookupType ghost "type" n with
- | (TNamed _) as x, _ -> x
+ | { tnode = TNamed _ } as t, _ -> t
| _ ->
Kernel.fatal ~current:true "Named type %s is not mapped correctly" n)
@@ -4331,7 +4329,7 @@ let rec doSpecList loc ghost (suggestedAnonName: string)
let enum, _ = createEnumInfo n'' ~norig:n in
let a = extraAttrs @ (getTypeAttrs ()) in
enum.eattr <- enum.eattr @ (doAttributes ghost a);
- let res = TEnum (enum, []) in
+ let res = mk_tenum enum in
let smallest = ref Integer.zero in
let largest = ref Integer.zero in
(* Life is fun here. ANSI says: enum constants are ints,
@@ -4456,11 +4454,9 @@ let rec doSpecList loc ghost (suggestedAnonName: string)
match e'.enode with
(* If this is a string literal, then we treat it as in sizeof*)
| Const (CStr s) -> begin
- match typeOf e' with
- | TPtr(bt, _) -> (* This is the type of array elements *)
- TArray(bt,
- Some (new_exp ~loc:e'.eloc (SizeOfStr s)),
- [])
+ match (typeOf e').tnode with
+ | TPtr bt-> (* This is the type of array elements *)
+ mk_tarray bt (Some (new_exp ~loc:e'.eloc (SizeOfStr s)))
| _ -> abort_context "The typeOf a string is not a pointer type"
end
| _ -> t
@@ -4721,7 +4717,7 @@ and doType (ghost:bool) (context: type_context)
let a2n, a2f, a2t = partitionAttributes ~default:nameortype a2' in
let bt' = cabsTypeAddAttributes a1t bt in
let bt'', a1fadded =
- match unrollType bt with
+ match unrollTypeNode bt with
| TFun _ -> cabsTypeAddAttributes a1f bt', true
| _ -> bt', false
in
@@ -4731,19 +4727,21 @@ and doType (ghost:bool) (context: type_context)
let restyp = cabsTypeAddAttributes a2t restyp in
(* See if we can add some more type attributes *)
let restyp' =
- match unrollType restyp with
+ let t = unrollType restyp in
+ match t.tnode with
| TFun _ ->
if a1fadded then
cabsTypeAddAttributes a2f restyp
else
cabsTypeAddAttributes a2f
(cabsTypeAddAttributes a1f restyp)
- | TPtr ((TFun _ as tf), ap) when not (Machine.msvcMode ()) ->
+ | TPtr ({ tnode = TFun _ } as tf)
+ when not (Machine.msvcMode ()) ->
if a1fadded then
- TPtr(cabsTypeAddAttributes a2f tf, ap)
+ mk_tptr ~tattr:t.tattr (cabsTypeAddAttributes a2f tf)
else
- TPtr(cabsTypeAddAttributes a2f
- (cabsTypeAddAttributes a1f tf), ap)
+ let t' = cabsTypeAddAttributes a2f (cabsTypeAddAttributes a1f tf) in
+ mk_tptr ~tattr:t.tattr t'
| _ ->
if a1f <> [] && not a1fadded then
Kernel.error ~once:true ~current:true
@@ -4763,13 +4761,15 @@ and doType (ghost:bool) (context: type_context)
let al' = doAttributes ghost al in
let an, af, at = partitionAttributes ~default:AttrType al' in
(* Now recurse *)
- let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in
+ let t = mk_tptr ~tattr:at bt in
+ let restyp, nattr = doDeclType t acc d in
(* See if we can do anything with function type attributes *)
let restyp' =
- match unrollType restyp with
+ let t = unrollType restyp in
+ match t.tnode with
| TFun _ -> cabsTypeAddAttributes af restyp
- | TPtr((TFun _ as tf), ap) ->
- TPtr(cabsTypeAddAttributes af tf, ap)
+ | TPtr ({ tnode = TFun _ } as tf) ->
+ mk_tptr ~tattr:t.tattr (cabsTypeAddAttributes af tf)
| _ ->
if af <> [] then
Kernel.error ~once:true ~current:true
@@ -4900,7 +4900,8 @@ and doType (ghost:bool) (context: type_context)
Kernel.error ~once:true ~current:true
"static specifier inside array argument is allowed only in \
function argument";
- doDeclType (TArray(bt, lo, al')) acc d
+ let t = mk_tarray ~tattr:al' bt lo in
+ doDeclType t acc d
| Cabs.PROTO (d, args, ghost_args, isva) ->
(* Start a scope for the parameter names *)
@@ -5004,21 +5005,22 @@ and doType (ghost:bool) (context: type_context)
end
end
in
- let attrs = Cil.addAttributes a' main_attrs in
- TPtr(bt, attrs)
+ let tattr = Cil.addAttributes a' main_attrs in
+ mk_tptr ~tattr bt
in
let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit =
match args with
| [] -> ()
| a :: args' ->
- (match unrollType a.vtype with
- | TArray(bt,lo,attr) ->
+ let t = unrollType a.vtype in
+ (match t.tnode with
+ | TArray (bt, lo) ->
(* Note that for multi-dimensional arrays we strip off only
the first TArray and leave bt alone. *)
- let real_type = turnArrayIntoPointer bt lo attr in
+ let real_type = turnArrayIntoPointer bt lo t.tattr in
Cil.update_var_type a real_type
- | TFun _ -> Cil.update_var_type a (TPtr(a.vtype, []))
- | TComp (_,_) -> begin
+ | TFun _ -> Cil.update_var_type a (mk_tptr a.vtype)
+ | TComp _ -> begin
match isTransparentUnion a.vtype with
| None -> ()
| Some fstfield ->
@@ -5046,7 +5048,7 @@ and doType (ghost:bool) (context: type_context)
in
let tres =
match unrollType bt with
- | TArray(t,lo,attr) -> turnArrayIntoPointer t lo attr
+ | { tnode = TArray(t,lo); tattr } -> turnArrayIntoPointer t lo tattr
| _ -> bt
in
(* Drop qualifiers on the return type. They are meaningless (qualifiers
@@ -5054,7 +5056,8 @@ and doType (ghost:bool) (context: type_context)
the return type of the function is used e.g. for the type of retres,
and probably in many other places. *)
let tres = Cil.type_remove_qualifier_attributes tres in
- doDeclType (TFun (tres, args, isva', [])) acc d
+ let t = mk_tfun tres args isva' in
+ doDeclType t acc d
in
doDeclType bt [] dt
@@ -5187,8 +5190,8 @@ and makeCompType loc ghost (isstruct: bool)
| None -> None, ftype
| Some w -> begin
let source = fst w.expr_loc in
- (match unrollType ftype with
- | TInt (_, _) -> ()
+ (match unrollTypeNode ftype with
+ | TInt _ -> ()
| TEnum _ -> ()
| _ ->
Kernel.abort ~once:true ~source
@@ -5246,9 +5249,9 @@ and makeCompType loc ghost (isstruct: bool)
end
in
let rec is_circular t =
- match Cil.unrollType t with
- | TArray(bt,_,_) -> is_circular bt
- | TComp (comp',_) ->
+ match unrollTypeNode t with
+ | TArray (bt, _) -> is_circular bt
+ | TComp comp' ->
if Cil_datatype.Compinfo.equal comp comp' then begin
(* abort and not error, as this circularity could lead
to infinite recursion... *)
@@ -5310,7 +5313,7 @@ and makeCompType loc ghost (isstruct: bool)
Kernel.error ~source
"field %s occurs multiple times in aggregate %a. \
Previous occurrence is at line %d."
- f.fname Cil_datatype.Typ.pretty (TComp(comp,[]))
+ f.fname Cil_datatype.Typ.pretty (mk_tcomp comp)
(fst oldf.floc).Filepath.pos_lnum
with Not_found ->
(* Do not add unnamed bitfields: they can share the empty name. *)
@@ -5352,7 +5355,7 @@ and makeCompType loc ghost (isstruct: bool)
(* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *)
let a = Cil.addAttributes comp.cattr a in
comp.cattr <- process_pragmas_pack_align_comp_attributes loc comp a;
- let res = TComp (comp, []) in
+ let res = mk_tcomp comp in
(* Create a typedef for this one *)
cabsPushGlobal (GCompTag (comp, Current_loc.get ()));
@@ -5372,8 +5375,8 @@ and preprocessCast loc ghost (specs: Cabs.specifier)
(* However, it may just be casting of a whole union to its own type. We
* will resolve this later, when we'll convert casts to unions. *)
let ie' =
- match unrollType typ, ie with
- | TComp (c, _), Cabs.SINGLE_INIT _ when not c.cstruct ->
+ match unrollTypeNode typ, ie with
+ | TComp c, Cabs.SINGLE_INIT _ when not c.cstruct ->
Cabs.COMPOUND_INIT [(Cabs.INFIELD_INIT ("___matching_field",
Cabs.NEXT_INIT),
ie)]
@@ -5382,8 +5385,8 @@ and preprocessCast loc ghost (specs: Cabs.specifier)
(* Maybe specs contains an unnamed composite. Replace with the name so that
* when we do again the specs we get the right name *)
let specs1 =
- match typ with
- | TComp (ci, _) ->
+ match typ.tnode with
+ | TComp ci ->
List.map
(function
Cabs.SpecType (Cabs.Tstruct ("", _, [])) ->
@@ -5449,11 +5452,12 @@ and doExp local_env
* essentially doExp should never return things of type TFun or TArray *)
let processArrayFun e t =
let loc = e.eloc in
- match e.enode, unrollType t with
- | (Lval(lv) | CastE(_, {enode = Lval lv})), TArray(tbase, _, a) ->
- mkStartOfAndMark loc lv, TPtr(tbase, a)
+ let t' = unrollType t in
+ match e.enode, t'.tnode with
+ | (Lval(lv) | CastE(_, {enode = Lval lv})), TArray(tbase, _) ->
+ mkStartOfAndMark loc lv, mk_tptr ~tattr:t'.tattr tbase
| (Lval(lv) | CastE(_, {enode = Lval lv})), TFun _ ->
- mkAddrOfAndMark loc lv, TPtr(t, [])
+ mkAddrOfAndMark loc lv, mk_tptr t
| _, (TArray _ | TFun _) ->
abort_context
"Array or function expression is not lval: %a@\n"
@@ -5584,9 +5588,9 @@ and doExp local_env
let se = se1 @@@ (se2, ghost) in
let (e1'', t1, e2'', tresult) =
(* Either e1 or e2 can be the pointer *)
- match unrollType t1, unrollType t2 with
- | TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e
- | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e
+ match unrollTypeNode t1, unrollTypeNode t2 with
+ | TPtr t1e, (TInt _|TEnum _) -> e1', t1, e2', t1e
+ | (TInt _|TEnum _), TPtr t2e -> e2', t2, e1', t2e
| _ ->
abort_context
"Expecting exactly one pointer type in array access %a[%a] (%a \
@@ -5620,8 +5624,8 @@ and doExp local_env
doExp (no_paren_local_env local_env) CNoConst e (AExp None)
in
let tresult =
- match unrollType t with
- | TPtr(te, _) -> te
+ match unrollTypeNode t with
+ | TPtr te -> te
| _ ->
abort_context
"attempted to dereference an expression of non-pointer type %a"
@@ -5656,8 +5660,8 @@ and doExp local_env
List.filter (fun x -> not (Lval.equal x lv)) r
in
let field_offset =
- match unrollType t' with
- | TComp (comp, _) -> findField str comp
+ match unrollTypeNode t' with
+ | TComp comp -> findField str comp
| _ ->
abort_context "expecting a struct with field %s" str
in
@@ -5678,17 +5682,17 @@ and doExp local_env
let (r,se, e', t') =
doExp (no_paren_local_env local_env) CNoConst e (AExp None)
in
- let pointedt = match unrollType t' with
- | TPtr(t1, _) -> t1
- | TArray(t1,_,_) -> t1
+ let pointedt = match unrollTypeNode t' with
+ | TPtr t1 -> t1
+ | TArray (t1,_) -> t1
| _ -> abort_context "expecting a pointer to a struct"
in
let field_offset = match unrollType pointedt with
- | TComp (comp, _) -> findField str comp
- | x ->
+ | { tnode = TComp comp } -> findField str comp
+ | t ->
abort_context
"expecting a struct with field %s. Found %a. t1 is %a"
- str Cil_datatype.Typ.pretty x Cil_datatype.Typ.pretty t'
+ str Cil_datatype.Typ.pretty t Cil_datatype.Typ.pretty t'
in
let lv' = mkMem ~addr:e' ~off:field_offset in
let field_type = typeOfLval lv' in
@@ -5770,7 +5774,7 @@ and doExp local_env
Will use %a."
str (Floating_point.pretty_normal ~use_hex:true) nearest_float;
let node = Const (CReal (nearest_float, kind, Some str)) in
- let typ = TFloat (kind, []) in
+ let typ = mk_tfloat kind in
finishExp [] (unspecified_chunk empty) (new_exp ~loc node) typ
end
end
@@ -5899,7 +5903,7 @@ and doExp local_env
* StartOf. We must undo that now so that it is done once by
* the finishExp at the end of this case *)
let e2, t2 =
- match unrollType typ, e'.enode with
+ match unrollTypeNode typ, e'.enode with
| TArray _, StartOf lv -> new_exp ~loc (Lval lv), typ
| _, _ -> e', t'
in
@@ -5911,8 +5915,8 @@ and doExp local_env
end
in
let (t'', e'') =
- match typ with
- | TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *)
+ match typ.tnode with
+ | TVoid when what' = ADrop -> (t', e') (* strange GNU thing *)
| _ ->
(* Do this to check the cast, unless we are sure that we do not
* need the check. *)
@@ -5977,8 +5981,8 @@ and doExp local_env
Kernel.fatal ~current:true "normalization of unop failed"
| Cabs.VARIABLE s when
isOldStyleVarArgName s
- && (match !currentFunctionFDEC.svar.vtype with
- TFun(_, _, true, _) -> true | _ -> false) ->
+ && (match !currentFunctionFDEC.svar.vtype.tnode with
+ TFun (_, _, true) -> true | _ -> false) ->
(* We are in an old-style variable argument function and we are
* taking the address of the argument that was removed while
* processing the function type. We compute the address based on
@@ -5995,7 +5999,7 @@ and doExp local_env
let last = getLast !currentFunctionFDEC.sformals in
let res = mkAddrOfAndMark e.expr_loc (var last) in
let tres = typeOf res in
- let tres', res' = castTo tres (TInt(IULong, [])) res in
+ let tres', res' = castTo tres longType res in
(* Now we must add to this address to point to the next
* argument. Round up to a multiple of 4 *)
let sizeOfLast =
@@ -6041,11 +6045,11 @@ and doExp local_env
| x' :: r when LvalStructEq.equal x x' -> r
| _ -> r
in
- finishExp reads se (mkAddrOfAndMark loc x) (TPtr(tres, []))
+ finishExp reads se (mkAddrOfAndMark loc x) (mk_tptr tres)
| Const (CStr _ | CWStr _) ->
(* string to array *)
- finishExp r se e' (TPtr(t, []))
+ finishExp r se e' (mk_tptr t)
(* Function names are converted into pointers to the function.
* Taking the address-of again does not change things *)
@@ -6480,8 +6484,9 @@ and doExp local_env
Did you forget a /*@@ ghost ... /?" n ;
Kernel.debug ~dkey:Kernel.dkey_typing_global
"Calling function %s without prototype." n ;
- let ftype = TFun(intType, None, false,
- [Attr("missingproto",[])]) in
+ let ftype =
+ mk_tfun ~tattr:[Attr("missingproto",[])] intType None false
+ in
(* Add a prototype to the environment *)
let proto, _ =
makeGlobalVarinfo false
@@ -6500,13 +6505,13 @@ and doExp local_env
| _ -> doExp (no_paren_local_env local_env) CNoConst f (AExp None)
in
(* Get the result type and the argument types *)
- let (resType, argTypes, isvar, f'',attrs) =
+ let (resType, argTypes, isvar, f'', tattr) =
match unrollType ft' with
- | TFun(rt,at,isvar,attrs) -> (rt,at,isvar,f',attrs)
- | TPtr (t, _) -> begin
+ | { tnode = TFun(rt,at,isvar); tattr } -> (rt,at,isvar,f',tattr)
+ | { tnode = TPtr t } -> begin
match unrollType t with
- | TFun(rt,at,isvar,_) -> (* Make the function pointer
- * explicit *)
+ | { tnode = TFun (rt, at, isvar) } -> (* Make the function pointer
+ * explicit *)
let f'' =
match f'.enode with
| AddrOf lv -> new_exp ~loc:f'.eloc (Lval(lv))
@@ -6556,7 +6561,7 @@ and doExp local_env
*)
if not isSpecialBuiltin && not are_ghost then begin
warn_no_proto f;
- let typ = TFun (resType, Some [], false,attrs) in
+ let typ = mk_tfun ~tattr resType (Some []) false in
Cil.update_var_type f typ;
end
| None, _ (* TODO: treat function pointers. *)
@@ -6691,7 +6696,7 @@ and doExp local_env
List.split
(List.mapi default_argument_promotion args)
in
- let typ = TFun (resType, Some prm_types, false,attrs) in
+ let typ = mk_tfun ~tattr resType (Some prm_types) false in
begin
try
(* Nested calls of a function without a prototype : inner
@@ -6777,8 +6782,8 @@ and doExp local_env
in
(* Get the name of the last formal *)
let getNameLastNonGhostFormal () : string =
- match !currentFunctionFDEC.svar.vtype with
- | TFun(_, Some args, true, _) -> begin
+ match !currentFunctionFDEC.svar.vtype.tnode with
+ | TFun(_, Some args, true) -> begin
let args, _ = Cil.argsToPairOfLists (Some args) in
match List.rev args with
| (last_par_name, _, _) :: _ -> last_par_name
@@ -6815,8 +6820,8 @@ and doExp local_env
end
| "__builtin_va_start" ->
- let variad = match (!currentFunctionFDEC).svar.vtype with
- | TFun(_,_,t,_) -> t
+ let variad = match (!currentFunctionFDEC).svar.vtype.tnode with
+ | TFun (_, _, t) -> t
| _ -> assert false
in
let name =
@@ -7659,7 +7664,7 @@ and doBinOp loc (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) =
let doIntegralArithmetic () =
if isIntegralType t1 && isIntegralType t2 then begin
let tres = unrollType (arithmeticConversion t1 t2) in
- match tres with
+ match tres.tnode with
| TInt _ ->
tres,
optConstFoldBinOp loc false bop
@@ -8144,7 +8149,8 @@ and doInit local_env asconst preinit so acc initl =
| (what, ie) :: _ ->
Cprint.print_init_expression fmt (Cabs.COMPOUND_INIT [(what, ie)])
);
- match unrollType so.soTyp, allinitl with
+ let soTyp' = unrollType so.soTyp in
+ match soTyp'.tnode, allinitl with
(* No more initializers return *)
| _, [] -> acc, preinit, []
(* No more subobjects to initialize *)
@@ -8152,7 +8158,7 @@ and doInit local_env asconst preinit so acc initl =
(* If we are at an array of characters and the initializer is a
* string literal (optionally enclosed in braces) then explode the
* string into characters *)
- | TArray(bt, leno, _ ),
+ | TArray (bt, leno),
(Cabs.NEXT_INIT,
(Cabs.SINGLE_INIT({ expr_node = Cabs.CONSTANT (Cabs.CONST_STRING s)} as e)|
Cabs.COMPOUND_INIT
@@ -8162,8 +8168,8 @@ and doInit local_env asconst preinit so acc initl =
Cabs.CONSTANT
(Cabs.CONST_STRING s)} as e))]))
:: restil
- when (match unrollType bt with
- | TInt((IChar|IUChar|ISChar), _) -> true
+ when (match unrollTypeNode bt with
+ | TInt (IChar|IUChar|ISChar) -> true
| TInt _ ->
(*Base type is a scalar other than char. Maybe a wchar_t?*)
abort_context
@@ -8214,7 +8220,7 @@ and doInit local_env asconst preinit so acc initl =
(* [weimer] Wed Jan 30 15:38:05 PST 2002
* Despite what the compiler says, this match case is used and it is
* important. *)
- | TArray(bt, leno, _),
+ | TArray (bt, leno),
(Cabs.NEXT_INIT,
(Cabs.SINGLE_INIT({expr_node = Cabs.CONSTANT (Cabs.CONST_WSTRING s)} as e)|
Cabs.COMPOUND_INIT
@@ -8226,7 +8232,7 @@ and doInit local_env asconst preinit so acc initl =
:: restil
when
(let bt' = unrollType bt in
- match bt' with
+ match bt'.tnode with
(* compare bt to wchar_t, ignoring signed vs. unsigned *)
| TInt _ when (bitsSizeOf bt') =
(bitsSizeOf (Machine.wchar_type ())) ->
@@ -8287,7 +8293,7 @@ and doInit local_env asconst preinit so acc initl =
doInit local_env asconst preinit' so acc' restil
(* If we are at an array and we see a single initializer then it must
* be one for the first element *)
- | TArray(bt, leno, _), (Cabs.NEXT_INIT, Cabs.SINGLE_INIT _oneinit) :: _restil ->
+ | TArray(bt, leno), (Cabs.NEXT_INIT, Cabs.SINGLE_INIT _oneinit) :: _restil ->
(* Grab the length if there is one *)
let leno = integerArrayLength leno in
so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack;
@@ -8295,20 +8301,20 @@ and doInit local_env asconst preinit so acc initl =
(* Start over with the fields *)
doInit local_env asconst preinit so acc allinitl
(* An incomplete structure with any initializer is an error. *)
- | TComp (comp, _), _ :: restil when comp.cfields = None ->
+ | TComp comp, _ :: restil when comp.cfields = None ->
Kernel.error ~current:true ~once:true
"variable `%s' has initializer but incomplete type" so.host.vname;
doInit local_env asconst preinit so acc restil
(* If we are at a composite and we see a single initializer of the same
* type as the composite then grab it all. If the type is not the same
* then we must go on and try to initialize the fields *)
- | TComp (comp, _), (Cabs.NEXT_INIT, Cabs.SINGLE_INIT oneinit) :: restil ->
+ | TComp comp, (Cabs.NEXT_INIT, Cabs.SINGLE_INIT oneinit) :: restil ->
let r,se, oneinit', t' =
doExp (no_paren_local_env local_env) asconst oneinit (AExp None)
in
let r = Cil_datatype.Lval.Set.of_list r in
- if (match unrollType t' with
- | TComp (comp', _) when comp'.ckey = comp.ckey -> true
+ if (match unrollTypeNode t' with
+ | TComp comp' when comp'.ckey = comp.ckey -> true
| _ -> false)
then begin
(* Initialize the whole struct *)
@@ -8344,7 +8350,7 @@ and doInit local_env asconst preinit so acc initl =
doInit local_env asconst preinit' so se restil
(* An array with a compound initializer. The initializer is for the
* array elements *)
- | TArray (bt, leno, _), (Cabs.NEXT_INIT, Cabs.COMPOUND_INIT initl) :: restil ->
+ | TArray (bt, leno), (Cabs.NEXT_INIT, Cabs.COMPOUND_INIT initl) :: restil ->
(* Create a separate object for the array *)
let so' = makeSubobj so.host so.soTyp so.soOff in
(* Go inside the array *)
@@ -8374,7 +8380,7 @@ and doInit local_env asconst preinit so acc initl =
doInit local_env asconst preinit' so acc' restil
(* We have a designator that tells us to select the matching union field.
* This is to support a GCC extension *)
- | TComp(ci, _) as targ,
+ | TComp ci,
[(Cabs.NEXT_INIT,
Cabs.COMPOUND_INIT
[(Cabs.INFIELD_INIT ("___matching_field", Cabs.NEXT_INIT),
@@ -8394,7 +8400,7 @@ and doInit local_env asconst preinit so acc initl =
| _ :: rest -> findField rest
in
(* If this is a cast from union X to union X *)
- if Typ.equal t'noattr (Cil.typeDeepDropAllAttributes targ) then
+ if Typ.equal t'noattr (Cil.typeDeepDropAllAttributes soTyp') then
doInit local_env asconst preinit so acc
[(Cabs.NEXT_INIT, Cabs.SINGLE_INIT oneinit)]
else
@@ -8405,7 +8411,7 @@ and doInit local_env asconst preinit so acc initl =
[Cabs.INFIELD_INIT (fi.fname, Cabs.NEXT_INIT), Cabs.SINGLE_INIT oneinit]
(* A structure with a composite initializer. We initialize the fields*)
- | TComp (comp, _), (Cabs.NEXT_INIT, Cabs.COMPOUND_INIT initl) :: restil ->
+ | TComp comp, (Cabs.NEXT_INIT, Cabs.COMPOUND_INIT initl) :: restil ->
(* Create a separate subobject iterator *)
let so' = makeSubobj so.host so.soTyp so.soOff in
(* Go inside the comp *)
@@ -8428,7 +8434,7 @@ and doInit local_env asconst preinit so acc initl =
(* Continue *)
doInit local_env asconst preinit' so acc' restil
(* A scalar with a initializer surrounded by a number of braces *)
- | t, (Cabs.NEXT_INIT, next) :: restil ->
+ | _, (Cabs.NEXT_INIT, next) :: restil ->
begin
let rec find_one_init c =
match c with
@@ -8452,7 +8458,7 @@ and doInit local_env asconst preinit so acc initl =
with Not_found ->
abort_context
"scalar value (of type %a) initialized by compound initializer"
- Cil_datatype.Typ.pretty t
+ Cil_datatype.Typ.pretty soTyp'
end
(* We have a designator *)
| _, (what, ie) :: restil when what != Cabs.NEXT_INIT ->
@@ -8468,8 +8474,8 @@ and doInit local_env asconst preinit so acc initl =
match what with
| Cabs.NEXT_INIT -> acc
| Cabs.INFIELD_INIT (fn, whatnext) -> begin
- match unrollType so.soTyp with
- | TComp (comp, _) ->
+ match unrollTypeNode so.soTyp with
+ | TComp comp ->
let toinit = fieldsToInit comp (Some fn) in
so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
normalSubobj so;
@@ -8481,8 +8487,8 @@ and doInit local_env asconst preinit so acc initl =
| Cabs.ATINDEX_INIT(idx, whatnext) -> begin
let open Current_loc.Operators in
let<> UpdatedCurrentLoc = idx.expr_loc in
- match unrollType so.soTyp with
- | TArray (bt, leno, _) ->
+ match unrollTypeNode so.soTyp with
+ | TArray (bt, leno) ->
let ilen = integerArrayLength leno in
let nextidx', doidx =
let (r,doidx, idxe', _) =
@@ -8568,8 +8574,8 @@ and doInit local_env asconst preinit so acc initl =
((Cabs.NEXT_INIT, ie) :: restil)
in
expandRange (fun x -> x) what
- | t, (_what, _ie) :: _ ->
- abort_context "doInit: cases for t=%a" Cil_datatype.Typ.pretty t
+ | _, (_what, _ie) :: _ ->
+ abort_context "doInit: cases for t=%a" Cil_datatype.Typ.pretty soTyp'
(* Create and add to the file (if not already added) a global. Return the
* varinfo *)
@@ -9081,14 +9087,15 @@ and createLocal ghost ((_, sto, _, _) as specs)
(* We have a length now *)
Cil.update_var_type vi et
else
- (match vi.vtype, ie' with
+ (match vi.vtype.tnode, ie' with
(* Initializing a local array *)
- | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, a),
+ | TArray({ tnode = TInt (IChar|IUChar|ISChar) } as bt, None),
SingleInit({enode = Const(CStr s);eloc=loc}) ->
- Cil.update_var_type vi
- (TArray(bt,
- Some (integer ~loc (String.length s + 1)),
- a))
+ let t =
+ mk_tarray ~tattr:vi.vtype.tattr bt
+ (Some (integer ~loc (String.length s + 1)))
+ in
+ Cil.update_var_type vi t
| _, _ -> ());
(* Now create assignments instead of the initialization *)
let (@@@) s1 s2 = s1 @@@ (s2, ghost) in
@@ -9414,12 +9421,10 @@ and doDecl local_env (isglobal: bool) (def: Cabs.definition) : chunk =
let () = fixFormalsType formals in
(* Recreate the type based on the formals. *)
- let ftype = TFun(returnType,
- Some (List.map (fun f ->
- (f.vname,
- f.vtype,
- f.vattr)) formals),
- isvararg, funta) in
+ let ftype =
+ let args = Some (List.map (fun f -> (f.vname, f.vtype, f.vattr)) formals) in
+ mk_tfun ~tattr:funta returnType args isvararg
+ in
(*log "Funtype of %s: %a\n" n Cil_datatype.Typ.pretty ftype;*)
@@ -9620,9 +9625,10 @@ and doDecl local_env (isglobal: bool) (def: Cabs.definition) : chunk =
in
Cil.mkStmt ~ghost ~valid_sid (Instr(Code_annot(annot,loc)))
in
- match unrollType !currentReturnType with
- | TVoid _ -> [], None
- | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt ->
+ let rt = unrollType !currentReturnType in
+ match rt.tnode with
+ | TVoid -> [], None
+ | TInt _ | TEnum _ | TFloat _ | TPtr _ ->
let res = Some (mkCastT ~oldt:intType ~newt:rt (zero ~loc)) in
if !currentFunctionFDEC.svar.vname = "main" then
[],res
@@ -9633,12 +9639,12 @@ and doDecl local_env (isglobal: bool) (def: Cabs.definition) : chunk =
!currentFunctionFDEC.svar.vname;
[assert_false ()], res
end
- | rt ->
+ | _ ->
(* 0 is not an admissible value for the return type.
On the other hand, *( T* )0 is. We're not supposed
to get there anyway. *)
let null_ptr =
- mkCastT ~oldt:intType ~newt:(TPtr(rt,[])) (zero ~loc)
+ mkCastT ~oldt:intType ~newt:(mk_tptr rt) (zero ~loc)
in
let res =
Some (new_exp ~loc (Lval (mkMem ~addr:null_ptr ~off:NoOffset)))
@@ -9764,15 +9770,15 @@ and doTypedef ghost ((specs, nl): Cabs.name_group) =
- other types are allowed. *)
if declared_in_current_scope ~ghost n then
begin
- match newTyp' with (* do NOT unroll type here,
- redefinitions of typedefs are ok *)
- | TComp (newci, _) ->
+ match newTyp'.tnode with (* do NOT unroll type here,
+ redefinitions of typedefs are ok *)
+ | TComp newci ->
(* Composite types with different tags may be compatible, but here
we use the tags to try and detect if the type is being redefined,
which is NOT allowed. *)
begin
- match unrollType typeinfo.ttype with
- | TComp (ci, _) ->
+ match unrollTypeNode typeinfo.ttype with
+ | TComp ci ->
if ci.cname <> newci.cname then
(* different tags => we consider that the type is being redefined *)
error_conflicting_types ()
@@ -9805,7 +9811,7 @@ and doTypedef ghost ((specs, nl): Cabs.name_group) =
* It is better to change the name of the type instead. So, remember
* all types whose names have changed *)
H.add typedefs n' ti;
- let namedTyp = TNamed(ti, []) in
+ let namedTyp = mk_tnamed ti in
(* Register the type. register it as local because we might be in a
* local context *)
addLocalToEnv ghost (kindPlusName "type" n) (EnvTyp namedTyp);
@@ -9838,16 +9844,16 @@ and doOnlyTypedef ghost (specs: Cabs.spec_elem list) : unit =
| Cabs.SpecType(Cabs.Tenum(_, Some _, _)) -> true
| _ -> false) specs
in
- match restyp with
- | TComp(ci, al) ->
+ match restyp.tnode with
+ | TComp ci ->
if isadef then begin
- ci.cattr <- cabsAddAttributes ci.cattr al;
+ ci.cattr <- cabsAddAttributes ci.cattr restyp.tattr;
(* The GCompTag was already added *)
end else (* Add a GCompTagDecl *)
cabsPushGlobal (GCompTagDecl(ci, Current_loc.get ()))
- | TEnum(ei, al) ->
+ | TEnum ei ->
if isadef then begin
- ei.eattr <- cabsAddAttributes ei.eattr al;
+ ei.eattr <- cabsAddAttributes ei.eattr restyp.tattr;
end else
cabsPushGlobal (GEnumTagDecl(ei, Current_loc.get ()))
| _ ->
@@ -10409,11 +10415,11 @@ let split_extern_inline_def acc g =
the link phase. If a spec exists, the external declaration will inherit
it.
*)
- let new_v = Cil_const.copy_with_new_vid svar in
+ let new_v = copy_with_new_vid svar in
svar.vname <- svar.vname ^ "__fc_inline";
(* inline definition is restricted to this translation unit. *)
svar.vstorage <- Static;
- let new_formals = List.map Cil_const.copy_with_new_vid sformals in
+ let new_formals = List.map copy_with_new_vid sformals in
Cil.unsafeSetFormalsDecl new_v new_formals;
let formals_map = List.combine sformals new_formals in
let new_spec = copy_spec (svar, new_v) formals_map sspec in
diff --git a/src/kernel_internals/typing/ghost_accesses.ml b/src/kernel_internals/typing/ghost_accesses.ml
index dd3a5352291..bcb3608ec95 100644
--- a/src/kernel_internals/typing/ghost_accesses.ml
+++ b/src/kernel_internals/typing/ghost_accesses.ml
@@ -92,9 +92,9 @@ class visitor = object(self)
inherit Visitor.frama_c_inplace
method private ghost_incompatible nt ot =
- match (unrollType nt), (unrollType ot) with
- | TPtr (nt', _), TPtr(ot', _)
- | TPtr (nt', _), TArray(ot', _, _) ->
+ match unrollTypeNode nt, unrollTypeNode ot with
+ | TPtr nt', TPtr ot'
+ | TPtr nt', TArray (ot', _) ->
Cil.isGhostType nt' <> Cil.isGhostType ot' ||
self#ghost_incompatible nt' ot'
| _ ->
@@ -152,8 +152,8 @@ class visitor = object(self)
Error.invalid_ghost_type_for_varinfo ~once:true ~current ~source v ;
if isFunctionType (unrollType v.vtype) then begin
let ftype = getReturnType (unrollType v.vtype) in
- match ftype with
- | TPtr (t, _) when not (isWFGhostType t) ->
+ match ftype.tnode with
+ | TPtr t when not (isWFGhostType t) ->
Error.invalid_ghost_type_for_return ~once:true ~current ~source ()
| _ -> ()
end ;
diff --git a/src/kernel_internals/typing/infer_assigns.ml b/src/kernel_internals/typing/infer_assigns.ml
index ff70d3ae21c..8ef7322e05a 100644
--- a/src/kernel_internals/typing/infer_assigns.ml
+++ b/src/kernel_internals/typing/infer_assigns.ml
@@ -49,7 +49,7 @@ let from_prototype kf =
let loc = vi.vdecl in
let t = tvar (cvar_to_lvar vi) in
let typ = vi.vtype in
- if Cil.isVoidPtrType typ then
+ if isVoidPtrType typ then
let const = typeHasAttribute "const" (Cil.typeOf_pointed typ) in
let typ' = if const then Cil_const.charConstPtrType else Cil_const.charPtrType in
(vi.vghost, Logic_utils.mk_cast ~loc typ' t, typ')
@@ -72,12 +72,12 @@ let from_prototype kf =
(* Generate the required numbers of [[..]] until with find a non-array
type *)
let rec mk_offset set typ =
- match Cil.unrollType typ with
- | TArray (typ_elem, size, _) ->
+ match unrollTypeNode typ with
+ | TArray (typ_elem, size) ->
let range = match size with
| None -> make_range None
| Some size ->
- make_range (Cil.constFoldToInt size)
+ make_range (constFoldToInt size)
in
let offs, typ = mk_offset true typ_elem in
TIndex (range, offs), typ
@@ -87,16 +87,16 @@ let from_prototype kf =
in
(* make_set_type (Ctype typ_pointed) *)
- let typ_pointed = Cil.typeOf_pointed typ in
+ let typ_pointed = typeOf_pointed typ in
(* Generate the initial term: [*(t+(0..))] for array types or char*
pointers, *t for other pointer types. It would have been better to
recognize formals with type [typ[]] instead of [typ *], but this
information is lost during normalization *)
let t_range_node, set =
- match findAttribute "arraylen" (typeAttr typ) with
+ match findAttribute "arraylen" typ.tattr with
| [AInt length] -> TBinOp (PlusPI, t, make_range (Some length)), true
| _ ->
- if Cil.isAnyCharPtrType typ
+ if isAnyCharPtrType typ
then TBinOp (PlusPI, t, make_range None), true
else t.term_node, false
in
@@ -144,8 +144,8 @@ let from_prototype kf =
(fun (g, content) -> content, From (inputs g))
to_assign
in
- match rtyp with
- | TVoid _ ->
+ match rtyp.tnode with
+ | TVoid ->
(* assigns all pointer args from basic args and content of pointer args *)
arguments
| _ ->
diff --git a/src/kernel_internals/typing/logic_builtin.ml b/src/kernel_internals/typing/logic_builtin.ml
index b61c740185a..c2af9d8bb78 100644
--- a/src/kernel_internals/typing/logic_builtin.ml
+++ b/src/kernel_internals/typing/logic_builtin.ml
@@ -34,7 +34,8 @@ let float_type = Ctype Cil_const.floatType
let double_type = Ctype Cil_const.doubleType
let long_double_type = Ctype Cil_const.longDoubleType
let object_ptr = Ctype Cil_const.voidPtrType
-let fun_ptr = Ctype (TPtr(TFun(Cil_const.voidType,None,false,[]),[]))
+let fun_ptr =
+ Ctype Cil_const.(mk_tptr (mk_tfun voidType None false))
let polymorphic_type name = name, Lvar name
diff --git a/src/kernel_internals/typing/mergecil.ml b/src/kernel_internals/typing/mergecil.ml
index d9ef2e8af3d..81edf28f544 100644
--- a/src/kernel_internals/typing/mergecil.ml
+++ b/src/kernel_internals/typing/mergecil.ml
@@ -519,22 +519,23 @@ module VolatileMerging =
end)
let hash_type t =
- let rec aux acc depth = function
- | TVoid _ -> acc
- | TInt (ikind,_) -> 3 * acc + Hashtbl.hash ikind
- | TFloat (fkind,_) -> 5 * acc + Hashtbl.hash fkind
- | TPtr(t,_) when depth < 5 -> aux (7*acc) (depth+1) t
+ let rec aux acc depth t =
+ match t.tnode with
+ | TVoid -> acc
+ | TInt ikind -> 3 * acc + Hashtbl.hash ikind
+ | TFloat fkind -> 5 * acc + Hashtbl.hash fkind
+ | TPtr t when depth < 5 -> aux (7*acc) (depth+1) t
| TPtr _ -> 7 * acc
- | TArray (t,_,_) when depth < 5 -> aux (9*acc) (depth+1) t
+ | TArray (t, _) when depth < 5 -> aux (9*acc) (depth+1) t
| TArray _ -> 9 * acc
- | TFun (r,_,_,_) when depth < 5 -> aux (11*acc) (depth+1) r
+ | TFun (r, _, _) when depth < 5 -> aux (11*acc) (depth+1) r
| TFun _ -> 11 * acc
- | TNamed (t,_) -> 13 * acc + Hashtbl.hash t.tname
- | TComp(c,_) ->
- let mul = if c.cstruct then 17 else 19 in
- mul * acc + Hashtbl.hash c.cname
- | TEnum (e,_) -> 23 * acc + Hashtbl.hash e.ename
- | TBuiltin_va_list _ -> 29 * acc
+ | TNamed ti -> 13 * acc + Hashtbl.hash ti.tname
+ | TComp ci ->
+ let mul = if ci.cstruct then 17 else 19 in
+ mul * acc + Hashtbl.hash ci.cname
+ | TEnum ei -> 23 * acc + Hashtbl.hash ei.ename
+ | TBuiltin_va_list -> 29 * acc
in
aux 117 0 t
@@ -1319,8 +1320,8 @@ let update_compinfo ci =
node.ndata
let rec update_type_repr t =
- match t with
- | TNamed (ti,attrs) ->
+ match t.tnode with
+ | TNamed ti ->
ti.ttype <- update_type_repr ti.ttype;
let node =
PlainMerging.getNode tEq tSyn !currentFidx ti.tname ti None
@@ -1356,9 +1357,9 @@ let rec update_type_repr t =
node.nrep <- node;
PlainMerging.add_eq_table tEq (oldnode.nfidx, n) renamed_node;
end;
- TNamed(node.ndata,attrs)
- | TComp (ci,attrs) ->
- TComp (update_compinfo ci, attrs)
+ Cil_const.mk_tnamed ~tattr:t.tattr node.ndata
+ | TComp ci ->
+ Cil_const.mk_tcomp ~tattr:t.tattr (update_compinfo ci)
| _ -> t
let static_var_visitor = object
@@ -1752,14 +1753,14 @@ let oneFilePass1 (f:file) : unit =
(Some (l, !currentDeclIdx)))
else begin (* Go inside and clean the referenced flag for the
* declared tags *)
- match t.ttype with
- TComp (ci, _ ) ->
+ match t.ttype.tnode with
+ TComp ci ->
ci.creferenced <- false;
(* Create a node for it *)
ignore
(PlainMerging.getNode sEq sSyn !currentFidx ci.cname ci None)
- | TEnum (ei, _) ->
+ | TEnum ei ->
ei.ereferenced <- false;
ignore
(EnumMerging.getNode eEq eSyn !currentFidx ei ei None)
@@ -1843,9 +1844,9 @@ let logic_info_of_logic_var lv =
let tparams = extract_tparams Datatype.String.Set.empty lv.lv_type in
let rt, args =
match lv.lv_type with
- | Larrow (l, Ctype (TVoid _)) -> None, l
+ | Larrow (l, Ctype { tnode = TVoid }) -> None, l
| Larrow(l,t) -> Some t, l
- | Ctype (TVoid _) -> None, []
+ | Ctype { tnode = TVoid } -> None, []
| t -> Some t, []
in
{ l_var_info = lv;
@@ -2011,8 +2012,8 @@ class renameVisitorClass =
(* The use of a type. Change only those types whose underlying info
* is not a root. *)
method! vtype (t: typ) =
- match t with
- TComp (ci, a) when not ci.creferenced -> begin
+ match t.tnode with
+ | TComp ci when not ci.creferenced -> begin
match PlainMerging.findReplacement true sEq !currentFidx ci.cname with
None ->
Kernel.debug ~dkey:Kernel.dkey_linker "No renaming needed %s(%d)"
@@ -2022,28 +2023,31 @@ class renameVisitorClass =
Kernel.debug ~dkey:Kernel.dkey_linker
"Renaming use of %s(%d) to %s(%d)"
ci.cname !currentFidx ci'.cname oldfidx;
- ChangeTo (TComp (ci', visitCilAttributes (self :> cilVisitor) a))
+ let tattr = visitCilAttributes (self :> cilVisitor) t.tattr in
+ ChangeTo (Cil_const.mk_tcomp ~tattr ci')
end
- | TComp(ci,_) ->
+ | TComp ci ->
Kernel.debug ~dkey:Kernel.dkey_linker
"%s(%d) referenced. No change" ci.cname !currentFidx;
DoChildren
- | TEnum (ei, a) when not ei.ereferenced -> begin
+ | TEnum ei when not ei.ereferenced -> begin
match EnumMerging.findReplacement true eEq !currentFidx ei with
None -> DoChildren
| Some (ei', _) ->
+ let tattr = visitCilAttributes (self :> cilVisitor) t.tattr in
if ei' == intEnumInfo then
(* This is actually our friend intEnumInfo *)
- ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a))
+ ChangeTo (Cil_const.mk_tint ~tattr IInt)
else
- ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a))
+ ChangeTo (Cil_const.mk_tenum ~tattr ei')
end
- | TNamed (ti, a) when not ti.treferenced -> begin
+ | TNamed ti when not ti.treferenced -> begin
match PlainMerging.findReplacement true tEq !currentFidx ti.tname with
None -> DoChildren
| Some (ti', _) ->
- ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a))
+ let tattr = visitCilAttributes (self :> cilVisitor) t.tattr in
+ ChangeTo (Cil_const.mk_tnamed ~tattr ti')
end
| _ -> DoChildren
diff --git a/src/kernel_internals/typing/oneret.ml b/src/kernel_internals/typing/oneret.ml
index 6f805da8dae..fcf62faa80b 100644
--- a/src/kernel_internals/typing/oneret.ml
+++ b/src/kernel_internals/typing/oneret.ml
@@ -203,13 +203,13 @@ let oneret ?(callback: callback option) (f: fundec) : unit =
let fname = f.svar.vname in
(* Get the return type *)
let retTyp =
- match f.svar.vtype with
- TFun(rt, _, _, _) -> rt
+ match f.svar.vtype.tnode with
+ TFun(rt, _, _) -> rt
| _ ->
Kernel.fatal "Function %s does not have a function type" f.svar.vname
in
(* Does it return anything ? *)
- let hasRet = match unrollType retTyp with TVoid _ -> false | _ -> true in
+ let hasRet = match unrollTypeNode retTyp with TVoid -> false | _ -> true in
(* Memoize the return result variable. Use only if hasRet *)
let lastloc = ref Cil_datatype.Location.unknown in
diff --git a/src/kernel_internals/typing/rmtmps.ml b/src/kernel_internals/typing/rmtmps.ml
index 7dcb102cb80..14ec4b538c9 100644
--- a/src/kernel_internals/typing/rmtmps.ml
+++ b/src/kernel_internals/typing/rmtmps.ml
@@ -274,7 +274,7 @@ let isExportedRoot global =
v.vname, true, "has FC_BUILTIN attribute"
| GAnnot _ -> "", true, "global annotation"
| GType (t, _) when
- Cil.hasAttribute "FC_BUILTIN" (Cil.typeAttr t.ttype) ->
+ Cil.hasAttribute "FC_BUILTIN" t.ttype.tattr ->
t.tname, true, "has FC_BUILTIN attribute"
| GCompTag (c,_) | GCompTagDecl (c,_) when
Cil.hasAttribute "FC_BUILTIN" c.cattr ->
@@ -446,12 +446,12 @@ class markReachableVisitor
ignore (visitCilAttributes (self :> cilVisitor) attrs)
method! vtype typ =
- (match typ with
- | TEnum(e, attrs) ->
- self#visitAttrs attrs;
+ (match typ.tnode with
+ | TEnum e ->
+ self#visitAttrs typ.tattr;
self#mark_enum e
- | TComp(c, attrs) ->
+ | TComp c ->
let old = is_reachable reachable_tbl (Comp c) in
if not old then
begin
@@ -462,11 +462,11 @@ class markReachableVisitor
(* to recurse, we must ask explicitly *)
let recurse f = ignore (self#vtype f.ftype) in
List.iter recurse (Option.value ~default:[] c.cfields);
- self#visitAttrs attrs;
+ self#visitAttrs typ.tattr;
self#visitAttrs c.cattr
end;
- | TNamed(ti, attrs) ->
+ | TNamed ti ->
let old = (is_reachable reachable_tbl (Type ti)) in
if not old then
begin
@@ -476,19 +476,19 @@ class markReachableVisitor
(* recurse deeper into the type referred-to by the typedef *)
(* to recurse, we must ask explicitly *)
ignore (self#vtype ti.ttype);
- self#visitAttrs attrs
+ self#visitAttrs typ.tattr
end;
- | TVoid a | TInt (_,a) | TFloat (_,a) | TBuiltin_va_list a ->
- self#visitAttrs a
- | TPtr(ty,a) -> ignore (self#vtype ty); self#visitAttrs a
- | TArray(ty,sz, a) ->
- ignore (self#vtype ty); self#visitAttrs a;
+ | TVoid | TInt _ | TFloat _ | TBuiltin_va_list ->
+ self#visitAttrs typ.tattr
+ | TPtr ty -> ignore (self#vtype ty); self#visitAttrs typ.tattr
+ | TArray (ty, sz) ->
+ ignore (self#vtype ty); self#visitAttrs typ.tattr;
Option.iter (ignore $ (visitCilExpr (self:>cilVisitor))) sz
- | TFun (ty, args,_,a) ->
+ | TFun (ty, args, _) ->
ignore (self#vtype ty);
Option.iter (List.iter (fun (_,ty,_) -> ignore (self#vtype ty))) args;
- self#visitAttrs a
+ self#visitAttrs typ.tattr
);
SkipChildren
@@ -620,32 +620,33 @@ class markReferencedVisitor = object (self)
SkipChildren
| _ -> SkipChildren
- method! vtype = function
- | TNamed (ti, _) ->
+ method! vtype t =
+ match t.tnode with
+ | TNamed ti ->
if not (Stack.is_empty inside_typ) then begin
Kernel.debug ~current:true ~dkey "referenced: type %s" ti.tname;
ti.treferenced <- true;
end;
DoChildren
- | TComp (ci, _) ->
+ | TComp ci ->
if not (Stack.is_empty inside_typ) then begin
Kernel.debug ~current:true ~dkey "referenced: comp %s" ci.cname;
ci.creferenced <- true;
end;
DoChildren
- | TEnum (ei, _) ->
+ | TEnum ei ->
if not (Stack.is_empty inside_typ) then begin
Kernel.debug ~current:true ~dkey "referenced: enum %s" ei.ename;
ei.ereferenced <- true;
end;
DoChildren
- | TVoid _
+ | TVoid
| TInt _
| TFloat _
| TPtr _
| TArray _
| TFun _
- | TBuiltin_va_list _ -> DoChildren
+ | TBuiltin_va_list -> DoChildren
method! vexpr e =
match e.enode with
@@ -823,7 +824,7 @@ let removeUnmarked isRoot ast reachable_tbl =
(* unused global types, variables, and functions are simply removed *)
| GType (t, _) ->
is_reachable reachable_tbl (Type t) ||
- Cil.hasAttribute "FC_BUILTIN" (Cil.typeAttr t.ttype)
+ Cil.hasAttribute "FC_BUILTIN" t.ttype.tattr
|| isRoot global
| GCompTag (c,_) | GCompTagDecl (c,_) ->
is_reachable reachable_tbl (Comp c) ||
diff --git a/src/kernel_internals/typing/substitute_const_globals.ml b/src/kernel_internals/typing/substitute_const_globals.ml
index 4763c4e44e6..df5860eb8c8 100644
--- a/src/kernel_internals/typing/substitute_const_globals.ml
+++ b/src/kernel_internals/typing/substitute_const_globals.ml
@@ -35,8 +35,9 @@ class constGlobSubstVisitorClass : cilVisitor = object
(* Visit globals and register only the association between globals with attribute
'const' and respective initializers. *)
method! vglob g =
- let rec is_arithmetic_type = function
- | TArray (typ, _, _) -> is_arithmetic_type typ
+ let rec is_arithmetic_type t =
+ match t.tnode with
+ | TArray (typ, _) -> is_arithmetic_type typ
| TInt _ | TFloat _ | TEnum _ -> true
| _ -> false
in
diff --git a/src/kernel_services/abstract_interp/base.ml b/src/kernel_services/abstract_interp/base.ml
index 3b32bf604b9..8aa162acb65 100644
--- a/src/kernel_services/abstract_interp/base.ml
+++ b/src/kernel_services/abstract_interp/base.ml
@@ -250,9 +250,10 @@ let is_weak = function
| _ -> false
(* Does a C type end by an empty struct? *)
-let rec final_empty_struct = function
- | TArray (typ, _, _) -> final_empty_struct typ
- | TComp (compinfo, _) ->
+let rec final_empty_struct t =
+ match t.tnode with
+ | TArray (typ, _) -> final_empty_struct typ
+ | TComp compinfo ->
begin
match compinfo.cfields with
| Some [] | None -> true
@@ -261,9 +262,9 @@ let rec final_empty_struct = function
try Cil.bitsSizeOf last_field.ftype = 0
with Cil.SizeOfError _ -> false
end
- | TNamed (typeinfo, _) -> final_empty_struct typeinfo.ttype
- | TVoid _ | TInt _ | TFloat _ | TPtr _ | TEnum _
- | TFun _ | TBuiltin_va_list _ -> false
+ | TNamed typeinfo -> final_empty_struct typeinfo.ttype
+ | TVoid | TInt _ | TFloat _ | TPtr _ | TEnum _
+ | TFun _ | TBuiltin_va_list -> false
(* Does a base end by an empty struct? *)
let final_empty_struct = function
diff --git a/src/kernel_services/abstract_interp/cvalue.ml b/src/kernel_services/abstract_interp/cvalue.ml
index 39cce4963fe..37f7e90159b 100644
--- a/src/kernel_services/abstract_interp/cvalue.ml
+++ b/src/kernel_services/abstract_interp/cvalue.ml
@@ -142,7 +142,7 @@ module V = struct
offsets. *)
let pretty_base_offsets_typ typ fmt b i =
let typ_match = match Option.map Cil.unrollType typ with
- | Some (TPtr (typ_pointed, _)) ->
+ | Some { tnode = TPtr typ_pointed } ->
if Cil.isVoidType typ_pointed then None else Some typ_pointed
| _ -> None
in
@@ -191,9 +191,9 @@ module V = struct
let conv_offset' o =
let o, ok = conv_offset o in
if o = NoOffset then
- let o' = match Cil.unrollType typ_base with
+ let o' = match Cil.unrollTypeNode typ_base with
| TArray _ -> Index (Cil.(zero ~loc:Cil_builtins.builtinLoc), NoOffset)
- | TComp (ci, _) -> Field (List.hd (Option.get ci.cfields), NoOffset)
+ | TComp ci -> Field (List.hd (Option.get ci.cfields), NoOffset)
| _ -> raise Bit_utils.NoMatchingOffset
in o', ok
else o, ok
@@ -255,7 +255,7 @@ module V = struct
try
let ival = project_ival v in
match Ival.project_small_set ival, Option.map Cil.unrollType typ with
- | Some list, Some (TEnum (ei, _)) -> pretty_enumitem_set ei fmt list
+ | Some list, Some { tnode = TEnum ei } -> pretty_enumitem_set ei fmt list
| _ -> Ival.pretty fmt ival
with
| Not_based_on_null ->
diff --git a/src/kernel_services/abstract_interp/offsetmap.ml b/src/kernel_services/abstract_interp/offsetmap.ml
index 7c1a623c66e..5be034f8c61 100644
--- a/src/kernel_services/abstract_interp/offsetmap.ml
+++ b/src/kernel_services/abstract_interp/offsetmap.ml
@@ -2653,8 +2653,7 @@ module Int_Intervals = struct
let typ =
match typ with
| Some t -> t
- | None ->
- Cil_types.(TArray (TInt(IUChar,[]), None, []))
+ | None -> Cil_const.(mk_tarray ucharType None)
in
match i with
| Top -> Format.pp_print_string fmt "[..]"
diff --git a/src/kernel_services/analysis/bit_utils.ml b/src/kernel_services/analysis/bit_utils.ml
index 6c3396d6ea2..79afd2818a6 100644
--- a/src/kernel_services/analysis/bit_utils.ml
+++ b/src/kernel_services/analysis/bit_utils.ml
@@ -59,8 +59,8 @@ let warn_if_zero ty r =
(** [sizeof ty] is the size of [ty] in bits. This function may return
[Int_Base.top]. *)
let sizeof ty =
- (match ty with
- | TVoid _ -> Kernel.warning ~current:true ~once:true "using size of 'void'"
+ (match ty.tnode with
+ | TVoid -> Kernel.warning ~current:true ~once:true "using size of 'void'"
| _ -> ()) ;
try Int_Base.inject (Integer.of_int (bitsSizeOf ty))
with SizeOfError _ ->
@@ -69,8 +69,8 @@ let sizeof ty =
(** [osizeof ty] is the size of [ty] in bytes. This function may return
[Int_Base.top]. *)
let osizeof ty =
- (match ty with
- | TVoid _ -> Kernel.warning ~once:true ~current:true "using size of 'void'"
+ (match ty.tnode with
+ | TVoid -> Kernel.warning ~once:true ~current:true "using size of 'void'"
| _ -> ()) ;
try
Int_Base.inject (Integer.of_int (warn_if_zero ty (bitsSizeOf ty) / 8))
@@ -81,11 +81,11 @@ exception Neither_Int_Nor_Enum_Nor_Pointer
(** May raise [Neither_Int_Nor_Enum_Nor_Pointer] if the sign of the type is not
meaningful. [true] means that the type is signed. *)
let is_signed_int_enum_pointer ty =
- match unrollType ty with
- | TInt (k,_) | TEnum ({ekind=k},_) -> Cil.isSigned k
+ match unrollTypeNode ty with
+ | TInt k | TEnum {ekind=k} -> Cil.isSigned k
| TPtr _ -> false
- | TFloat _ | TFun _ | TBuiltin_va_list _
- | TVoid _ | TArray _ | TComp _
+ | TFloat _ | TFun _ | TBuiltin_va_list
+ | TVoid | TArray _ | TComp _
| TNamed _ -> raise Neither_Int_Nor_Enum_Nor_Pointer
(** Returns the sign of type of the [lval]. [true] means that the type is
@@ -117,9 +117,9 @@ let sizeof_lval lv =
(** Returns the size of the type pointed by a pointer type in bits.
Never call it on a non pointer type. *)
let sizeof_pointed typ =
- match unrollType typ with
- | TPtr (typ,_) -> sizeof typ
- | TArray(typ,_,_) -> sizeof typ
+ match unrollTypeNode typ with
+ | TPtr typ -> sizeof typ
+ | TArray (typ,_) -> sizeof typ
| _ ->
Kernel.fatal "TYPE IS: %a (unrolled as %a)"
Printer.pp_typ typ
@@ -128,9 +128,9 @@ let sizeof_pointed typ =
(** Returns the size of the type pointed by a pointer type in bytes.
Never call it on a non pointer type. *)
let osizeof_pointed typ =
- match unrollType typ with
- | TPtr (typ,_) -> osizeof typ
- | TArray(typ,_,_) -> osizeof typ
+ match unrollTypeNode typ with
+ | TPtr typ -> osizeof typ
+ | TArray (typ,_) -> osizeof typ
| _ ->
assert false (*
Format.printf "TYPE IS: %a\n" Printer.pp_typ typ;
@@ -214,9 +214,10 @@ let rec pretty_bits_internal env bfinfo typ ~align ~start ~stop =
Abstract_interp.Int.pretty start
Abstract_interp.Int.pretty stop;
false) else true);
- match (unrollType typ) with
- | TInt (_ , _) | TPtr (_, _) | TEnum (_, _) | TFloat (_, _)
- | TVoid _ | TBuiltin_va_list _ | TNamed _ | TFun (_, _, _, _) as typ ->
+ let typ = unrollType typ in
+ match typ.tnode with
+ | TInt _ | TPtr _ | TEnum _ | TFloat _
+ | TVoid | TBuiltin_va_list | TNamed _ | TFun (_, _, _) ->
let size =
match bfinfo with
| Other -> begin
@@ -239,7 +240,7 @@ let rec pretty_bits_internal env bfinfo typ ~align ~start ~stop =
raw_bits 'b' start stop)
)
- | TComp (compinfo, _) as typ ->
+ | TComp compinfo ->
let size = Integer.of_int (try bitsSizeOf typ
with SizeOfError _ -> 0)
in
@@ -342,7 +343,7 @@ let rec pretty_bits_internal env bfinfo typ ~align ~start ~stop =
raw_bits '?' start stop
end
- | TArray (typ, _, _) ->
+ | TArray (typ, _) ->
let size =
try Integer.of_int (bitsSizeOf typ)
with Cil.SizeOfError _ -> Integer.zero
@@ -463,16 +464,16 @@ type offset_match =
(* Comparison of the shape of two types. Attributes are completely ignored. *)
let rec type_compatible t1 t2 =
- match Cil.unrollType t1, Cil.unrollType t2 with
- | TVoid _, TVoid _ -> true
- | TInt (i1, _), TInt (i2, _) -> i1 = i2
- | TFloat (f1, _), TFloat (f2, _) -> f1 = f2
- | TPtr (t1, _), TPtr (t2, _) -> type_compatible t1 t2
- | TArray (t1', s1, _), TArray (t2', s2, _) ->
+ match unrollTypeNode t1, Cil.unrollTypeNode t2 with
+ | TVoid, TVoid -> true
+ | TInt i1, TInt i2 -> i1 = i2
+ | TFloat f1, TFloat f2 -> f1 = f2
+ | TPtr t1, TPtr t2 -> type_compatible t1 t2
+ | TArray (t1', s1), TArray (t2', s2) ->
type_compatible t1' t2' &&
(s1 == s2 || try Integer.equal (Cil.lenOfArray64 s1) (Cil.lenOfArray64 s2)
with Cil.LenOfArray _ -> false)
- | TFun (r1, a1, v1, _), TFun (r2, a2, v2, _) ->
+ | TFun (r1, a1, v1), TFun (r2, a2, v2) ->
v1 = v2 && type_compatible r1 r2 &&
(match a1, a2 with
| None, _ | _, None -> true
@@ -482,11 +483,11 @@ let rec type_compatible t1 t2 =
(fun (_, t1, _) (_, t2, _) -> type_compatible t1 t2) l1 l2
with Invalid_argument _ -> false)
| TNamed _, TNamed _ -> assert false
- | TComp (c1, _), TComp (c2, _) -> c1.ckey = c2.ckey
- | TEnum (e1, _), TEnum (e2, _) -> e1.ename = e2.ename
- | TBuiltin_va_list _, TBuiltin_va_list _ -> true
- | (TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ |
- TComp _ | TEnum _ | TBuiltin_va_list _), _ ->
+ | TComp c1, TComp c2 -> c1.ckey = c2.ckey
+ | TEnum e1, TEnum e2 -> e1.ename = e2.ename
+ | TBuiltin_va_list, TBuiltin_va_list -> true
+ | (TVoid | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ |
+ TComp _ | TEnum _ | TBuiltin_va_list), _ ->
false
(* We have found a possible matching offset of type [typ] for [om], do we stop
@@ -516,8 +517,8 @@ let rec find_offset typ ~offset om =
if Integer.is_zero offset && offset_matches om typ then
NoOffset, typ
else
- match Cil.unrollType typ with
- | TArray (typ_elt, _, _) ->
+ match Cil.unrollTypeNode typ with
+ | TArray (typ_elt, _) ->
let size_elt = Integer.of_int (Cil.bitsSizeOf typ_elt) in
if Integer.(equal size_elt zero) then
begin
@@ -528,7 +529,7 @@ let rec find_offset typ ~offset om =
Since the sizeof each element is zero, any offset is valid anyway.
*)
let typ =
- TArray (typ_elt, Some minus_one_expr, [])
+ Cil_const.mk_tarray typ_elt (Some minus_one_expr)
in
Index (minus_one_expr, NoOffset), typ
end
@@ -551,14 +552,14 @@ let rec find_offset typ ~offset om =
let nb = Integer.e_div size size_elt in
let exp_nb = Cil.kinteger64 ~loc nb in
let typ =
- TArray (typ_elt, Some exp_nb, [])
+ Cil_const.mk_tarray typ_elt (Some exp_nb)
in
Index (exp_start, NoOffset), typ
else (* We match different parts of multiple cells: too imprecise. *)
raise NoMatchingOffset
end
- | TComp (ci, _) ->
+ | TComp ci ->
let rec find_field = function
| [] -> raise NoMatchingOffset
| fi :: q ->
diff --git a/src/kernel_services/analysis/exn_flow.ml b/src/kernel_services/analysis/exn_flow.ml
index 609500cda3e..747ad94e0e5 100644
--- a/src/kernel_services/analysis/exn_flow.ml
+++ b/src/kernel_services/analysis/exn_flow.ml
@@ -283,35 +283,35 @@ let compute () = Globals.Functions.iter compute_kf
let get_type_tag t =
let rec aux t =
- match t with
- | TVoid _ -> "v"
- | TInt (IBool,_) -> "B"
- | TInt (IChar,_) -> "c"
- | TInt (ISChar,_) -> "sc"
- | TInt (IUChar,_) -> "uc"
- | TInt (IInt,_) -> "i"
- | TInt (IUInt,_) -> "ui"
- | TInt (IShort,_) -> "s"
- | TInt (IUShort,_) -> "us"
- | TInt (ILong,_) -> "l"
- | TInt (IULong,_) -> "ul"
- | TInt (ILongLong,_) -> "ll"
- | TInt (IULongLong,_) -> "ull"
- | TFloat(FFloat,_) -> "f"
- | TFloat(FDouble,_) -> "d"
- | TFloat (FLongDouble,_) -> "ld"
- | TPtr(t,_) -> "p" ^ aux t
- | TArray(t,_,_) -> "a" ^ aux t
- | TFun(rt,l,_,_) ->
+ match t.tnode with
+ | TVoid -> "v"
+ | TInt IBool -> "B"
+ | TInt IChar -> "c"
+ | TInt ISChar -> "sc"
+ | TInt IUChar -> "uc"
+ | TInt IInt -> "i"
+ | TInt IUInt -> "ui"
+ | TInt IShort -> "s"
+ | TInt IUShort -> "us"
+ | TInt ILong -> "l"
+ | TInt IULong -> "ul"
+ | TInt ILongLong -> "ll"
+ | TInt IULongLong -> "ull"
+ | TFloat FFloat -> "f"
+ | TFloat FDouble -> "d"
+ | TFloat FLongDouble -> "ld"
+ | TPtr t -> "p" ^ aux t
+ | TArray (t, _) -> "a" ^ aux t
+ | TFun (rt, l, _) ->
let base = "fun" ^ aux rt in
(match l with
| None -> base
| Some l ->
List.fold_left (fun acc (_,t,_) -> acc ^ aux t) base l)
| TNamed _ -> Kernel.fatal "named type not correctly unrolled"
- | TComp (s,_) -> (if s.cstruct then "S" else "U") ^ s.cname
- | TEnum (e,_) -> "E" ^ e.ename
- | TBuiltin_va_list _ -> "va"
+ | TComp ci -> (if ci.cstruct then "S" else "U") ^ ci.cname
+ | TEnum ei -> "E" ^ ei.ename
+ | TBuiltin_va_list -> "va"
in "__fc_" ^ aux t
let get_type_enum t = "__fc_exn_kind_" ^ (get_type_tag t)
@@ -366,10 +366,10 @@ let generate_exn_union e exns =
in
let create_struct_fields _ =
let uncaught = (exn_uncaught_name, Cil_const.intType, None, [], loc) in
- let kind = (exn_kind_name, TEnum (e,[]), None, [], loc) in
+ let kind = (exn_kind_name, Cil_const.mk_tenum e, None, [], loc) in
let obj =
(exn_obj_name,
- TComp(exn_kind_union, []), None, [], loc)
+ Cil_const.mk_tcomp exn_kind_union, None, [], loc)
in
Some [uncaught; kind; obj]
in
@@ -563,7 +563,7 @@ class erase_exn =
let e = generate_exn_enum exns in
let u,s = generate_exn_union e exns in
let exn =
- Cil.makeGlobalVar "__fc_exn" (TComp (s,[]))
+ Cil.makeGlobalVar "__fc_exn" (Cil_const.mk_tcomp s)
in
self#update_enum_bindings e exns;
self#update_union_bindings u exns;
@@ -574,7 +574,7 @@ class erase_exn =
GCompTag (u,loc) ::
GEnumTag (e,loc) :: new_types;
exn_var <- Some exn;
- let exn_init = Cil.makeZeroInit ~loc (TComp(s,[]))
+ let exn_init = Cil.makeZeroInit ~loc (Cil_const.mk_tcomp s)
in
let gexn_var = GVar(exn, { init = Some exn_init }, loc) in
ChangeDoChildrenPost(
diff --git a/src/kernel_services/ast_building/cil_builder.ml b/src/kernel_services/ast_building/cil_builder.ml
index 97e4839294d..c3d9fc6ebdc 100644
--- a/src/kernel_services/ast_building/cil_builder.ml
+++ b/src/kernel_services/ast_building/cil_builder.ml
@@ -42,6 +42,7 @@ struct
and ('value,'shape) typ = ('value,'shape) morphology * Cil_types.logic_type
open Cil_types
+ open Cil_const
(* Logic types *)
@@ -51,26 +52,26 @@ struct
(* C base types *)
- let of_ctyp t = Single, Ctype t
- let void = Single, Ctype (TVoid [])
- let bool = Single, Ctype (TInt (IBool, []))
- let char = Single, Ctype (TInt (IChar, []))
- let schar = Single, Ctype (TInt (ISChar, []))
- let uchar = Single, Ctype (TInt (IUChar, []))
- let int = Single, Ctype (TInt (IInt, []))
- let uint = Single, Ctype (TInt (IUInt, []))
- let short = Single, Ctype (TInt (IShort, []))
- let ushort = Single, Ctype (TInt (IUShort, []))
- let long = Single, Ctype (TInt (ILong, []))
- let ulong = Single, Ctype (TInt (IULong, []))
- let longlong = Single, Ctype (TInt (ILongLong, []))
- let ulonglong = Single, Ctype (TInt (IULongLong, []))
- let float = Single, Ctype (TFloat (FFloat, []))
- let double = Single, Ctype (TFloat (FDouble, []))
- let longdouble = Single, Ctype (TFloat (FLongDouble, []))
+ let of_ctyp t = Single, Ctype t
+ let void = Single, Ctype voidType
+ let bool = Single, Ctype boolType
+ let char = Single, Ctype charType
+ let schar = Single, Ctype scharType
+ let uchar = Single, Ctype ucharType
+ let int = Single, Ctype intType
+ let uint = Single, Ctype uintType
+ let short = Single, Ctype shortType
+ let ushort = Single, Ctype ushortType
+ let long = Single, Ctype longType
+ let ulong = Single, Ctype ulongType
+ let longlong = Single, Ctype longLongType
+ let ulonglong = Single, Ctype ulongLongType
+ let float = Single, Ctype floatType
+ let double = Single, Ctype doubleType
+ let longdouble = Single, Ctype longDoubleType
let ptr = function
- | _, Ctype t -> Single, Ctype (TPtr (t, []))
+ | _, Ctype t -> Single, Ctype (mk_tptr t)
| _, _ -> raise NotACType
let array ?size = function
@@ -78,33 +79,21 @@ struct
let to_exp = Cil.integer ~loc:unknown_loc in
let size = Option.map to_exp size in
Listed typ,
- Ctype (TArray (t, size, []))
+ Ctype (mk_tarray t size)
| _, _ -> raise NotACType
let structure compinfo f =
- Record f, Ctype (TComp (compinfo, []))
+ Record f, Ctype (mk_tcomp compinfo)
(* Attrbutes *)
- let attribute (s,t) name params =
- let add_to = Cil.addAttribute (Attr (name, params)) in
- let t = match t with
- | Ctype t -> t
- | _ -> raise NotACType
- in
- let t = match t with
- | TVoid l -> TVoid (add_to l)
- | TInt (kind, l) -> TInt (kind, add_to l)
- | TFloat (kind, l) -> TFloat (kind, add_to l)
- | TPtr (typ, l) -> TPtr (typ, add_to l)
- | TArray (typ, size, l) -> TArray (typ, size, add_to l)
- | TFun (typ, args, variadic, l) -> TFun (typ, args, variadic, add_to l)
- | TNamed (typeinfo, l) -> TNamed (typeinfo, add_to l)
- | TComp (compinfo, l) -> TComp (compinfo, add_to l)
- | TEnum (enuminfo, l) -> TEnum (enuminfo, add_to l)
- | TBuiltin_va_list l -> TBuiltin_va_list (add_to l)
- in
- (s,Ctype t)
+ let attribute (s, t) name params =
+ match t with
+ | Ctype t ->
+ let tattr = Cil.addAttribute (Attr (name, params)) t.tattr in
+ s, Ctype { t with tattr }
+ | _ -> raise NotACType
+
let const typ = attribute typ "const" []
let stdlib_generated typ = attribute typ "fc_stdlib_generated" []
@@ -444,10 +433,10 @@ struct
let of_init i = `init (CilInit i)
let compound t l =
- match t with
- | Cil_types.TArray _ ->
+ match t.Cil_types.tnode with
+ | TArray _ ->
`init (ArrayInit (t, List.map harden_init l))
- | Cil_types.TComp (comp,_) ->
+ | TComp comp ->
let field_init field init =
field, harden_init init
in
@@ -459,7 +448,7 @@ struct
match ty with
| Single, Ctype _ -> x
| Listed sub, Ctype t-> compound t (List.map (values sub) x)
- | Record f, Ctype (TComp (comp,_) as t) ->
+ | Record f, Ctype (Cil_types.{ tnode = TComp comp } as t) ->
let field_init field =
field, harden_init (f field x)
in
@@ -516,7 +505,7 @@ struct
| Index (lv, e) ->
let (host, offset) as lv' = build_lval ~scope ~loc lv
and e' = build_exp ~scope ~loc e in
- begin match Cil.(unrollType (typeOfLval lv')) with
+ begin match Cil.(unrollTypeNode (typeOfLval lv')) with
| TArray _ ->
let offset' = Cil_types.Index (e', NoOffset) in
host, Cil.addOffset offset' offset
@@ -529,9 +518,9 @@ struct
end
| (Field (lv,_) | FieldNamed (lv,_)) as e ->
let (host, offset) as lv' = build_lval ~scope ~loc lv in
- let host', offset', ci = match Cil.(unrollTypeDeep (typeOfLval lv')) with
- | TComp (ci,_) -> host, offset, ci
- | TPtr (TComp (ci,_),_) ->
+ let host', offset', ci = match Cil.(unrollTypeDeep (typeOfLval lv')).tnode with
+ | TComp ci -> host, offset, ci
+ | TPtr { tnode = TComp ci } ->
Mem (Cil.new_exp ~loc (Lval lv')), Cil_types.NoOffset, ci
| _ -> typing_error "trying to get a field of an lvalue which is not \
of composite type or pointer to a composite type"
@@ -592,10 +581,10 @@ struct
and t' = build_term ~scope ~loc ~restyp t in
let lty = Cil.typeOfTermLval tlv' in
begin match Logic_utils.unroll_type lty with
- | Ctype (TArray _) ->
+ | Ctype { tnode = TArray _ } ->
let offset' = Cil_types.(TIndex (t', TNoOffset)) in
host, Logic_const.addTermOffset offset' offset
- | Ctype (TPtr _) ->
+ | Ctype { tnode = TPtr _ } ->
let base = Logic_const.term ~loc (TLval tlv') lty in
let addr = Logic_const.term ~loc (TBinOp (PlusPI,base,t')) lty in
TMem addr, TNoOffset
@@ -609,8 +598,8 @@ struct
| lty -> lty
in
let host', offset', ci = match lty with
- | Ctype (TComp (ci,_)) -> host, offset, ci
- | Ctype (TPtr (TComp (ci,_),_)) ->
+ | Ctype { tnode = TComp ci } -> host, offset, ci
+ | Ctype { tnode = TPtr { tnode = TComp ci } } ->
TMem (Logic_const.term ~loc (Cil_types.TLval tlv') lty), TNoOffset, ci
| _ -> typing_error "trying to get a field of an lvalue which is not \
of composite type or pointer to a composite type"
diff --git a/src/kernel_services/ast_data/alarms.ml b/src/kernel_services/ast_data/alarms.ml
index c30340bda37..1d83fc6d07b 100644
--- a/src/kernel_services/ast_data/alarms.ml
+++ b/src/kernel_services/ast_data/alarms.ml
@@ -514,8 +514,9 @@ let create_predicate ?(loc=Location.unknown) alarm =
let loc = best_loc ~loc e2.eloc in
let t1 = match e1 with
| None -> begin
- let typ = match Cil.unrollTypeDeep (Cil.typeOf e2) with
- | TPtr (TFun _, _) -> TPtr (TFun(Cil_const.voidType, None, false, []), [])
+ let typ = match Cil.(unrollTypeDeep (typeOf e2)).tnode with
+ | TPtr { tnode = TFun _ } ->
+ Cil_const.(mk_tptr (mk_tfun voidType None false))
| _ -> Cil_const.voidPtrType
in
let zero = Cil.lzero () in
@@ -618,14 +619,15 @@ let create_predicate ?(loc=Location.unknown) alarm =
let loc = e.eloc in
let t = Cil.typeOf e in
let e =
- match Cil.unrollTypeDeep t, args with
- | TPtr (TFun (_, Some _, _, _), _), _
- | TPtr (TFun _, _), None -> e
- | TPtr (TFun (ret, None, var, attrs), _), Some args ->
+ let t' = Cil.unrollTypeDeep t in
+ match t'.tnode, args with
+ | TPtr { tnode = TFun (_, Some _, _) }, _
+ | TPtr { tnode = TFun _ }, None -> e
+ | TPtr { tnode = TFun (ret, None, var); tattr }, Some args ->
let ltyps = List.map (fun arg -> "", Cil.typeOf arg, []) args in
- let typ = TFun (ret, Some ltyps, var, attrs) in
- Cil.mkCast ~newt:(TPtr (typ, [])) e
- | t', _ ->
+ let typ = Cil_const.mk_tfun ~tattr ret (Some ltyps) var in
+ Cil.mkCast ~newt:(Cil_const.mk_tptr typ) e
+ | _, _ ->
Kernel.fatal
"Trying to emit a Function_pointer alarm over expression %a \
that has unexpected type %a (unrolled as %a)"
diff --git a/src/kernel_services/ast_data/annotations.ml b/src/kernel_services/ast_data/annotations.ml
index ce32cb9f6b7..6864f1e2bdd 100644
--- a/src/kernel_services/ast_data/annotations.ml
+++ b/src/kernel_services/ast_data/annotations.ml
@@ -505,8 +505,8 @@ let model_fields ?emitter t =
with Not_found -> acc
with Not_found -> acc
in
- match t with
- | TNamed (ty,_) -> aux self_fields ty.ttype
+ match t.tnode with
+ | TNamed ti -> aux self_fields ti.ttype
| _ -> self_fields
in
aux [] t
diff --git a/src/kernel_services/ast_data/cil_types.ml b/src/kernel_services/ast_data/cil_types.ml
index 7981195c73d..0317e359af2 100644
--- a/src/kernel_services/ast_data/cil_types.ml
+++ b/src/kernel_services/ast_data/cil_types.ml
@@ -280,14 +280,14 @@ and global =
(** {2 Types} *)
(* ************************************************************************* *)
-(** A C type is represented in CIL using the type {!Cil_types.typ}. Among types
+(** A C type is represented in CIL using the type {!Cil_types.typ}. Among types
we differentiate the integral types (with different kinds denoting the sign
and precision), floating point types, enumeration types, array and pointer
types, and function types. Every type is associated with a list of
attributes, which are always kept in sorted order. Use {!Cil.addAttribute}
and {!Cil.addAttributes} to construct list of attributes. If you want to
- inspect a type, you should use {!Cil.unrollType} or {!Cil.unrollTypeDeep} to
- see through the uses of named types.
+ inspect a type, you should use {!Cil.unrollType}, {!Cil.unrollTypeNode} or
+ {!Cil.unrollTypeDeep} to see through the uses of named types.
CIL is configured at build-time with the sizes and alignments of the
underlying compiler (GCC or MSVC). CIL contains functions that can compute
@@ -296,27 +296,39 @@ and global =
(both in bits) using the function {!Cil.bitsOffset}. At the moment these
functions do not take into account the [packed] attributes and pragmas. *)
-and typ =
- | TVoid of attributes (** Void type. Also predefined as {!Cil_const.voidType} *)
+(** The representation of a Cil type.
+ @before Frama-C+dev This type was not a record but a variant like
+ {!typ_node} with attributes being part of the tuples. *)
+and typ = {
+ tnode : typ_node;
+ (** The type itself. *)
- | TInt of ikind * attributes
+ tattr : attributes;
+ (** A list of attributes associated with the type, including its qualifiers. *)
+}
+
+(** @since Frama-C+dev *)
+and typ_node =
+ | TVoid (** Void type. Also predefined as {!Cil_const.voidType} *)
+
+ | TInt of ikind
(** An integer type. The kind specifies the sign and width. Several useful
variants are predefined as {!Cil_const.intType}, {!Cil_const.uintType},
{!Cil_const.longType}, {!Cil_const.charType}. *)
- | TFloat of fkind * attributes
+ | TFloat of fkind
(** A floating-point type. The kind specifies the precision. You can also use
the predefined constant {!Cil_const.doubleType}. *)
- | TPtr of typ * attributes
+ | TPtr of typ
(** Pointer type. Several useful variants are predefined as
{!Cil_const.charPtrType}, {!Cil_const.charConstPtrType} (pointer to a constant
character), {!Cil_const.voidPtrType}, {!Cil_const.intPtrType} *)
- | TArray of typ * exp option * attributes
+ | TArray of typ * exp option
(** Array type. It indicates the base type and the array length. *)
- | TFun of typ * (string * typ * attributes) list option * bool * attributes
+ | TFun of typ * (string * typ * attributes) list option * bool
(** Function type. Indicates the type of the result, the name, type
and name attributes of the formal arguments ([None] if no arguments
were specified, as in a function whose definition or prototype we
@@ -328,7 +340,7 @@ and typ =
{!Cil.setFormals}, or {!Cil.setFunctionType}, or
{!Cil.makeFormalVar} for this purpose. *)
- | TNamed of typeinfo * attributes
+ | TNamed of typeinfo
(** The use of a named type. All uses of the same type name must share the
typeinfo. Each such type name must be preceded in the file by a [GType]
global. This is printed as just the type name. The actual referred type
@@ -337,7 +349,7 @@ and typ =
attributes are in addition to those given when the type name was
defined. *)
- | TComp of compinfo * attributes
+ | TComp of compinfo
(** A reference to a struct or a union type. All references to the
same struct or union must share the same compinfo among them and
with a [GCompTag] global that precedes all uses (except maybe
@@ -346,14 +358,14 @@ and typ =
addition to the attributes that were given at the definition of
the type and which are stored in the compinfo. *)
- | TEnum of enuminfo * attributes
+ | TEnum of enuminfo
(** A reference to an enumeration type. All such references must
share the enuminfo among them and with a [GEnumTag] global that
precedes all uses. The attributes refer to this use of the
enumeration and are in addition to the attributes of the
enumeration itself, which are stored inside the enuminfo *)
- | TBuiltin_va_list of attributes
+ | TBuiltin_va_list
(** This is the same as the gcc's type with the same name *)
(* ************************************************************************* *)
diff --git a/src/kernel_services/ast_data/globals.ml b/src/kernel_services/ast_data/globals.ml
index 05e6fa76fdf..a18152d84d0 100644
--- a/src/kernel_services/ast_data/globals.ml
+++ b/src/kernel_services/ast_data/globals.ml
@@ -777,30 +777,30 @@ module Types = struct
let aux_glob g = match g with
| GType (ti, _loc) ->
let name_tag = (ti.tname, Logic_typing.Typedef) in
- Types.replace name_tag (TNamed (ti, []));
+ Types.replace name_tag (Cil_const.mk_tnamed ti);
TypeNameToGlobal.replace name_tag g
| GEnumTag (ei, _loc) ->
let name_tag = (ei.ename, Logic_typing.Enum) in
- Types.add name_tag (TEnum (ei, []));
+ Types.add name_tag (Cil_const.mk_tenum ei);
List.iter aux_ei ei.eitems;
TypeNameToGlobal.replace name_tag g
| GEnumTagDecl (ei, _) ->
let name_tag = (ei.ename, Logic_typing.Enum) in
- Types.add name_tag (TEnum (ei, []));
+ Types.add name_tag (Cil_const.mk_tenum ei);
List.iter aux_ei ei.eitems
| GCompTag (ci, _loc) ->
let kind = Logic_typing.(if ci.cstruct then Struct else Union) in
let name_tag = (ci.cname, kind) in
- Types.add name_tag (TComp (ci, []));
+ Types.add name_tag (Cil_const.mk_tcomp ci);
TypeNameToGlobal.replace name_tag g
| GCompTagDecl (ci, _) ->
let kind = Logic_typing.(if ci.cstruct then Struct else Union) in
let name_tag = (ci.cname, kind) in
- Types.add name_tag (TComp (ci, []))
+ Types.add name_tag (Cil_const.mk_tcomp ci)
| _ -> ()
in
diff --git a/src/kernel_services/ast_data/kernel_function.ml b/src/kernel_services/ast_data/kernel_function.ml
index 2ccc01dc302..de206414514 100644
--- a/src/kernel_services/ast_data/kernel_function.ml
+++ b/src/kernel_services/ast_data/kernel_function.ml
@@ -611,8 +611,8 @@ let is_main kf =
let returns_void kf =
let result_type,_,_,_ = Cil.splitFunctionType (get_type kf) in
- match Cil.unrollType result_type with
- | TVoid _ -> true
+ match Cil.unrollTypeNode result_type with
+ | TVoid -> true
| _ -> false
(* ************************************************************************* *)
diff --git a/src/kernel_services/ast_data/machine.ml b/src/kernel_services/ast_data/machine.ml
index 3864563b64a..8bd08467541 100644
--- a/src/kernel_services/ast_data/machine.ml
+++ b/src/kernel_services/ast_data/machine.ml
@@ -276,14 +276,14 @@ let init ~initLogicBuiltins machdep =
Kernel.fatal ~current:true
"Machine.init: cannot find the right ikind for type %s" name
in
- the_machine.upointKind <- findIkindSz true (sizeof_ptr ());
- the_machine.upointType <- TInt(the_machine.upointKind, []);
+ the_machine.upointKind <- findIkindSz true (sizeof_ptr ());
+ the_machine.upointType <- Cil_const.mk_tint the_machine.upointKind;
the_machine.kindOfSizeOf <- findIkindName (size_t ());
- the_machine.typeOfSizeOf <- TInt(the_machine.kindOfSizeOf, []);
- the_machine.wcharKind <- findIkindName (wchar_t ());
- the_machine.wcharType <- TInt(the_machine.wcharKind, []);
- the_machine.ptrdiffKind <- findIkindName (ptrdiff_t ());
- the_machine.ptrdiffType <- TInt(the_machine.ptrdiffKind, []);
+ the_machine.typeOfSizeOf <- Cil_const.mk_tint the_machine.kindOfSizeOf;
+ the_machine.wcharKind <- findIkindName (wchar_t ());
+ the_machine.wcharType <- Cil_const.mk_tint the_machine.wcharKind;
+ the_machine.ptrdiffKind <- findIkindName (ptrdiff_t ());
+ the_machine.ptrdiffType <- Cil_const.mk_tint the_machine.ptrdiffKind;
the_machine.useLogicalOperators <- Kernel.LogicalOperators.get ();
(* Have to be marked before calling [init*Builtins] below. *)
TheMachine.mark_as_computed ();
diff --git a/src/kernel_services/ast_printing/cil_printer.ml b/src/kernel_services/ast_printing/cil_printer.ml
index 43115b0c53e..e08be7ca062 100644
--- a/src/kernel_services/ast_printing/cil_printer.ml
+++ b/src/kernel_services/ast_printing/cil_printer.ml
@@ -712,27 +712,28 @@ class cil_printer () = object (self)
end;
self#varname fmt v.vname
- method private no_ghost_at_first_level = function
- | TArray(t, e, a) ->
- let t = Cil.typeRemoveAttributes [ "ghost" ] t in
- let a = Cil.dropAttribute "ghost" a in
- TArray (t, e, a)
- | t -> Cil.typeRemoveAttributes [ "ghost" ] t
+ method private no_ghost_at_first_level t =
+ match t.tnode with
+ | TArray (bt, e) ->
+ let bt' = Cil.typeRemoveAttributes [ "ghost" ] bt in
+ let tattr = Cil.dropAttribute "ghost" t.tattr in
+ Cil_const.mk_tarray ~tattr bt' e
+ | _ -> Cil.typeRemoveAttributes [ "ghost" ] t
(* variable declaration *)
method vdecl fmt (v:varinfo) =
let stom, rest = Cil.separateStorageModifiers v.vattr in
(* Small hack to keep printing noreturn attribute before function type. *)
- let noreturn_attrs = Cil.(filterAttributes "noreturn" (typeAttr v.vtype)) in
+ let noreturn_attrs = Cil.(filterAttributes "noreturn" v.vtype.tattr) in
let stom_noreturn = stom @ noreturn_attrs in
let vtype_no_noreturn = Cil.typeRemoveAttributes ["noreturn"] v.vtype in
let fundecl = if Cil.isFunctionType v.vtype then Some v else None in
let v = { v with vtype = self#no_ghost_at_first_level vtype_no_noreturn } in
let v =
if v.vformal && not state.print_cil_as_is then begin
- match v.vtype with
- | TPtr(t,a) when Cil.hasAttribute "arraylen" a ->
- { v with vtype = TArray(t, None, a)}
+ match v.vtype.tnode with
+ | TPtr t when Cil.hasAttribute "arraylen" v.vtype.tattr ->
+ { v with vtype = Cil_const.mk_tarray ~tattr:v.vtype.tattr t None}
| _ -> v
end
else v
@@ -961,8 +962,8 @@ class cil_printer () = object (self)
fprintf fmt "%a = " self#lval lv;
(* Maybe we need to print a cast *)
(let destt = Cil.typeOfLval lv in
- match Cil.unrollType (Cil.typeOf e) with
- | TFun(rt, _, _, _) when (Cil.need_cast rt destt) ->
+ match Cil.(unrollTypeNode (typeOf e)) with
+ | TFun(rt, _, _) when (Cil.need_cast rt destt) ->
fprintf fmt "(%a)" (self#typ None) destt
| _ -> ()));
(* Now the function name *)
@@ -1774,7 +1775,7 @@ class cil_printer () = object (self)
if verbose then
fprintf fmt "/* Following enum is equivalent to %a */@\n"
(self#typ None)
- (TInt(enum.ekind,[]));
+ (Cil_const.mk_tint enum.ekind);
fprintf fmt "%a@[ %a {@\n%a@]@\n}%a;@\n"
self#pp_keyword "enum"
(self#typedef g self#enumname) enum
@@ -1790,7 +1791,7 @@ class cil_printer () = object (self)
self#line_directive fmt l;
fprintf fmt "%a %a;@\n"
self#pp_keyword "enum"
- (self#typeref (TEnum(enum,[])) self#enumname) enum
+ (self#typeref (Cil_const.mk_tenum enum) self#enumname) enum
| GCompTag (comp, l) -> (* This is a definition of a tag *)
let sto_mod, rest_attr = Cil.separateStorageModifiers comp.cattr in
@@ -1807,7 +1808,7 @@ class cil_printer () = object (self)
self#line_directive fmt l;
fprintf fmt "%a %a;@\n"
self#compkind comp
- (self#typeref (TComp(comp,[])) self#compname) comp
+ (self#typeref (Cil_const.mk_tcomp comp) self#compname) comp
| GVar (vi, io, l) ->
self#line_directive ~forcefile:true fmt l;
@@ -1999,52 +2000,56 @@ class cil_printer () = object (self)
(* if pa = nil then nil else text "/*" ++ pa ++ text "*/"*)
| _ -> self#attributes fmt a
in
- match t with
- | TVoid a -> fprintf fmt "void%a%a" self#attributes a pname true
+ match t.tnode with
+ | TVoid -> fprintf fmt "void%a%a" self#attributes t.tattr pname true
- | TInt (ikind,a) ->
+ | TInt ikind ->
fprintf fmt "%a%a%a"
- (self#typeref t self#ikind) ikind self#attributes a pname true
+ (self#typeref t self#ikind) ikind
+ self#attributes t.tattr
+ pname true
- | TFloat(fkind, a) ->
+ | TFloat fkind ->
fprintf fmt "%a%a%a"
- (self#typeref t self#fkind) fkind self#attributes a pname true
+ (self#typeref t self#fkind) fkind
+ self#attributes t.tattr
+ pname true
- | TComp (comp, a) -> (* A reference to a struct *)
+ | TComp comp -> (* A reference to a struct *)
fprintf fmt "%a %a%a%a"
self#compkind comp
(self#typeref t self#compname) comp
- self#attributes a
+ self#attributes t.tattr
pname true
- | TEnum (enum, a) ->
+ | TEnum enum ->
fprintf fmt "%a %a%a%a"
self#pp_keyword "enum"
(self#typeref t self#enumname) enum
- self#attributes a
+ self#attributes t.tattr
pname true
- | TPtr (bt, a) ->
+ | TPtr bt ->
(* Parenthesize the ( * attr name) if a pointer to a function or an
* array. However, on MSVC the __stdcall modifier must appear right
* before the pointer constructor "(__stdcall *f)". We push them into
* the parenthesis. *)
let (paren: (formatter -> unit) option), (bt': typ) =
- match bt with
- | TFun(rt, args, isva, fa) when Machine.msvcMode () ->
- let an, af', at = Cil.partitionAttributes ~default:Cil.AttrType fa in
+ match bt.tnode with
+ | TFun(rt, args, isva) when Machine.msvcMode () ->
+ let an, af', at = Cil.partitionAttributes ~default:Cil.AttrType bt.tattr in
(* We take the af' and we put them into the parentheses *)
Some
(fun fmt ->
fprintf fmt
"(%a"
printAttributes af'),
- TFun(rt, args, isva, Cil.addAttributes an at)
+ Cil_const.mk_tfun ~tattr:(Cil.addAttributes an at) rt args isva
| TFun _ | TArray _ -> (Some (fun fmt -> fprintf fmt "(")), bt
| _ -> None, bt
in
let name' =
- fun fmt -> fprintf fmt "*%a%a" printAttributes a pname (a <> [])
+ fun fmt -> fprintf fmt "*%a%a" printAttributes t.tattr pname (t.tattr <> [])
in
let name'' =
fun fmt ->
@@ -2055,8 +2060,8 @@ class cil_printer () = object (self)
in
self#typ (Some name'') fmt bt'
- | TArray (elemt, lo, a) ->
- let atts_elem, a = Cil.splitArrayAttributes a in
+ | TArray (elemt, lo) ->
+ let atts_elem, a = Cil.splitArrayAttributes t.tattr in
let size_info,a =
List.partition
(fun a -> List.mem (Cil.attributeName a) ["arraylen"; "static"]) a
@@ -2097,11 +2102,11 @@ class cil_printer () = object (self)
fmt
elemt
- | TFun (restyp, args, isvararg, a) ->
+ | TFun (restyp, args, isvararg) ->
let name' fmt =
- if filter_printing_attributes a = [] then pname fmt false
- else if nameOpt = None then printAttributes fmt a
- else fprintf fmt "(%a%a)" printAttributes a pname true
+ if filter_printing_attributes t.tattr = [] then pname fmt false
+ else if nameOpt = None then printAttributes fmt t.tattr
+ else fprintf fmt "(%a%a)" printAttributes t.tattr pname true
in
let partition_ghosts ghost_arg args =
match args with
@@ -2150,15 +2155,15 @@ class cil_printer () = object (self)
in
self#typ (Some pp_params) fmt restyp
- | TNamed (ti, a) ->
+ | TNamed ti ->
fprintf fmt "%a%a%a"
(self#typeref t self#typename) ti
- self#attributes a
+ self#attributes t.tattr
pname true
- | TBuiltin_va_list a ->
+ | TBuiltin_va_list ->
fprintf fmt "__builtin_va_list%a%a"
- self#attributes a
+ self#attributes t.tattr
pname true
(**** PRINTING ATTRIBUTES *********)
@@ -2563,8 +2568,8 @@ class cil_printer () = object (self)
| TBinOp (op,l,r) ->
fprintf fmt "@[%a@ %a@ %a@]" term l self#term_binop op term r
| TCast (false, Ctype ty,t) ->
- begin match ty, t.term_node with
- | TFloat(fk,_) , TConst(LReal r as cst) when
+ begin match ty.tnode, t.term_node with
+ | TFloat fk , TConst(LReal r as cst) when
not Kernel.(is_debug_key_enabled dkey_print_logic_coercions) &&
Floating_point.has_suffix fk r.r_literal ->
self#logic_constant fmt cst
diff --git a/src/kernel_services/ast_printing/cil_types_debug.ml b/src/kernel_services/ast_printing/cil_types_debug.ml
index 090a31b3d26..1733f3d629b 100644
--- a/src/kernel_services/ast_printing/cil_types_debug.ml
+++ b/src/kernel_services/ast_printing/cil_types_debug.ml
@@ -121,23 +121,22 @@ and pp_global fmt = function
| GText(string) -> Format.fprintf fmt "GText(%a)" pp_string string
| GAnnot(global_annotation,location) -> Format.fprintf fmt "GAnnot(%a,%a)" pp_global_annotation global_annotation pp_location location
-and pp_typ fmt = function
- | TVoid(attributes) -> Format.fprintf fmt "TVoid(%a)" pp_attributes attributes
- | TInt(ikind,attributes) -> Format.fprintf fmt "TInt(%a,%a)" pp_ikind ikind pp_attributes attributes
- | TFloat(fkind,attributes) -> Format.fprintf fmt "TFloat(%a,%a)" pp_fkind fkind pp_attributes attributes
- | TPtr(typ,attributes) -> Format.fprintf fmt "TPtr(%a,%a)" pp_typ typ pp_attributes attributes
- | TArray(typ,exp_option,attributes) ->
- Format.fprintf fmt "TArray(%a,%a,%a)" pp_typ typ (pp_option pp_exp) exp_option
- pp_attributes attributes
- | TFun(typ,string_typ_attributes_tuple_list_option,bool,attributes) ->
- Format.fprintf fmt "TFun(%a,%a,%a,%a)" pp_typ typ
+and pp_typ fmt t =
+ match t.tnode with
+ | TVoid -> Format.fprintf fmt "TVoid(%a)" pp_attributes t.tattr
+ | TInt ikind -> Format.fprintf fmt "TInt(%a,%a)" pp_ikind ikind pp_attributes t.tattr
+ | TFloat fkind -> Format.fprintf fmt "TFloat(%a,%a)" pp_fkind fkind pp_attributes t.tattr
+ | TPtr typ -> Format.fprintf fmt "TPtr(%a,%a)" pp_typ typ pp_attributes t.tattr
+ | TArray (typ,exp_option) ->
+ Format.fprintf fmt "TArray(%a,%a,%a)" pp_typ typ (pp_option pp_exp) exp_option pp_attributes t.tattr
+ | TFun (typ,string_typ_attributes_tuple_list_option,bool) ->
+ Format.fprintf fmt "TFun(%a,%a,%a,%a)" pp_typ typ
(pp_option (pp_list (pp_tuple3 pp_string pp_typ pp_attributes))) string_typ_attributes_tuple_list_option
- pp_bool bool pp_attributes attributes
- | TNamed(typeinfo,attributes) ->
- Format.fprintf fmt "TNamed(%a,%a)" pp_typeinfo typeinfo pp_attributes attributes
- | TComp(compinfo,attributes) -> Format.fprintf fmt "TComp(%a,%a)" pp_compinfo compinfo pp_attributes attributes
- | TEnum(enuminfo,attributes) -> Format.fprintf fmt "TEnum(%a,%a)" pp_enuminfo enuminfo pp_attributes attributes
- | TBuiltin_va_list(attributes) -> Format.fprintf fmt "TBuiltin_va_list(%a)" pp_attributes attributes
+ pp_bool bool pp_attributes t.tattr
+ | TNamed typeinfo -> Format.fprintf fmt "TNamed(%a,%a)" pp_typeinfo typeinfo pp_attributes t.tattr
+ | TComp compinfo -> Format.fprintf fmt "TComp(%a,%a)" pp_compinfo compinfo pp_attributes t.tattr
+ | TEnum enuminfo -> Format.fprintf fmt "TEnum(%a,%a)" pp_enuminfo enuminfo pp_attributes t.tattr
+ | TBuiltin_va_list -> Format.fprintf fmt "TBuiltin_va_list(%a)" pp_attributes t.tattr
and pp_ikind fmt = function
| IBool -> Format.fprintf fmt "IBool"
diff --git a/src/kernel_services/ast_printing/printer_tag.ml b/src/kernel_services/ast_printing/printer_tag.ml
index bbc921bf6c4..5eec71c9923 100644
--- a/src/kernel_services/ast_printing/printer_tag.ml
+++ b/src/kernel_services/ast_printing/printer_tag.ml
@@ -275,12 +275,13 @@ let declaration_of_global = function
Some(SFunction (Globals.Functions.get vi))
| GAsm _ | GPragma _ | GText _ | GAnnot _ -> None
-let declaration_of_type = function
- | TVoid _ | TInt _ | TFloat _ | TPtr _
- | TArray _ | TFun _ | TBuiltin_va_list _ -> None
- | TNamed(ti, _) -> Some (SType ti)
- | TComp (ci, _) -> Some (SComp ci)
- | TEnum (ei, _) -> Some (SEnum ei)
+let declaration_of_type t =
+ match t.tnode with
+ | TVoid | TInt _ | TFloat _ | TPtr _
+ | TArray _ | TFun _ | TBuiltin_va_list -> None
+ | TNamed ti -> Some (SType ti)
+ | TComp ci -> Some (SComp ci)
+ | TEnum ei -> Some (SEnum ei)
let declaration_of_property ip =
match Property.get_kf ip with
@@ -305,12 +306,13 @@ let declaration_of_localizable = function
| PLval(None,_,_) | PExp(None,_,_)
| PType _ -> None
-let definition_of_type = function
- | TVoid _ | TInt _ | TFloat _ | TPtr _
- | TArray _ | TFun _ | TBuiltin_va_list _ -> None
- | TNamed(ti, _) -> Some (PGlobal(GType(ti,Location.unknown)))
- | TComp (ci, _) -> Some (PGlobal(GCompTag(ci,Location.unknown)))
- | TEnum (ei, _) -> Some (PGlobal(GEnumTag(ei,Location.unknown)))
+let definition_of_type t =
+ match t.tnode with
+ | TVoid | TInt _ | TFloat _ | TPtr _
+ | TArray _ | TFun _ | TBuiltin_va_list -> None
+ | TNamed ti -> Some (PGlobal(GType(ti,Location.unknown)))
+ | TComp ci -> Some (PGlobal(GCompTag(ci,Location.unknown)))
+ | TEnum ei -> Some (PGlobal(GEnumTag(ei,Location.unknown)))
let definition_of_localizable = function
| PLval(kf,ki,(Var vi,NoOffset))
@@ -332,12 +334,13 @@ let name_of_declaration = function
| SGlobal vi -> vi.vname
| SFunction kf -> Kernel_function.get_name kf
-let name_of_type = function
- | TVoid _ | TInt _ | TFloat _ | TPtr _
- | TArray _ | TFun _ | TBuiltin_va_list _ -> None
- | TNamed(ti, _) -> Some ti.tname
- | TComp (ci, _) -> Some ci.cname
- | TEnum (ei, _) -> Some ei.ename
+let name_of_type t =
+ match t.tnode with
+ | TVoid | TInt _ | TFloat _ | TPtr _
+ | TArray _ | TFun _ | TBuiltin_va_list -> None
+ | TNamed ti -> Some ti.tname
+ | TComp ci -> Some ci.cname
+ | TEnum ei -> Some ei.ename
let name_of_global g =
Option.map name_of_declaration @@ declaration_of_global g
@@ -440,9 +443,9 @@ let localizable_of_global g =
let localizable_of_declaration = function
| SFunction kf -> localizable_of_kf kf
| SGlobal vi -> PVDecl(None,Kglobal,vi)
- | SComp ci -> PType(TComp(ci,[]))
- | SEnum ei -> PType(TEnum(ei,[]))
- | SType ti -> PType(TNamed(ti,[]))
+ | SComp ci -> PType(Cil_const.mk_tcomp ci)
+ | SEnum ei -> PType(Cil_const.mk_tenum ei)
+ | SType ti -> PType(Cil_const.mk_tnamed ti)
(* -------------------------------------------------------------------------- *)
(* --- Find localizable at a Filepath.position --- *)
diff --git a/src/kernel_services/ast_queries/ast_diff.ml b/src/kernel_services/ast_queries/ast_diff.ml
index abbdd84292d..a95e0cb6e82 100644
--- a/src/kernel_services/ast_queries/ast_diff.ml
+++ b/src/kernel_services/ast_queries/ast_diff.ml
@@ -350,7 +350,7 @@ let find_candidate_compinfo ?loc:_loc ci =
let su = if ci.cstruct then Logic_typing.Struct else Logic_typing.Union in
if Globals.Types.mem_type su ci.cname then begin
match Globals.Types.find_type su ci.cname with
- | TComp(ci', _) -> Some ci'
+ | { tnode = TComp ci' } -> Some ci'
| t ->
Kernel.fatal
"Expected compinfo instead of %a"
@@ -360,7 +360,7 @@ let find_candidate_compinfo ?loc:_loc ci =
let find_candidate_enuminfo ?loc:_loc ei =
if Globals.Types.mem_type Logic_typing.Enum ei.ename then begin
match Globals.Types.find_type Logic_typing.Enum ei.ename with
- | TEnum(ei,_) -> Some ei
+ | { tnode = TEnum ei } -> Some ei
| t ->
Kernel.fatal
"Expected enuminfo instead of %a"
@@ -830,44 +830,44 @@ and is_same_model_info mi mi' env =
Cil_datatype.Attributes.equal mi.mi_attr mi'.mi_attr
and is_same_type t t' env =
- match t, t' with
- | TVoid a, TVoid a' -> Cil_datatype.Attributes.equal a a'
- | TInt (ik,a), TInt(ik',a') ->
- equal_ikind ik ik' && Cil_datatype.Attributes.equal a a'
- | TFloat (fk,a), TFloat(fk', a') ->
- equal_fkind fk fk' && Cil_datatype.Attributes.equal a a'
- | TBuiltin_va_list a, TBuiltin_va_list a' ->
- Cil_datatype.Attributes.equal a a'
- | TPtr(t,a), TPtr(t',a') ->
- is_same_type t t' env && Cil_datatype.Attributes.equal a a'
- | TArray(t,s,a), TArray(t',s',a') ->
- is_same_type t t' env &&
+ let is_same_tattr () = Cil_datatype.Attributes.equal t.tattr t'.tattr in
+ match t.tnode, t'.tnode with
+ | TVoid, TVoid -> is_same_tattr ()
+ | TInt ik, TInt ik' ->
+ equal_ikind ik ik' && is_same_tattr ()
+ | TFloat fk, TFloat fk' ->
+ equal_fkind fk fk' && is_same_tattr ()
+ | TBuiltin_va_list, TBuiltin_va_list -> is_same_tattr ()
+ | TPtr bt, TPtr bt' ->
+ is_same_type bt bt' env && is_same_tattr ()
+ | TArray (bt, s), TArray (bt', s') ->
+ is_same_type bt bt' env &&
is_same_opt is_same_exp s s' env &&
- Cil_datatype.Attributes.equal a a'
- | TFun(rt,l,var,a), TFun(rt', l', var', a') ->
+ is_same_tattr ()
+ | TFun (rt, l, var), TFun(rt', l', var') ->
is_same_type rt rt' env &&
is_same_opt (is_same_list is_same_formal) l l' env &&
(var = var') &&
- Cil_datatype.Attributes.equal a a'
- | TNamed(t,a), TNamed(t',a') ->
- let correspondence = typeinfo_correspondence t env in
+ is_same_tattr ()
+ | TNamed ti, TNamed ti' ->
+ let correspondence = typeinfo_correspondence ti env in
(match correspondence with
| `Not_present -> false
- | `Same t'' -> Cil_datatype.Typeinfo.equal t' t'') &&
- Cil_datatype.Attributes.equal a a'
- | TComp(c,a), TComp(c', a') ->
- let correspondence = compinfo_correspondence c env in
+ | `Same ti'' -> Cil_datatype.Typeinfo.equal ti' ti'') &&
+ is_same_tattr ()
+ | TComp ci, TComp ci' ->
+ let correspondence = compinfo_correspondence ci env in
(match correspondence with
| `Not_present -> false
- | `Same c'' -> Cil_datatype.Compinfo.equal c' c'') &&
- Cil_datatype.Attributes.equal a a'
- | TEnum(e,a), TEnum(e',a') ->
- let correspondence = enuminfo_correspondence e env in
+ | `Same ci'' -> Cil_datatype.Compinfo.equal ci' ci'') &&
+ is_same_tattr ()
+ | TEnum ei, TEnum ei' ->
+ let correspondence = enuminfo_correspondence ei env in
(match correspondence with
| `Not_present -> false
- | `Same e'' -> Cil_datatype.Enuminfo.equal e' e'') &&
- Cil_datatype.Attributes.equal a a'
- | (TVoid _ | TInt _ | TFloat _ | TBuiltin_va_list _ | TPtr _ | TArray _
+ | `Same ei'' -> Cil_datatype.Enuminfo.equal ei' ei'') &&
+ is_same_tattr ()
+ | (TVoid | TInt _ | TFloat _ | TBuiltin_va_list | TPtr _ | TArray _
| TFun _ | TNamed _ | TComp _ | TEnum _), _ -> false
and is_same_compinfo ci ci' env =
diff --git a/src/kernel_services/ast_queries/ast_info.ml b/src/kernel_services/ast_queries/ast_info.ml
index 2e84fc40db5..936c056eb29 100644
--- a/src/kernel_services/ast_queries/ast_info.ml
+++ b/src/kernel_services/ast_queries/ast_info.ml
@@ -334,8 +334,8 @@ let is_function_type vi = isFunctionType vi.vtype
module Function = struct
- let formal_args called_vinfo = match called_vinfo.vtype with
- | TFun (_,Some argl,_,_) ->
+ let formal_args called_vinfo = match called_vinfo.vtype.tnode with
+ | TFun (_,Some argl,_) ->
argl
| TFun _ ->
[]
@@ -421,45 +421,44 @@ let block_of_local (fdec:fundec) vi =
(** {2 Types} *)
(* ************************************************************************** *)
-let array_type ?length ?(attr=[]) ty = TArray(ty,length,attr)
-
let direct_array_size ty =
- match unrollType ty with
- | TArray(_ty,Some size,_) -> value_of_integral_expr size
- | TArray(_ty,None,_) -> Integer.zero
+ match unrollTypeNode ty with
+ | TArray(_ty,Some size) -> value_of_integral_expr size
+ | TArray(_ty,None) -> Integer.zero
| _ -> assert false
let rec array_size ty =
- match unrollType ty with
- | TArray(elemty,Some _,_) ->
+ match unrollTypeNode ty with
+ | TArray(elemty,Some _) ->
if isArrayType elemty then
Integer.mul (direct_array_size ty) (array_size elemty)
else direct_array_size ty
- | TArray(_,None,_) -> Integer.zero
+ | TArray(_,None) -> Integer.zero
| _ -> assert false
-let direct_element_type ty = match unrollType ty with
- | TArray(eltyp,_,_) -> eltyp
+let direct_element_type ty = match unrollTypeNode ty with
+ | TArray(eltyp,_) -> eltyp
| _ -> assert false
let element_type ty =
- let rec elem_type ty = match unrollType ty with
- | TArray(eltyp,_,_) -> elem_type eltyp
+ let rec elem_type ty = match unrollTypeNode ty with
+ | TArray(eltyp,_) -> elem_type eltyp
| _ -> ty
in
- match unrollType ty with
- | TArray(eltyp,_,_) -> elem_type eltyp
+ match unrollTypeNode ty with
+ | TArray (eltyp,_) -> elem_type eltyp
| _ -> assert false
let direct_pointed_type ty =
- match unrollType ty with
- | TPtr(elemty,_) -> elemty
+ match unrollTypeNode ty with
+ | TPtr elemty -> elemty
| _ -> assert false
let pointed_type ty =
- match unrollType (direct_pointed_type ty) with
- | TArray _ as arrty -> element_type arrty
- | ty -> ty
+ let ty' = unrollType (direct_pointed_type ty) in
+ match ty'.tnode with
+ | TArray _ -> element_type ty'
+ | _ -> ty'
(* ************************************************************************** *)
(** {2 Predefined} *)
@@ -496,6 +495,9 @@ let () = Cil_builtins.add_special_builtin_family start_with_frama_c_builtin
let is_frama_c_builtin v =
Cil_builtins.has_fc_builtin_attr v || start_with_frama_c_builtin v.vname
+let array_type ?length ?(attr=[]) ty =
+ Cil_const.mk_tarray ~tattr:attr ty length
+
(*
Local Variables:
diff --git a/src/kernel_services/ast_queries/ast_info.mli b/src/kernel_services/ast_queries/ast_info.mli
index a21e023dc80..dd108a214f5 100644
--- a/src/kernel_services/ast_queries/ast_info.mli
+++ b/src/kernel_services/ast_queries/ast_info.mli
@@ -196,8 +196,6 @@ val block_of_local: fundec -> varinfo -> block
(** {2 Types} *)
(* ************************************************************************** *)
-val array_type: ?length:exp -> ?attr:attributes -> typ -> typ
-
val direct_array_size: typ -> Integer.t
val array_size: typ -> Integer.t
val direct_element_type: typ -> typ
@@ -281,6 +279,10 @@ val is_frama_c_builtin: varinfo -> bool
@before 29.0-Copper Behave like {!start_with_frama_c_builtin}.
*)
+val array_type: ?length:exp -> ?attr:attributes -> typ -> typ
+(** @deprecated Frama-C+dev *)
+[@@alert deprecated "Use Cil_const.mk_tarray instead."]
+
(*
Local Variables:
compile-command: "make -C ../../.."
diff --git a/src/kernel_services/ast_queries/cil.ml b/src/kernel_services/ast_queries/cil.ml
index b4482d7194f..afb9866d196 100644
--- a/src/kernel_services/ast_queries/cil.ml
+++ b/src/kernel_services/ast_queries/cil.ml
@@ -213,42 +213,18 @@ let findAttribute (an: string) (al: attribute list) : attrparam list =
| _ -> acc)
[] al
-let rec typeAttrs = function
- TVoid a -> a
- | TInt (_, a) -> a
- | TFloat (_, a) -> a
- | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype)
- | TPtr (_, a) -> a
- | TArray (_, _,a) -> a
- | TComp (comp, a) -> addAttributes comp.cattr a
- | TEnum (enum, a) -> addAttributes enum.eattr a
- | TFun (_, _, _, a) -> a
- | TBuiltin_va_list a -> a
-
-let typeAttr = function
- | TVoid a
- | TInt (_, a)
- | TFloat (_, a)
- | TNamed (_, a)
- | TPtr (_, a)
- | TArray (_, _, a)
- | TComp (_, a)
- | TEnum (_, a)
- | TFun (_, _, _, a)
- | TBuiltin_va_list a -> a
-
-let setTypeAttrs t a =
- match t with
- TVoid _ -> TVoid a
- | TInt (i, _) -> TInt (i, a)
- | TFloat (f, _) -> TFloat (f, a)
- | TNamed (t, _) -> TNamed(t, a)
- | TPtr (t', _) -> TPtr(t', a)
- | TArray (t', l, _) -> TArray(t', l, a)
- | TComp (comp, _) -> TComp (comp, a)
- | TEnum (enum, _) -> TEnum (enum, a)
- | TFun (r, args, v, _) -> TFun(r,args,v,a)
- | TBuiltin_va_list _ -> TBuiltin_va_list a
+let rec typeAttrs { tnode; tattr } =
+ match tnode with
+ | TVoid -> tattr
+ | TInt _ -> tattr
+ | TFloat _ -> tattr
+ | TNamed t -> addAttributes tattr (typeAttrs t.ttype)
+ | TPtr _ -> tattr
+ | TArray _ -> tattr
+ | TComp comp -> addAttributes comp.cattr tattr
+ | TEnum enum -> addAttributes enum.eattr tattr
+ | TFun _ -> tattr
+ | TBuiltin_va_list -> tattr
let qualifier_attributes = [ "const"; "restrict"; "volatile"; "ghost" ]
@@ -273,57 +249,61 @@ let rec typeAddAttributes ?(combine=addAttributes) a0 t =
| _ ->
(* anything else: add a0 to existing attributes *)
let add (a: attributes) = combine a0 a in
- match t with
- TVoid a -> TVoid (add a)
- | TInt (ik, a) -> TInt (ik, add a)
- | TFloat (fk, a) -> TFloat (fk, add a)
- | TEnum (enum, a) -> TEnum (enum, add a)
- | TPtr (t, a) -> TPtr (t, add a)
- | TArray (t, l, a) ->
+ match t.tnode with
+ | TVoid
+ | TInt _
+ | TFloat _
+ | TEnum _
+ | TPtr _
+ | TFun _
+ | TComp _
+ | TNamed _
+ | TBuiltin_va_list -> {t with tattr = add t.tattr}
+ | TArray (bt, l) ->
let att_elt, att_typ = splitArrayAttributes a0 in
- TArray (arrayPushAttributes att_elt t, l,
- addAttributes att_typ a)
- | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
- | TComp (comp, a) -> TComp (comp, add a)
- | TNamed (t, a) -> TNamed (t, add a)
- | TBuiltin_va_list a -> TBuiltin_va_list (add a)
+ let bt' = arrayPushAttributes att_elt bt in
+ let tattr = addAttributes att_typ t.tattr in
+ Cil_const.mk_tarray ~tattr bt' l
end
(* Push attributes that belong to the type of the elements of the array as
far as possible *)
-and arrayPushAttributes al = function
- | TArray (bt, l, a) ->
- TArray (arrayPushAttributes al bt, l, a)
- | t -> typeAddAttributes al t
+and arrayPushAttributes al t =
+ match t.tnode with
+ | TArray (bt, l) ->
+ let bt' = arrayPushAttributes al bt in
+ Cil_const.mk_tarray ~tattr:t.tattr bt' l
+ | _ -> typeAddAttributes al t
(**** Look for the presence of an attribute in a type ****)
let typeHasAttribute attr typ = hasAttribute attr (typeAttrs typ)
-let rec typeHasQualifier attr typ =
- match typ with
- | TNamed (t, a) ->
- hasAttribute attr a || typeHasQualifier attr t.ttype
- | TArray (t, _, a) ->
- typeHasQualifier attr t || (* ill-formed type *) hasAttribute attr a
- | _ -> hasAttribute attr (typeAttrs typ)
+let rec typeHasQualifier attr t =
+ match t.tnode with
+ | TNamed ti ->
+ hasAttribute attr t.tattr || typeHasQualifier attr ti.ttype
+ | TArray (bt, _) ->
+ typeHasQualifier attr bt || (* ill-formed type *) hasAttribute attr t.tattr
+ | _ -> hasAttribute attr (typeAttrs t)
let typeHasAttributeMemoryBlock a (ty:typ): bool =
let f attrs = if hasAttribute a attrs then raise Exit in
let rec visit (t: typ) : unit =
- match t with
- | TNamed (r, a') -> f a' ; visit r.ttype
- | TArray(t, _, a') -> f a'; visit t
- | TComp (comp, a') -> f a';
+ f t.tattr;
+ match t.tnode with
+ | TNamed r -> visit r.ttype
+ | TArray (bt, _) -> visit bt
+ | TComp comp ->
List.iter
(fun fi -> f fi.fattr; visit fi.ftype)
(Option.value ~default:[] comp.cfields)
- | TVoid a'
- | TInt (_, a')
- | TFloat (_, a')
- | TEnum (_, a')
- | TFun (_, _, _, a')
- | TBuiltin_va_list a'
- | TPtr(_, a') -> f a'
+ | TVoid
+ | TInt _
+ | TFloat _
+ | TEnum _
+ | TFun _
+ | TBuiltin_va_list
+ | TPtr _ -> ()
in
try visit ty; false
with Exit -> true
@@ -337,26 +317,31 @@ let typeAddGhost typ =
let rec typeRemoveAttributes ?anl t =
(* Try to preserve sharing. We use sharing to be more efficient, but also
to detect that we have removed an attribute under typedefs *)
- let new_attr al =
- match anl with None -> [] | Some anl -> dropAttributes anl al
+ let tattr =
+ match anl with
+ | None -> []
+ | Some anl -> dropAttributes anl t.tattr
in
- let reshare al f =
- let al' = new_attr al in if al' == al then t else f al'
+ let reshare () =
+ if tattr == t.tattr
+ then t
+ else Cil_const.mk_typ ~tattr t.tnode
in
- match t with
- | TVoid a -> reshare a (fun a -> TVoid a)
- | TInt (ik, a) -> reshare a (fun a -> TInt (ik, a))
- | TFloat (fk, a) -> reshare a (fun a -> TFloat (fk, a))
- | TEnum (enum, a) -> reshare a (fun a -> TEnum (enum, a))
- | TPtr (t, a) -> reshare a (fun a -> TPtr (t, a))
- | TArray (t, l, a) -> reshare a (fun a -> TArray (t, l, a))
- | TFun (t, args, isva, a) -> reshare a (fun a -> TFun(t, args, isva, a))
- | TComp (comp, a) -> reshare a (fun a -> TComp (comp, a))
- | TBuiltin_va_list a -> reshare a (fun a -> TBuiltin_va_list a)
- | TNamed (tn, a) ->
- let tn' = typeRemoveAttributes ?anl tn.ttype in
- if tn' == tn.ttype then reshare a (fun a -> TNamed (tn, a))
- else typeAddAttributes (new_attr a) tn'
+ match t.tnode with
+ | TVoid
+ | TInt _
+ | TFloat _
+ | TEnum _
+ | TPtr _
+ | TArray _
+ | TFun _
+ | TComp _
+ | TBuiltin_va_list -> reshare ()
+ | TNamed ti ->
+ let tt = typeRemoveAttributes ?anl ti.ttype in
+ if tt == ti.ttype
+ then reshare ()
+ else typeAddAttributes tattr tt
let typeRemoveAllAttributes t = typeRemoveAttributes t
@@ -365,32 +350,35 @@ let typeRemoveAttributes anl t = typeRemoveAttributes ~anl t
let rec typeRemoveAttributesDeep (anl: string list) t =
(* Try to preserve sharing. We use sharing to be more efficient, but also
to detect that we have removed an attribute under typedefs *)
- let reshare al f =
- let al' = dropAttributes anl al in
- if al' == al then t else f al'
+ let reshare () =
+ let tattr = dropAttributes anl t.tattr in
+ if tattr == t.tattr
+ then t
+ else Cil_const.mk_typ ~tattr t.tnode
in
- match t with
- | TVoid a -> reshare a (fun a -> TVoid a)
- | TInt (ik, a) -> reshare a (fun a -> TInt (ik, a))
- | TFloat (fk, a) -> reshare a (fun a -> TFloat (fk, a))
- | TEnum (enum, a) -> reshare a (fun a -> TEnum (enum, a))
- | TPtr (t, a) ->
+ match t.tnode with
+ | TVoid -> reshare ()
+ | TInt _ -> reshare ()
+ | TFloat _ -> reshare ()
+ | TEnum _ -> reshare ()
+ | TPtr t ->
let t' = typeRemoveAttributesDeep anl t in
- if t != t' then TPtr(t', dropAttributes anl a)
- else reshare a (fun a -> TPtr(t,a))
- | TArray (t, l, a) ->
+ if t != t'
+ then Cil_const.mk_tptr ~tattr:(dropAttributes anl t.tattr) t'
+ else reshare ()
+ | TArray (t, l) ->
let t' = typeRemoveAttributesDeep anl t in
- if t!=t' then TArray(t', l, dropAttributes anl a)
- else reshare a (fun a -> TArray (t, l, a))
- | TFun (t, args, isva, a) -> reshare a (fun a -> TFun(t, args, isva, a))
- | TComp (comp, a) -> reshare a (fun a -> TComp (comp, a))
- | TBuiltin_va_list a -> reshare a (fun a -> TBuiltin_va_list a)
- | TNamed (tn, a) ->
- let tn' = typeRemoveAttributesDeep anl tn.ttype in
- if tn' == tn.ttype then
- reshare a (fun a -> TNamed (tn, a))
- else
- typeAddAttributes (dropAttributes anl a) tn'
+ if t != t'
+ then Cil_const.mk_tarray ~tattr:(dropAttributes anl t.tattr) t' l
+ else reshare ()
+ | TFun _ -> reshare ()
+ | TComp _ -> reshare ()
+ | TBuiltin_va_list -> reshare ()
+ | TNamed ti ->
+ let tt = typeRemoveAttributesDeep anl ti.ttype in
+ if tt == ti.ttype
+ then reshare ()
+ else typeAddAttributes (dropAttributes anl t.tattr) tt
let type_remove_qualifier_attributes =
typeRemoveAttributes qualifier_attributes
@@ -516,19 +504,50 @@ let () =
let unrollType (t: typ) : typ =
let rec withAttrs (al: attributes) (t: typ) : typ =
- match t with
- TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
- | x -> typeAddAttributes al x
+ match t.tnode with
+ | TNamed ti -> withAttrs (addAttributes al t.tattr) ti.ttype
+ | _ -> typeAddAttributes al t
in
withAttrs [] t
+let unrollTypeNode (t: typ) : typ_node =
+ (unrollType t).tnode
+
let () = punrollType := unrollType
(* Unroll typedefs, discarding all intermediate attribute. To be used only
- when one is interested in the shape of the type *)
-let rec unrollTypeSkel = function
- | TNamed (r, _) -> unrollTypeSkel r.ttype
- | x -> x
+ when one is interested in the shape of the type node *)
+let rec unrollTypeSkel (t : typ) : typ_node =
+ match t.tnode with
+ | TNamed ti -> unrollTypeSkel ti.ttype
+ | _ -> t.tnode
+
+let rec unrollTypeDeep (t: typ) : typ =
+ let rec withAttrs (al: attributes) (t: typ) : typ =
+ match t.tnode with
+ | TNamed r -> withAttrs (addAttributes al t.tattr) r.ttype
+ | TPtr bt ->
+ let bt' = unrollTypeDeep bt in
+ let tattr = addAttributes al t.tattr in
+ Cil_const.mk_tptr ~tattr bt'
+ | TArray (bt, l) ->
+ let att_elt, att_typ = splitArrayAttributes al in
+ let bt' = arrayPushAttributes att_elt (unrollTypeDeep bt) in
+ let tattr = addAttributes att_typ t.tattr in
+ Cil_const.mk_tarray ~tattr bt' l
+ | TFun (rt, args, isva) ->
+ let rt' = unrollTypeDeep rt in
+ let args' =
+ match args with
+ | None -> None
+ | Some argl ->
+ Some (List.map (fun (an, at, aa) -> (an, unrollTypeDeep at, aa)) argl)
+ in
+ let tattr = addAttributes al t.tattr in
+ Cil_const.mk_tfun ~tattr rt' args' isva
+ | _ -> typeAddAttributes al t
+ in
+ withAttrs [] t
let is_ghost_else block =
hasAttribute frama_c_ghost_else block.battrs
@@ -617,8 +636,8 @@ let isGhostFormalVarDecl (_name, _type, attr) =
hasAttribute frama_c_ghost_formal attr
let setFormalsDecl vi typ =
- match unrollType typ with
- | TFun(_, Some args, _, _) ->
+ match unrollTypeSkel typ with
+ | TFun (_, Some args, _) ->
let is_ghost d = vi.vghost || isGhostFormalVarDecl d in
let makeFormalsVarDecl i (n,t,a as x) =
let x = if n = "" then begin
@@ -630,7 +649,7 @@ let setFormalsDecl vi typ =
makeFormalsVarDecl ~ghost:(is_ghost x) x
in
FormalsDecl.replace vi (List.mapi makeFormalsVarDecl args)
- | TFun(_,None,_,_) -> ()
+ | TFun (_, None, _) -> ()
| _ ->
Kernel.error ~current:true
"trying to assigns formal parameters to an object \
@@ -652,11 +671,10 @@ let setFormals (f: fundec) (forms: varinfo list) =
List.iter (fun v -> v.vformal <- true) forms;
f.sformals <- forms; (* Set the formals *)
match unrollType f.svar.vtype with
- TFun(rt, _, isva, fa) ->
- update_var_type f.svar
- (TFun(rt,
- Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms),
- isva, fa));
+ | { tnode = TFun (rt, _, isva); tattr } ->
+ let args = Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms) in
+ let t' = Cil_const.mk_tfun ~tattr rt args isva in
+ update_var_type f.svar t'
| _ ->
Kernel.fatal "Set formals. %s does not have function type" f.svar.vname
@@ -2393,29 +2411,34 @@ and childrenType (vis : cilVisitor) (t : typ) : typ =
(* look for types referred to inside t's definition *)
let fTyp t = visitCilType vis t in
let fAttr a = visitCilAttributes vis a in
- match t with
- TPtr(t1, a) ->
+ let tattr = visitCilAttributes vis t.tattr in
+ match t.tnode with
+ | TPtr t1 ->
let t1' = fTyp t1 in
- let a' = fAttr a in
- if t1' != t1 || a' != a then TPtr(t1', a') else t
- | TArray(t1, None, a) ->
+ if t1' != t1 || tattr != t.tattr
+ then Cil_const.mk_tptr ~tattr t1'
+ else t
+ | TArray (t1, None) ->
let t1' = fTyp t1 in
- let a' = fAttr a in
- if t1' != t1 || a' != a then TArray(t1', None, a') else t
- | TArray(t1, Some e, a) ->
+ if t1' != t1 || tattr != t.tattr
+ then Cil_const.mk_tarray ~tattr t1' None
+ else t
+ | TArray(t1, Some e) ->
let t1' = fTyp t1 in
let e' = visitCilExpr vis e in
- let a' = fAttr a in
- if t1' != t1 || e' != e || a' != a then TArray(t1', Some e',a') else t
+ if t1' != t1 || e' != e || tattr != t.tattr
+ then Cil_const.mk_tarray ~tattr t1' (Some e')
+ else t
(* DON'T recurse into the compinfo, this is done in visitCilGlobal.
User can iterate over cinfo.cfields manually, if desired.*)
- | TComp(cinfo, a) ->
+ | TComp cinfo ->
let cinfo' = Visitor_behavior.Get.compinfo vis#behavior cinfo in
- let a' = fAttr a in
- if a != a' || cinfo' != cinfo then TComp(cinfo',a') else t
+ if tattr != t.tattr || cinfo' != cinfo
+ then Cil_const.mk_tcomp ~tattr cinfo'
+ else t
- | TFun(rettype, args, isva, a) ->
+ | TFun (rettype, args, isva) ->
let rettype' = fTyp rettype in
(* iterate over formals, as variable declarations *)
let argslist = argsToList args in
@@ -2425,24 +2448,24 @@ and childrenType (vis : cilVisitor) (t : typ) : typ =
if at' != at || aa' != aa then (an,at',aa') else arg
in
let argslist' = Extlib.map_no_copy visitArg argslist in
- let a' = fAttr a in
- if rettype' != rettype || argslist' != argslist || a' != a then
+ if rettype' != rettype || argslist' != argslist || tattr != t.tattr then
let args' = if argslist' == argslist then args else Some argslist' in
- TFun(rettype', args', isva, a') else t
+ Cil_const.mk_tfun ~tattr rettype' args' isva
+ else t
- | TNamed(t1, a) ->
- let a' = fAttr a in
+ | TNamed t1 ->
let t1' = Visitor_behavior.Get.typeinfo vis#behavior t1 in
- if a' != a || t1' != t1 then TNamed (t1', a') else t
- | TEnum(enum,a) ->
- let a' = fAttr a in
+ if tattr != t.tattr || t1' != t1
+ then Cil_const.mk_tnamed ~tattr t1'
+ else t
+ | TEnum enum ->
let enum' = Visitor_behavior.Get.enuminfo vis#behavior enum in
- if a' != a || enum' != enum then TEnum(enum',a') else t
- | TVoid _ | TInt _ | TFloat _ | TBuiltin_va_list _ ->
+ if tattr != t.tattr || enum' != enum
+ then Cil_const.mk_tenum ~tattr enum'
+ else t
+ | TVoid | TInt _ | TFloat _ | TBuiltin_va_list ->
(* no nested type. visit only the attributes. *)
- let a = typeAttrs t in
- let a' = fAttr a in
- if a' != a then setTypeAttrs t a' else t
+ if tattr != t.tattr then {t with tattr} else t
(* for declarations, we visit the types inside; but for uses, *)
(* we just visit the varinfo node *)
@@ -2752,12 +2775,12 @@ let intKindForSize (s:int) (unsigned:bool) : ikind =
else if s = sizeof_longlong () then ILongLong
else raise Not_found
-let uint64_t () = TInt(intKindForSize 8 true,[])
-let uint32_t () = TInt(intKindForSize 4 true,[])
-let uint16_t () = TInt(intKindForSize 2 true,[])
-let int64_t () = TInt(intKindForSize 8 false,[])
-let int32_t () = TInt(intKindForSize 4 false,[])
-let int16_t () = TInt(intKindForSize 2 false,[])
+let uint64_t () = Cil_const.mk_tint (intKindForSize 8 true)
+let uint32_t () = Cil_const.mk_tint (intKindForSize 4 true)
+let uint16_t () = Cil_const.mk_tint (intKindForSize 2 true)
+let int64_t () = Cil_const.mk_tint (intKindForSize 8 false)
+let int32_t () = Cil_const.mk_tint (intKindForSize 4 false)
+let int16_t () = Cil_const.mk_tint (intKindForSize 2 false)
let floatKindForSize (s:int) =
if s = sizeof_double () then FDouble
@@ -3136,36 +3159,14 @@ let mkStmtOneInstr ?ghost ?valid_sid ?sattr i =
let dummyInstr = Asm([], ["dummy statement!!"], None, Location.unknown)
let dummyStmt = mkStmt (Instr dummyInstr)
-let rec unrollTypeDeep (t: typ) : typ =
- let rec withAttrs (al: attributes) (t: typ) : typ =
- match t with
- TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
- | TPtr(t, a') -> TPtr(unrollTypeDeep t, addAttributes al a')
- | TArray(t, l, a') ->
- let att_elt, att_typ = splitArrayAttributes al in
- TArray(arrayPushAttributes att_elt (unrollTypeDeep t), l,
- addAttributes att_typ a')
- | TFun(rt, args, isva, a') ->
- TFun (unrollTypeDeep rt,
- (match args with
- None -> None
- | Some argl ->
- Some (List.map (fun (an,at,aa) ->
- (an, unrollTypeDeep at, aa)) argl)),
- isva,
- addAttributes al a')
- | x -> typeAddAttributes al x
- in
- withAttrs [] t
-
let isSignedInteger ty =
match unrollTypeSkel ty with
- | TInt(ik,_) | TEnum ({ekind=ik},_) -> isSigned ik
+ | TInt ik | TEnum {ekind=ik} -> isSigned ik
| _ -> false
let isUnsignedInteger ty =
match unrollTypeSkel ty with
- | TInt(ik,_) | TEnum ({ekind=ik},_) -> not (isSigned ik)
+ | TInt ik | TEnum {ekind=ik} -> not (isSigned ik)
| _ -> false
let var vi : lval = (Var vi, NoOffset)
@@ -3258,47 +3259,48 @@ let separateStorageModifiers (al: attribute list) =
let isVoidType t =
match unrollTypeSkel t with
- TVoid _ -> true
+ | TVoid -> true
| _ -> false
let isVoidPtrType t =
match unrollTypeSkel t with
- TPtr(tau,_) when isVoidType tau -> true
+ | TPtr tau when isVoidType tau -> true
| _ -> false
let isAnyCharType t =
match unrollTypeSkel t with
- | TInt((IChar|ISChar|IUChar),_) -> true
+ | TInt (IChar | ISChar | IUChar) -> true
| _ -> false
let isCharType t =
match unrollTypeSkel t with
- | TInt(IChar,_) -> true
+ | TInt IChar -> true
| _ -> false
let isShortType t =
match unrollTypeSkel t with
- | TInt((IUShort|IShort),_) -> true
+ | TInt (IUShort | IShort) -> true
| _ -> false
let isAnyCharPtrType t =
match unrollTypeSkel t with
- TPtr(tau,_) when isAnyCharType tau -> true
+ | TPtr tau when isAnyCharType tau -> true
| _ -> false
let isCharPtrType t =
match unrollTypeSkel t with
- TPtr(tau,_) when isCharType tau -> true
+ | TPtr tau when isCharType tau -> true
| _ -> false
let isCharConstPtrType t =
- match unrollTypeSkel t with
- TPtr(tau,attrs) when isCharType tau -> hasAttribute "const" attrs
+ match unrollType t with
+ | { tnode = TPtr tau; tattr } when isCharType tau ->
+ hasAttribute "const" tattr
| _ -> false
let isIntegralType t =
match unrollTypeSkel t with
- (TInt _ | TEnum _) -> true
+ | (TInt _ | TEnum _) -> true
| _ -> false
let isIntegralOrPointerType t =
@@ -3308,14 +3310,16 @@ let isIntegralOrPointerType t =
(* Don't completely unroll here, as we do not want to identify
intptr_t with its supporting integer type. *)
-let rec is_intptr_t = function
- | TNamed(t,_) ->
- t.tname = "intptr_t" || is_intptr_t t.ttype
+let rec is_intptr_t t =
+ match t.tnode with
+ | TNamed ti ->
+ ti.tname = "intptr_t" || is_intptr_t ti.ttype
| _ -> false
-let rec is_uintptr_t = function
- | TNamed (t,_) ->
- t.tname = "uintptr_t" || is_uintptr_t t.ttype
+let rec is_uintptr_t t =
+ match t.tnode with
+ | TNamed ti ->
+ ti.tname = "uintptr_t" || is_uintptr_t ti.ttype
| _ -> false
let rec isLogicBooleanType t =
@@ -3326,8 +3330,9 @@ let rec isLogicBooleanType t =
( is_unrollable_ltdef tdef && isLogicBooleanType (unroll_ltdef t))
| Lreal | Lvar _ | Larrow _ -> false
-let isBoolType typ = match unrollType typ with
- | TInt (IBool, _) -> true
+let isBoolType typ =
+ match unrollTypeSkel typ with
+ | TInt IBool -> true
| _ -> false
let rec isLogicPureBooleanType t =
@@ -3350,7 +3355,7 @@ let rec isLogicIntegralType t =
let isFloatingType t =
match unrollTypeSkel t with
- TFloat _ -> true
+ | TFloat _ -> true
| _ -> false
let isLogicFloatType t =
@@ -3384,12 +3389,12 @@ let rec isLogicRealType t =
(* ISO 6.2.5.18 *)
let isArithmeticType t =
match unrollTypeSkel t with
- (TInt _ | TEnum _ | TFloat _) -> true
+ | (TInt _ | TEnum _ | TFloat _) -> true
| _ -> false
let isLongDoubleType t =
match unrollTypeSkel t with
- | TFloat(FLongDouble,_) -> true
+ | TFloat FLongDouble -> true
| _ -> false
let rec isLogicArithmeticType t =
@@ -3413,7 +3418,7 @@ let isLogicFunctionType t = Logic_const.isLogicCType isFunctionType t
let isFunPtrType t =
match unrollTypeSkel t with
- | TPtr (t,_) -> isFunctionType t
+ | TPtr t -> isFunctionType t
| _ -> false
let isLogicFunPtrType t = Logic_const.isLogicCType isFunPtrType t
@@ -3431,8 +3436,8 @@ let isScalarType t = isArithmeticType t || isPointerType t
(* Check if a type is a transparent union, and return the first field if it
* is *)
let isTransparentUnion (t: typ) : fieldinfo option =
- match unrollType t with
- | TComp (comp, _) when not comp.cstruct ->
+ match unrollTypeSkel t with
+ | TComp comp when not comp.cstruct ->
(* Turn transparent unions into the type of their first field *)
if typeHasAttribute "transparent_union" t then begin
match comp.cfields with
@@ -3451,32 +3456,33 @@ let rec isTypeTagType t =
| _ -> false
let getReturnType t =
- match unrollType t with
- | TFun(rt,_,_,_) -> rt
+ match unrollTypeSkel t with
+ | TFun(rt, _, _) -> rt
| _ -> Kernel.fatal "getReturnType: not a function type"
let setReturnTypeVI (v: varinfo) (t: typ) =
match unrollType v.vtype with
- | TFun (_, args, va, a) ->
- update_var_type v (TFun (t, args, va, a));
+ | { tnode = TFun (_, args, va); tattr } ->
+ let t' = Cil_const.mk_tfun ~tattr t args va in
+ update_var_type v t'
| _ -> Kernel.fatal "setReturnType: not a function type"
let setReturnType (f:fundec) (t:typ) =
setReturnTypeVI f.svar t
let typeOf_pointed typ =
- match unrollType typ with
- | TPtr (typ,_) -> typ
+ match unrollTypeSkel typ with
+ | TPtr typ -> typ
| _ -> Kernel.fatal "Not a pointer type %a" !pp_typ_ref typ
let typeOf_array_elem t =
- match unrollType t with
- | TArray (ty_elem, _, _) -> ty_elem
+ match unrollTypeNode t with
+ | TArray (ty_elem, _) -> ty_elem
| _ -> Kernel.fatal "Not an array type %a" !pp_typ_ref t
let typeOf_array_elem_size t =
- match unrollType t with
- | TArray (ty_elem, arr_size, _ ) ->
+ match unrollTypeNode t with
+ | TArray (ty_elem, arr_size) ->
ty_elem, Option.bind arr_size !constfoldtoint
| _ -> Kernel.fatal "Not an array type %a" !pp_typ_ref t
@@ -3492,7 +3498,7 @@ let no_op_coerce typ t =
(**** Compute the type of an expression ****)
let rec typeOf (e: exp) : typ =
match e.enode with
- | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
+ | Const(CInt64 (_, ik, _)) -> Cil_const.mk_tint ik
(* Character constants have type int. ISO/IEC 9899:1999 (E),
* section 6.4.4.4 [Character constants], paragraph 10, if you
@@ -3506,9 +3512,9 @@ let rec typeOf (e: exp) : typ =
| Const(CWStr _s) ->
let typ = typeAddAttributes [Attr("const",[])] (wchar_type ()) in
- TPtr(typ,[])
+ Cil_const.mk_tptr typ
- | Const(CReal (_, fk, _)) -> TFloat(fk, [])
+ | Const(CReal (_, fk, _)) -> Cil_const.mk_tfloat fk
| Const(CEnum {eival=v}) -> typeOf v
@@ -3520,22 +3526,22 @@ let rec typeOf (e: exp) : typ =
| UnOp (_, _, t) -> t
| BinOp (_, _, _, t) -> t
| CastE (t, _) -> t
- | AddrOf lv -> TPtr(typeOfLval lv, [])
+ | AddrOf lv -> Cil_const.mk_tptr (typeOfLval lv)
| StartOf lv ->
match unrollType (typeOfLval lv) with
- | TArray (t,_,attrs) -> TPtr(t, attrs)
+ | { tnode = TArray (t,_); tattr } -> Cil_const.mk_tptr ~tattr t
| _ -> Kernel.fatal ~current:true "typeOf: StartOf on a non-array"
and typeOfInit (i: init) : typ =
match i with
- SingleInit e -> typeOf e
+ | SingleInit e -> typeOf e
| CompoundInit (t, _) -> t
and typeOfLval = function
- Var vi, off -> typeOffset vi.vtype off
+ | Var vi, off -> typeOffset vi.vtype off
| Mem addr, off -> begin
- match unrollType (typeOf addr) with
- | TPtr (t, _) -> typeOffset t off
+ match (unrollType (typeOf addr)).tnode with
+ | TPtr t -> typeOffset t off
| _ -> Kernel.fatal ~current:true
"typeOfLval: Mem on a non-pointer (%a)" !pp_exp_ref addr
end
@@ -3547,15 +3553,14 @@ and typeOfLhost = function
and typeOffset basetyp = function
NoOffset -> basetyp
| Index (_, o) -> begin
- match unrollType basetyp with
- TArray (t, _, _baseAttrs) ->
- typeOffset t o
+ match unrollTypeNode basetyp with
+ | TArray (t, _) -> typeOffset t o
| _ -> Kernel.fatal ~current:true "typeOffset: Index on a non-array"
end
| Field (fi, o) ->
match unrollType basetyp with
- | TComp (_, baseAttrs) ->
- let attrs = filter_qualifier_attributes baseAttrs in
+ | { tnode = TComp _; tattr } ->
+ let attrs = filter_qualifier_attributes tattr in
(* if the field is mutable, it can written to even if it is
part of a const object (but a const subpart of the field
is still const (except potentially a mutable subsubpart, etc.)
@@ -3583,8 +3588,8 @@ let rec typeOfTermLval = function
| TMem addr, off -> begin
let rec type_of_pointed = function
| Ctype typ ->
- begin match unrollType typ with
- | TPtr (t, _) -> typeTermOffset (Ctype t) off
+ begin match unrollTypeSkel typ with
+ | TPtr t -> typeTermOffset (Ctype t) off
| _ ->
Kernel.fatal ~current:true
"typeOfTermLval: Mem on a non-pointer"
@@ -3637,9 +3642,9 @@ and typeTermOffset basetyp =
match basetyp with
| Ctype typ ->
begin match unrollType typ with
- TArray (t, _, baseAttrs) ->
+ | { tnode = TArray (t, _); tattr } ->
let elementType = typeTermOffset (Ctype t) o in
- blendAttributes baseAttrs elementType
+ blendAttributes tattr elementType
| _ ->
Kernel.fatal ~current:true
"typeTermOffset: Index on a non-array"
@@ -3661,9 +3666,9 @@ and typeTermOffset basetyp =
let rec elt_type = function
| Ctype typ ->
begin match unrollType typ with
- TComp (_, baseAttrs) ->
+ | { tnode = TComp _; tattr } ->
let fieldType = typeTermOffset (Ctype fi.ftype) o in
- blendAttributes baseAttrs fieldType
+ blendAttributes tattr fieldType
| _ -> Kernel.fatal ~current:true "typeTermOffset: Field on a non-compound"
end
| Lboolean | Linteger | Lreal ->
@@ -3707,13 +3712,13 @@ let rec isWFGhostType t =
isWFGhostType' (unrollTypeDeep t)
and isWFGhostType' t =
if not (isGhostType t) then isWFNonGhostType t
- else match t with
- | TPtr(t, _) | TArray(t, _, _) -> isWFGhostType' t
+ else match t.tnode with
+ | TPtr t | TArray (t, _) -> isWFGhostType' t
| _ -> true
and isWFNonGhostType t =
if isGhostType t then false
- else match t with
- | TPtr(t, _) | TArray(t, _, _) -> isWFNonGhostType t
+ else match t.tnode with
+ | TPtr t | TArray (t, _) -> isWFNonGhostType t
| _ -> true
(**** MACHINE DEPENDENT PART ****)
@@ -3854,22 +3859,23 @@ let ignoreAlignmentAttrs = ref false
(* Get the minimum alignment in bytes for a given type *)
let rec bytesAlignOf t =
- let alignOfType () = match t with
- | TInt((IChar|ISChar|IUChar|IBool), _) -> 1
- | TInt((IShort|IUShort), _) -> alignof_short ()
- | TInt((IInt|IUInt), _) -> alignof_int ()
- | TInt((ILong|IULong), _) -> alignof_long ()
- | TInt((ILongLong|IULongLong), _) -> alignof_longlong ()
- | TEnum (ei,_) -> bytesAlignOf (TInt(ei.ekind, []))
- | TFloat(FFloat, _) -> alignof_float ()
- | TFloat(FDouble, _) -> alignof_double ()
- | TFloat(FLongDouble, _) -> alignof_longdouble ()
- | TNamed (t, _) -> bytesAlignOf t.ttype
- | TArray (t, _, _) -> bytesAlignOf t
- | TPtr _ | TBuiltin_va_list _ -> alignof_ptr ()
+ let alignOfType () =
+ match t.tnode with
+ | TInt (IChar|ISChar|IUChar|IBool) -> 1
+ | TInt (IShort|IUShort) -> alignof_short ()
+ | TInt (IInt|IUInt) -> alignof_int ()
+ | TInt (ILong|IULong) -> alignof_long ()
+ | TInt (ILongLong|IULongLong) -> alignof_longlong ()
+ | TEnum ei -> bytesAlignOf (Cil_const.mk_tint ei.ekind)
+ | TFloat FFloat -> alignof_float ()
+ | TFloat FDouble -> alignof_double ()
+ | TFloat FLongDouble -> alignof_longdouble ()
+ | TNamed t -> bytesAlignOf t.ttype
+ | TArray (t, _) -> bytesAlignOf t
+ | TPtr _ | TBuiltin_va_list -> alignof_ptr ()
(* For composite types get the maximum alignment of any field inside *)
- | TComp (c, _) ->
+ | TComp c ->
(* On GCC the zero-width fields do not contribute to the alignment. On
* MSVC only those zero-width that _do_ appear after other
* bitfields contribute to the alignment. So we drop those that
@@ -3890,8 +3896,8 @@ let rec bytesAlignOf t =
max sofar (alignOfField f)) 1 fields
(* These are some error cases *)
| TFun _ when not (msvcMode ()) -> alignof_fun ()
- | TFun _ as t -> raise (SizeOfError ("Undefined sizeof on a function.", t))
- | TVoid _ as t ->
+ | TFun _ -> raise (SizeOfError ("Undefined sizeof on a function.", t))
+ | TVoid ->
if sizeof_void () > 0 then
sizeof_void ()
else
@@ -4074,9 +4080,9 @@ and offsetOfFieldAcc_MSVC last (fi: fieldinfo)
let ftype = unrollType fi.ftype in
let ftypeAlign = 8 * alignOfField fi in
let ftypeBits = (if last then bitsSizeOfEmptyArray else bitsSizeOf) ftype in
- match ftype, fi.fbitfield, sofar.oaPrevBitPack with
+ match ftype.tnode, fi.fbitfield, sofar.oaPrevBitPack with
(* Ignore zero-width bitfields that come after non-bitfields *)
- | TInt (_ikthis, _), Some 0, None ->
+ | TInt _ikthis, Some 0, None ->
let firstFree = sofar.oaFirstFree in
{ oaFirstFree = firstFree;
oaLastFieldStart = firstFree;
@@ -4097,7 +4103,7 @@ and offsetOfFieldAcc_MSVC last (fi: fieldinfo)
oaPrevBitPack = None }
(* A width of 0 means that we must end the current packing. *)
- | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) ->
+ | TInt ikthis, Some 0, Some (packstart, _, wdpack) ->
let firstFree =
if sofar.oaFirstFree = packstart then packstart else
packstart + wdpack
@@ -4110,7 +4116,7 @@ and offsetOfFieldAcc_MSVC last (fi: fieldinfo)
(* Check for a bitfield that fits in the current pack after some other
* bitfields *)
- | TInt(_ikthis, _), Some wdthis, Some (packstart, _ikprev, wdpack)
+ | TInt _ikthis, Some wdthis, Some (packstart, _ikprev, wdpack)
when packstart + wdpack >= sofar.oaFirstFree + wdthis ->
{ oaFirstFree = sofar.oaFirstFree + wdthis;
oaLastFieldStart = sofar.oaFirstFree;
@@ -4132,7 +4138,7 @@ and offsetOfFieldAcc_MSVC last (fi: fieldinfo)
oaPrevBitPack = None }
(* No active bitfield pack. But we are seeing a bitfield. *)
- | TInt(ikthis, _), Some wdthis, None ->
+ | TInt ikthis, Some wdthis, None ->
let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
{ oaFirstFree = firstFree + wdthis;
oaLastFieldStart = firstFree;
@@ -4154,9 +4160,9 @@ and offsetOfFieldAcc_MSVC last (fi: fieldinfo)
(** This is a special version of [bitsSizeOf] that accepts empty arrays.
Currently, we only use it for flexible array members *)
and bitsSizeOfEmptyArray typ =
- match unrollType typ with
- | TArray (_, None, _) -> 0
- | TArray (_, Some e, _) -> begin
+ match unrollTypeNode typ with
+ | TArray (_, None) -> 0
+ | TArray (_, Some e) -> begin
match constFoldToInt e with
| Some i when Integer.is_zero i ->
(* Used for GCC extension of non-C99 flexible array members.
@@ -4170,29 +4176,29 @@ and bitsSizeOfEmptyArray typ =
(* The size of a type, in bits. If struct or array then trailing padding is
* added *)
and bitsSizeOf t =
- match t with
- | TInt (ik,_) -> 8 * (bytesSizeOfInt ik)
- | TFloat(FDouble, _) -> 8 * sizeof_double ()
- | TFloat(FLongDouble, _) -> 8 * sizeof_longdouble ()
- | TFloat _ -> 8 * sizeof_float ()
- | TEnum (ei,_) -> bitsSizeOf (TInt(ei.ekind, []))
- | TPtr _ -> 8 * sizeof_ptr ()
- | TBuiltin_va_list _ -> 8 * sizeof_ptr ()
- | TNamed (t, _) -> bitsSizeOf t.ttype
- | TComp ({cfields=None} as comp, _) ->
+ match t.tnode with
+ | TInt ik -> 8 * (bytesSizeOfInt ik)
+ | TFloat FDouble -> 8 * sizeof_double ()
+ | TFloat FLongDouble -> 8 * sizeof_longdouble ()
+ | TFloat _ -> 8 * sizeof_float ()
+ | TEnum ei -> bitsSizeOf (Cil_const.mk_tint ei.ekind)
+ | TPtr _ -> 8 * sizeof_ptr ()
+ | TBuiltin_va_list -> 8 * sizeof_ptr ()
+ | TNamed t -> bitsSizeOf t.ttype
+ | TComp ({cfields=None} as comp) ->
raise
(SizeOfError
(Format.sprintf "abstract type '%s'" (compFullName comp), t))
- | TComp ({cfields=Some[]}, _) when acceptEmptyCompinfo() ->
+ | TComp {cfields=Some[]} when acceptEmptyCompinfo() ->
find_sizeof t (fun () -> t,0)
- | TComp ({cfields=Some[]} as comp,_) ->
+ | TComp ({cfields=Some[]} as comp) ->
find_sizeof t
(fun () ->
(* sizeof() empty structs/arrays is only allowed on GCC/MSVC *)
raise
(SizeOfError
(Format.sprintf "empty struct '%s'" (compFullName comp), t)))
- | TComp (comp, _) when comp.cstruct -> (* Struct *)
+ | TComp comp when comp.cstruct -> (* Struct *)
find_sizeof t
(fun () ->
(* Go and get the last offset *)
@@ -4215,7 +4221,7 @@ and bitsSizeOf t =
else
t, addTrailing lastoff.oaFirstFree (8 * bytesAlignOf t))
- | TComp (comp, _) -> (* Union *)
+ | TComp comp -> (* Union *)
find_sizeof t
(fun () ->
(* Get the maximum of all fields *)
@@ -4236,12 +4242,12 @@ and bitsSizeOf t =
(* Add trailing by simulating adding an extra field *)
t, addTrailing max (8 * bytesAlignOf t))
- | TArray(bt, Some len, attrs) ->
+ | TArray(bt, Some len) ->
find_sizeof t
(fun () ->
begin
let v = constFold true len in
- let norm_typ = TArray(bt, Some v, attrs) in
+ let norm_typ = Cil_const.mk_tarray ~tattr:t.tattr bt (Some v) in
match v with
{ enode = Const(CInt64(l,_,_)) } ->
let sz = Integer.mul (Integer.of_int (bitsSizeOf bt)) l in
@@ -4259,7 +4265,7 @@ and bitsSizeOf t =
| _ ->
raise (SizeOfError ("Array with non-constant length.", norm_typ))
end)
- | TVoid _ ->
+ | TVoid ->
if sizeof_void () >= 0 then
8 * sizeof_void ()
else
@@ -4270,7 +4276,7 @@ and bitsSizeOf t =
else
raise (SizeOfError ("Undefined sizeof on a function.", t))
- | TArray (_, None, _) ->
+ | TArray (_, None) ->
find_sizeof t
(fun () ->
raise (SizeOfError ("Size of array without number of elements.", t)))
@@ -4318,7 +4324,7 @@ and fieldBitsOffset (f : fieldinfo) : int * int =
and bitsOffset (baset: typ) (off: offset) : int * int =
let rec loopOff (baset: typ) (width: int) (start: int) = function
- NoOffset -> start, width
+ | NoOffset -> start, width
| Index(e, off) -> begin
let ei =
match constFoldToInt e with
@@ -4331,8 +4337,8 @@ and bitsOffset (baset: typ) (off: offset) : int * int =
end
| Field(f, off) ->
if check_invariants then
- (match unrollType baset with
- | TComp (ci, _) -> assert (ci == f.fcomp)
+ (match unrollTypeSkel baset with
+ | TComp ci -> assert (ci == f.fcomp)
| _ -> assert false);
let offsbits, size = fieldBitsOffset f in
loopOff f.ftype size (start + offsbits) off
@@ -4348,19 +4354,19 @@ and constFold (machdep: bool) (e: exp) : exp =
Kernel.debug ~dkey "ConstFold %a@." !pp_exp_ref e;
let loc = e.eloc in
match e.enode with
- BinOp(bop, e1, e2, tres) -> constFoldBinOp ~loc machdep bop e1 e2 tres
- | UnOp(unop, e1, tres) when isIntegralType tres -> begin
+ | BinOp (bop, e1, e2, tres) -> constFoldBinOp ~loc machdep bop e1 e2 tres
+ | UnOp (unop, e1, tres) when isIntegralType tres -> begin
let tk =
match unrollTypeSkel tres with
- | TInt(ik, _) -> ik
- | TEnum (ei,_) -> ei.ekind
+ | TInt ik -> ik
+ | TEnum ei -> ei.ekind
| _ -> assert false (* tres is an integral type *)
in
let e1c = constFold machdep e1 in
match e1c.enode with
Const(CInt64(i,_ik,repr)) -> begin
match unop with
- Neg ->
+ | Neg ->
let repr = Option.map (fun s -> "-" ^ s) repr in
kinteger64 ~loc ?repr ~kind:tk (Integer.neg i)
| BNot -> kinteger64 ~loc ~kind:tk (Integer.lognot i)
@@ -4370,10 +4376,10 @@ and constFold (machdep: bool) (e: exp) : exp =
end
| _ -> if e1 == e1c then e else new_exp ~loc (UnOp(unop, e1c, tres))
end
- | UnOp(unop, e1, tres) when isArithmeticType tres -> begin
+ | UnOp (unop, e1, tres) when isArithmeticType tres -> begin
let tk =
match unrollTypeSkel tres with
- | TFloat(fk,_) -> fk
+ | TFloat fk -> fk
| _ -> assert false (*tres is arithmetic but not integral, i.e. Float *)
in
let e1c = constFold machdep e1 in
@@ -4423,9 +4429,10 @@ and constFold (machdep: bool) (e: exp) : exp =
| CastE (t, e) -> begin
Kernel.debug ~dkey "ConstFold CAST to %a@." !pp_typ_ref t ;
let e = constFold machdep e in
- match e.enode, unrollType t with
- | Const(CInt64(i,_k,_)),(TInt(nk,a)|TEnum({ekind = nk},a))
- when dropAttributes fc_internal_attributes a = [] ->
+ let t' = unrollType t in
+ match e.enode, t'.tnode with
+ | Const (CInt64(i,_k,_)), (TInt nk | TEnum {ekind = nk})
+ when dropAttributes fc_internal_attributes t'.tattr = [] ->
begin
(* If the cast has attributes, leave it alone. *)
Kernel.debug ~dkey "ConstFold to %a : %a@."
@@ -4433,7 +4440,7 @@ and constFold (machdep: bool) (e: exp) : exp =
(* Downcasts might truncate silently *)
kinteger64 ~loc ~kind:nk i
end
- | Const (CReal(f,_,_)),(TInt(ik,a)|TEnum({ekind = ik},a)) when a = [] ->
+ | Const (CReal(f,_,_)), (TInt ik | TEnum {ekind = ik}) when t.tattr = [] ->
(* See above *)
begin
try
@@ -4446,18 +4453,18 @@ and constFold (machdep: bool) (e: exp) : exp =
with Floating_point.Float_Non_representable_as_Int64 _ -> (* too big*)
new_exp ~loc (CastE (t, e))
end
- | Const (CReal(f,_,_)), TFloat (FFloat,a) when a = [] ->
+ | Const (CReal(f,_,_)), TFloat FFloat when t.tattr = [] ->
let f = Floating_point.round_to_single_precision_float f in
new_exp ~loc (Const (CReal (f,FFloat,None)))
- | Const (CReal(f,_,_)), TFloat (FDouble,a) when a = [] ->
+ | Const (CReal(f,_,_)), TFloat FDouble when t.tattr = [] ->
new_exp ~loc (Const (CReal (f,FDouble,None)))
(* We don't treat cast to long double, as we don't really know
how to handle this type anyway. *)
- | Const (CInt64(i,_,_)), (TFloat(FFloat,a)) when a = [] ->
+ | Const (CInt64(i,_,_)), TFloat FFloat when t.tattr = [] ->
let f = Integer.to_float i in
let f = Floating_point.round_to_single_precision_float f in
new_exp ~loc (Const (CReal (f,FFloat,None)))
- | Const (CInt64(i,_,_)), (TFloat(FDouble,a)) when a = [] ->
+ | Const (CInt64(i,_,_)), TFloat FDouble when t.tattr = [] ->
let f = Integer.to_float i in
new_exp ~loc (Const (CReal (f,FDouble,None)))
| _, _ -> new_exp ~loc (CastE (t, e))
@@ -4492,11 +4499,11 @@ and constFoldBinOp ~loc (machdep: bool) bop e1 e2 tres =
| Const(CEnum {eival = v}) -> mkInt v
| CastE(typ, e') -> begin
match unrollType typ with
- | TInt (ik, ta) -> begin
+ | { tnode = TInt ik } as t -> begin
let e = mkInt e' in
match e.enode with
| Const(CInt64(i, _, _)) -> kinteger64 ~loc ~kind:ik i
- | _ -> {e with enode = CastE(TInt(ik, ta), e)}
+ | _ -> {e with enode = CastE(t, e)}
end
| _ -> e
end
@@ -4504,8 +4511,8 @@ and constFoldBinOp ~loc (machdep: bool) bop e1 e2 tres =
in
let tk =
match unrollTypeSkel tres with
- TInt(ik, _) -> ik
- | TEnum (ei,_) -> ei.ekind
+ | TInt ik -> ik
+ | TEnum ei -> ei.ekind
| _ -> Kernel.fatal ~current:true "constFoldBinOp"
in
(* See if the result is unsigned *)
@@ -4646,7 +4653,7 @@ and constFoldBinOp ~loc (machdep: bool) bop e1 e2 tres =
end else if isArithmeticType tres && not (isLongDoubleType tres) then begin
let tk =
match unrollTypeSkel tres with
- | TFloat(fk,_) -> fk
+ | TFloat fk -> fk
| _ -> Kernel.fatal "constFoldBinOp: not a floating type"
in
match bop, e1'.enode, e2'.enode with
@@ -4676,8 +4683,8 @@ and constFoldToInt ?(machdep=true) e =
let bitsSizeOfBitfield typlv =
match unrollType typlv with
- | TInt (_, attrs) | TEnum (_, attrs) as t ->
- (match findAttribute bitfield_attribute_name attrs with
+ | { tnode = TInt _; tattr } | { tnode = TEnum _; tattr } as t ->
+ (match findAttribute bitfield_attribute_name tattr with
| [AInt i] -> Integer.to_int_exn i
| _ -> bitsSizeOf t)
| t -> bitsSizeOf t
@@ -4732,9 +4739,9 @@ let interpret_character_constant char_list =
else begin
let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in
if value <= (Int64.of_int32 Int32.max_int) then
- (CInt64(Integer.of_int64 value,IULong,orig_rep)),(TInt(IULong,[]))
+ (CInt64(Integer.of_int64 value,IULong,orig_rep)), Cil_const.ulongType
else
- (CInt64(Integer.of_int64 value,IULongLong,orig_rep)),(TInt(IULongLong,[]))
+ (CInt64(Integer.of_int64 value,IULongLong,orig_rep)), Cil_const.ulongLongType
end
let invalidStmt = mkStmt (Instr (Skip Location.unknown))
@@ -4838,9 +4845,9 @@ let need_cast ?(force=false) oldt newt =
not (Cil_datatype.Typ.equal oldt newt) &&
(force ||
match oldt, newt with
- | TInt(ik,ai),TEnum(e,ae)
- | TEnum(e,ae),TInt(ik,ai) when Attributes.equal ai ae ->
- ik <> e.ekind
+ | { tnode = TInt ik; tattr = ai }, { tnode = TEnum e; tattr = ae }
+ | { tnode = TEnum e; tattr = ae }, { tnode = TInt ik; tattr = ai }
+ when Attributes.equal ai ae -> ik <> e.ekind
| _ -> true)
let cvar_to_lvar vi = match vi.vlogic_var_assoc with
@@ -4915,8 +4922,8 @@ let makeTempVar fdec ?insert ?ghost ?(name = "__cil_tmp") ?descr ?(descrpure = t
(* Set the types of arguments and results as given by the function type
* passed as the second argument *)
let setFunctionType (f: fundec) (t: typ) =
- match unrollType t with
- TFun (_rt, Some args, _va, _a) ->
+ match unrollTypeSkel t with
+ | TFun (_rt, Some args, _va) ->
if List.length f.sformals <> List.length args then
Kernel.fatal ~current:true "setFunctionType: number of arguments differs from the number of formals" ;
(* Change the function type. *)
@@ -4932,8 +4939,8 @@ let setFunctionType (f: fundec) (t: typ) =
(* Set the types of arguments and results as given by the function type
passed as the second argument *)
let setFunctionTypeMakeFormals (f: fundec) (t: typ) =
- match unrollType t with
- TFun (_rt, Some args, _va, _a) ->
+ match unrollTypeNode t with
+ | TFun (_rt, Some args, _va) ->
if f.sformals <> [] then
Kernel.fatal ~current:true "setFunctionTypMakeFormals called on function %s with some formals already"
f.svar.vname ;
@@ -5028,7 +5035,7 @@ let emptyFunctionFromVI vi =
(* Make an empty function *)
let emptyFunction name =
let vi =
- makeGlobalVar ~temp:false name (TFun(Cil_const.voidType, Some [], false,[]))
+ makeGlobalVar ~temp:false name Cil_const.(mk_tfun voidType (Some []) false)
in emptyFunctionFromVI vi
let dummyFile =
@@ -5486,7 +5493,7 @@ let mkAddrOfVi vi = mkAddrOf ~loc:vi.vdecl (var vi)
let mkAddrOrStartOf ~loc (lv: lval) : exp =
match unrollTypeSkel (typeOfLval lv) with
- TArray _ -> new_exp ~loc (StartOf lv)
+ | TArray _ -> new_exp ~loc (StartOf lv)
| _ -> mkAddrOf ~loc lv
let mkMem ~(addr: exp) ~(off: offset) : lval =
@@ -5562,14 +5569,14 @@ let instr_falls_through = function
let splitFunctionType (ftype: typ)
: typ * (string * typ * attributes) list option * bool * attributes =
match unrollType ftype with
- TFun (rt, args, isva, a) -> rt, args, isva, a
+ | { tnode = TFun (rt, args, isva); tattr } -> rt, args, isva, tattr
| _ -> Kernel.fatal ~current:true "splitFunctionType invoked on a non function type %a"
!pp_typ_ref ftype
let splitFunctionTypeVI (fvi: varinfo)
: typ * (string * typ * attributes) list option * bool * attributes =
match unrollType fvi.vtype with
- TFun (rt, args, isva, a) -> rt, args, isva, a
+ | { tnode = TFun (rt, args, isva); tattr } -> rt, args, isva, tattr
| _ -> Kernel.abort "Function %s invoked on a non function type" fvi.vname
let argsToPairOfLists args =
@@ -5581,26 +5588,25 @@ let remove_attributes_for_integral_promotion a =
dropAttributes (bitfield_attribute_name :: spare_attributes_for_c_cast) a
let rec integralPromotion t = (* c.f. ISO 6.3.1.1 *)
+ let open Cil_const in
match unrollType t with
- | TInt ((IShort|ISChar|IBool), a) ->
- let a = remove_attributes_for_integral_promotion a in
- TInt(IInt, a)
- | TInt (IUChar|IUShort as k, a) ->
- let a = remove_attributes_for_integral_promotion a in
- if bitsSizeOfInt k < bitsSizeOf Cil_const.intType then
- TInt(IInt, a)
- else
- TInt(IUInt,a)
- | TInt (IChar,a) ->
+ | { tnode = TInt (IShort|ISChar|IBool); tattr } ->
+ let tattr = remove_attributes_for_integral_promotion tattr in
+ mk_tint ~tattr IInt
+ | { tnode = TInt (IUChar|IUShort as k); tattr } ->
+ let tattr = remove_attributes_for_integral_promotion tattr in
+ let ik = if bitsSizeOfInt k < bitsSizeOf intType then IInt else IUInt in
+ mk_tint ~tattr ik
+ | { tnode = TInt IChar; tattr } ->
let k = if isSigned IChar then ISChar else IUChar in
- integralPromotion (TInt (k, a))
- | TInt (k,a) ->
- begin match findAttribute bitfield_attribute_name a with
+ integralPromotion (mk_tint ~tattr k)
+ | { tnode = TInt k; tattr } ->
+ begin match findAttribute bitfield_attribute_name tattr with
| [AInt size] ->
(* This attribute always fits in int. *)
let size = Integer.to_int_exn size in
- let sizeofint = bitsSizeOf Cil_const.intType in
- let attrs = remove_attributes_for_integral_promotion a in
+ let sizeofint = bitsSizeOf intType in
+ let tattr = remove_attributes_for_integral_promotion tattr in
let kind =
if size < sizeofint then IInt
else if size = sizeofint then
@@ -5608,60 +5614,61 @@ let rec integralPromotion t = (* c.f. ISO 6.3.1.1 *)
else IUInt
else k
in
- TInt(kind,attrs)
+ mk_tint ~tattr kind
| [] -> t
| _ -> assert false
end
- | TEnum (ei, a) -> (* gcc packed enums can be < int *)
- integralPromotion (TInt(ei.ekind, a))
- | t -> Kernel.fatal ~current:true "integralPromotion: not expecting %a" !pp_typ_ref t
+ | { tnode = TEnum ei; tattr } -> (* gcc packed enums can be < int *)
+ integralPromotion (mk_tint ~tattr ei.ekind)
+ | _ -> Kernel.fatal ~current:true "integralPromotion: not expecting %a" !pp_typ_ref t
let arithmeticConversion t1 t2 = (* c.f. ISO 6.3.1.8 *)
let checkToInt _ = () in (* dummies for now *)
let checkToFloat _ = () in
match unrollTypeSkel t1, unrollTypeSkel t2 with
- TFloat(FLongDouble, _), _ -> checkToFloat t2; t1
- | _, TFloat(FLongDouble, _) -> checkToFloat t1; t2
- | TFloat(FDouble, _), _ -> checkToFloat t2; t1
- | _, TFloat (FDouble, _) -> checkToFloat t1; t2
- | TFloat(FFloat, _), _ -> checkToFloat t2; t1
- | _, TFloat (FFloat, _) -> checkToFloat t1; t2
+ | TFloat FLongDouble, _ -> checkToFloat t2; t1
+ | _, TFloat FLongDouble -> checkToFloat t1; t2
+ | TFloat FDouble, _ -> checkToFloat t2; t1
+ | _, TFloat FDouble -> checkToFloat t1; t2
+ | TFloat FFloat, _ -> checkToFloat t2; t1
+ | _, TFloat FFloat -> checkToFloat t1; t2
| _, _ -> begin
let t1' = integralPromotion t1 in
let t2' = integralPromotion t2 in
match unrollTypeSkel t1', unrollTypeSkel t2' with
- TInt(IULongLong, _), _ -> checkToInt t2'; t1'
- | _, TInt(IULongLong, _) -> checkToInt t1'; t2'
+ | TInt IULongLong, _ -> checkToInt t2'; t1'
+ | _, TInt IULongLong -> checkToInt t1'; t2'
- | TInt(ILongLong,_), _
+ | TInt ILongLong, _
when bitsSizeOf t1' <= bitsSizeOf t2' &&
- (not (isSignedInteger t2')) -> TInt(IULongLong,[])
- | _, TInt(ILongLong,_)
+ (not (isSignedInteger t2')) -> Cil_const.ulongLongType
+ | _, TInt ILongLong
when bitsSizeOf t2' <= bitsSizeOf t1' &&
- (not (isSignedInteger t1')) -> TInt(IULongLong,[])
+ (not (isSignedInteger t1')) -> Cil_const.ulongLongType
- | TInt(ILongLong, _), _ -> checkToInt t2'; t1'
- | _, TInt(ILongLong, _) -> checkToInt t1'; t2'
+ | TInt ILongLong, _ -> checkToInt t2'; t1'
+ | _, TInt ILongLong -> checkToInt t1'; t2'
- | TInt(IULong, _), _ -> checkToInt t2'; t1'
- | _, TInt(IULong, _) -> checkToInt t1'; t2'
+ | TInt IULong, _ -> checkToInt t2'; t1'
+ | _, TInt IULong -> checkToInt t1'; t2'
- | TInt(ILong,_), TInt(IUInt,_)
- when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[])
- | TInt(IUInt,_), TInt(ILong,_)
- when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[])
+ | TInt ILong, TInt IUInt
+ when bitsSizeOf t1' <= bitsSizeOf t2' -> Cil_const.ulongType
+ | TInt IUInt, TInt ILong
+ when bitsSizeOf t2' <= bitsSizeOf t1' -> Cil_const.ulongType
- | TInt(ILong, _), _ -> checkToInt t2'; t1'
- | _, TInt(ILong, _) -> checkToInt t1'; t2'
+ | TInt ILong, _ -> checkToInt t2'; t1'
+ | _, TInt ILong -> checkToInt t1'; t2'
- | TInt(IUInt, _), _ -> checkToInt t2'; t1'
- | _, TInt(IUInt, _) -> checkToInt t1'; t2'
+ | TInt IUInt, _ -> checkToInt t2'; t1'
+ | _, TInt IUInt -> checkToInt t1'; t2'
- | TInt(IInt, _), TInt (IInt, _) -> t1'
+ | TInt IInt, TInt IInt -> t1'
- | t1, t2 ->
- Kernel.fatal ~current:true "arithmeticConversion %a -> %a@." !pp_typ_ref t1 !pp_typ_ref t2
+ | n1, n2 ->
+ Kernel.fatal ~current:true "arithmeticConversion %a -> %a@."
+ !pp_typ_ref (Cil_const.mk_typ n1) !pp_typ_ref (Cil_const.mk_typ n2)
end
let isArrayType t = match unrollTypeSkel t with
@@ -5669,33 +5676,33 @@ let isArrayType t = match unrollTypeSkel t with
| _ -> false
let isUnsizedArrayType t = match unrollTypeSkel t with
- | TArray (_, None, _) -> true
+ | TArray (_, None) -> true
| _ -> false
let isSizedArrayType t = match unrollTypeSkel t with
- | TArray (_, Some _, _) -> true
+ | TArray (_, Some _) -> true
| _ -> false
let isAnyCharArrayType t = match unrollTypeSkel t with
- | TArray(tau,_,_) when isAnyCharType tau -> true
+ | TArray(tau, _) when isAnyCharType tau -> true
| _ -> false
let isCharArrayType t = match unrollTypeSkel t with
- | TArray(tau,_,_) when isCharType tau -> true
+ | TArray(tau, _) when isCharType tau -> true
| _ -> false
let isStructType t = match unrollTypeSkel t with
- | TComp (comp, _) -> comp.cstruct
+ | TComp comp -> comp.cstruct
| _ -> false
let isUnionType t = match unrollTypeSkel t with
- | TComp (comp, _) -> not comp.cstruct
+ | TComp comp -> not comp.cstruct
| _ -> false
let isStructOrUnionType t = isStructType t || isUnionType t
let isVariadicListType t = match unrollTypeSkel t with
- | TBuiltin_va_list _ -> true
+ | TBuiltin_va_list -> true
| _ -> false
let rec isConstantGen is_varinfo_cst f e = match e.enode with
@@ -5716,8 +5723,8 @@ let rec isConstantGen is_varinfo_cst f e = match e.enode with
| CastE(t,{ enode = Const(CReal _)}) when isIntegralType t -> true
| CastE(t, e) ->
begin
- match t, typeOf e with
- | TInt (i, _), TPtr _ ->
+ match t.tnode, (typeOf e).tnode with
+ | TInt i, TPtr _ ->
(* gcc/clang/ccomp only consider non-truncated constant ptr values
to be constant. If it is truncated, we consider it non-const
in any case.
@@ -5758,7 +5765,7 @@ let getCompField cinfo fieldName =
let getCompType typ =
match unrollTypeSkel typ with
- | TComp(comp,_) -> comp
+ | TComp comp -> comp
| _ -> raise Not_found
let sameSizeInt ?(machdep=false) (ik1 : ikind) (ik2 : ikind) =
@@ -5838,8 +5845,9 @@ let included_qualifiers ?(context=Identical) a1 a2 =
(* precondition: t1 and t2 must be "compatible" as per combineTypes, i.e.
you must have called [combineTypes t1 t2] before calling this function. *)
let rec have_compatible_qualifiers_deep ?(context=Identical) t1 t2 =
- match unrollType t1, unrollType t2 with
- | TFun (tres1, Some args1, _, _), TFun (tres2, Some args2, _, _) ->
+ let t1 = unrollType t1 and t2 = unrollType t2 in
+ match t1.tnode, t2.tnode with
+ | TFun (tres1, Some args1, _), TFun (tres2, Some args2, _) ->
have_compatible_qualifiers_deep
~context:(qualifier_context_fun_ret context) tres1 tres2 &&
let context = qualifier_context_fun_arg context in
@@ -5847,9 +5855,9 @@ let rec have_compatible_qualifiers_deep ?(context=Identical) t1 t2 =
have_compatible_qualifiers_deep ~context t1' t2' &&
included_qualifiers ~context a1 a2)
args1 args2
- | TPtr (t1', a1), TPtr (t2', a2)
- | TArray (t1', _, a1), TArray (t2', _, a2) ->
- (included_qualifiers ~context a1 a2) &&
+ | TPtr t1', TPtr t2'
+ | TArray (t1', _), TArray (t2', _) ->
+ (included_qualifiers ~context t1.tattr t2.tattr) &&
let context = qualifier_context_ptr context in
have_compatible_qualifiers_deep ~context t1' t2'
| _, _ -> included_qualifiers ~context (typeAttrs t1) (typeAttrs t2)
@@ -5940,12 +5948,14 @@ let combineTypesGen ?emitwith (combF : combineFunction)
~strictInteger ~strictReturnTypes
(what : combineWhat) (oldt : typ) (t : typ) : typ =
let warning = Kernel.warning ?emitwith in
- match oldt, t with
- | TVoid olda, TVoid a -> TVoid (combineAttributes what olda a)
+ let tattr = combineAttributes what oldt.tattr t.tattr in
+ match oldt.tnode, t.tnode with
+ | TVoid, TVoid ->
+ Cil_const.mk_tvoid ~tattr ()
- | _, TVoid _ when what = CombineFunret && not strictReturnTypes -> t
+ | _, TVoid when what = CombineFunret && not strictReturnTypes -> t
- | TInt (oldik, olda), TInt (ik, a) ->
+ | TInt oldik, TInt ik ->
let result k oldk = if rank oldk<rank k then k else oldk in
let check_gcc_mode oldk k =
if gccMode () && oldk == IInt &&
@@ -5984,9 +5994,9 @@ let combineTypesGen ?emitwith (combF : combineFunction)
else
check_gcc_mode oldk k
in
- TInt (combineIK oldik ik, combineAttributes what olda a)
+ Cil_const.mk_tint ~tattr (combineIK oldik ik)
- | TFloat (oldfk, olda), TFloat (fk, a) ->
+ | TFloat oldfk, TFloat fk ->
let combineFK oldk k =
if oldk == k then oldk else
if gccMode () && oldk == FDouble && k == FFloat
@@ -5995,28 +6005,28 @@ let combineTypesGen ?emitwith (combF : combineFunction)
else
raise (Cannot_combine "different floating point types")
in
- TFloat (combineFK oldfk fk, combineAttributes what olda a)
+ Cil_const.mk_tfloat ~tattr (combineFK oldfk fk)
- | TEnum (oldei, olda), TEnum (ei, a) ->
+ | TEnum oldei, TEnum ei ->
(* Matching enumerations always succeeds. But sometimes it maps both
* enumerations to integers *)
- TEnum (combF.enum_combine combF oldei ei,
- combineAttributes what olda a)
+ let ei' = combF.enum_combine combF oldei ei in
+ Cil_const.mk_tenum ~tattr ei'
(* Strange one. But seems to be handled by GCC *)
- | TEnum (oldei, olda) , TInt(IInt, a) ->
- TEnum(oldei, combineAttributes what olda a)
+ | TEnum oldei , TInt IInt ->
+ Cil_const.mk_tenum ~tattr oldei
(* Strange one. But seems to be handled by GCC. Warning. Here we are
* leaking types from new to old *)
- | TInt(IInt, olda), TEnum (ei, a) ->
- TEnum(ei, combineAttributes what olda a)
+ | TInt IInt, TEnum ei ->
+ Cil_const.mk_tenum ~tattr ei
- | TComp (oldci, olda) , TComp (ci, a) ->
- TComp(combF.comp_combine combF oldci ci,
- combineAttributes what olda a)
+ | TComp oldci , TComp ci ->
+ let ci' = combF.comp_combine combF oldci ci in
+ Cil_const.mk_tcomp ~tattr ci'
- | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
+ | TArray (oldbt, oldsz), TArray (bt, sz) ->
let newbt =
combF.typ_combine combF
~strictInteger ~strictReturnTypes CombineOther oldbt bt
@@ -6047,16 +6057,16 @@ let combineTypesGen ?emitwith (combF : combineFunction)
end else
raise (Cannot_combine "different array lengths")
in
- TArray (newbt, newsz, combineAttributes what olda a)
+ Cil_const.mk_tarray ~tattr newbt newsz
- | TPtr (oldbt, olda), TPtr (bt, a) ->
+ | TPtr oldbt, TPtr bt ->
let newbt =
combF.typ_combine combF
~strictInteger ~strictReturnTypes CombineOther oldbt bt
in
- TPtr (newbt, combineAttributes what olda a)
+ Cil_const.mk_tptr ~tattr newbt
- | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
+ | TFun (oldrt, oldargs, oldva), TFun (rt, args, va) ->
let newrt =
combF.typ_combine combF
~strictInteger ~strictReturnTypes CombineFunret oldrt rt
@@ -6103,37 +6113,38 @@ let combineTypesGen ?emitwith (combF : combineFunction)
in
(* Drop missingproto as soon as one of the type is a properly declared one*)
let olda' =
- if not (hasAttribute "missingproto" a) then
- dropAttribute "missingproto" olda
- else olda
+ if not (hasAttribute "missingproto" t.tattr) then
+ dropAttribute "missingproto" oldt.tattr
+ else oldt.tattr
in
let a' =
- if not (hasAttribute "missingproto" olda) then
- dropAttribute "missingproto" a
- else a
+ if not (hasAttribute "missingproto" oldt.tattr) then
+ dropAttribute "missingproto" t.tattr
+ else t.tattr
in
- TFun (newrt, newargs, oldva, combineAttributes what olda' a')
+ let tattr = combineAttributes what olda' a' in
+ Cil_const.mk_tfun ~tattr newrt newargs oldva
- | TBuiltin_va_list olda, TBuiltin_va_list a ->
- TBuiltin_va_list (combineAttributes what olda a)
+ | TBuiltin_va_list, TBuiltin_va_list ->
+ Cil_const.mk_tbuiltin ~tattr ()
- | TNamed (oldt, olda), TNamed (t, a) ->
- TNamed (combF.name_combine combF what oldt t,
- combineAttributes what olda a)
+ | TNamed oldti, TNamed ti ->
+ let ti' = combF.name_combine combF what oldti ti in
+ Cil_const.mk_tnamed ~tattr ti'
- | _, TNamed (t, a) ->
+ | _, TNamed ti ->
let res =
combF.typ_combine combF
- ~strictInteger ~strictReturnTypes what oldt t.ttype
+ ~strictInteger ~strictReturnTypes what oldt ti.ttype
in
- typeAddAttributes ~combine:(combineAttributes what) a res
+ typeAddAttributes ~combine:(combineAttributes what) t.tattr res
- | TNamed (oldt, olda), _ ->
+ | TNamed oldti, _ ->
let res =
combF.typ_combine combF
- ~strictInteger ~strictReturnTypes what oldt.ttype t
+ ~strictInteger ~strictReturnTypes what oldti.ttype t
in
- typeAddAttributes ~combine:(combineAttributes what) olda res
+ typeAddAttributes ~combine:(combineAttributes what) oldt.tattr res
| _ ->
raise
@@ -6193,10 +6204,12 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
let origin = if fromsource then "explicit cast:" else " implicit cast:" in
let error msg = abort_context ("%s " ^^ msg) origin in
let rec default_rec oldt newt =
- match unrollType oldt, unrollType newt with
+ let oldt' = unrollType oldt in
+ let newt' = unrollType newt in
+ match oldt'.tnode, newt'.tnode with
| TNamed _, _
| _, TNamed _ -> Kernel.fatal ~current:true "unrollType failed in checkCast"
- | t, TInt (IBool, _) when isScalarType t -> ()
+ | _, TInt IBool when isScalarType oldt' -> ()
| TInt _, TInt _ -> ()
| TFloat _, TInt _ -> (* ISO 6.3.1.4.1 *) ()
| TInt _, TFloat _ -> (* ISO 6.3.1.4.2 *) ()
@@ -6210,13 +6223,13 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
"Casting a pointer into an enumeration type"
| TInt _, TEnum _ -> ()
- | _, TVoid _ ->
+ | _, TVoid ->
(* ISO 6.3.2.2 *)
Kernel.debug ~level:3
"Casting a value into void: expr is evaluated for side effects"
- | TPtr (t, _), TPtr (TVoid _, _) when isObjectType t ->
+ | TPtr t, TPtr { tnode = TVoid } when isObjectType t ->
(* ISO 6.3.2.3.1 *) ()
- | TPtr (TVoid _, _), TPtr (t, _) when isObjectType t ->
+ | TPtr { tnode = TVoid }, TPtr t when isObjectType t ->
(* ISO 6.3.2.3.1 *) ()
| TInt _, TPtr _ -> (* ISO 6.3.2.3.5 *) ()
| TPtr _, TInt _ -> (* ISO 6.3.2.3.6 *)
@@ -6226,9 +6239,9 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
~wkey:Kernel.wkey_int_conversion
~current:true
"Conversion from a pointer to an integer without an explicit cast"
- | TPtr (t1, _), TPtr (t2, _) when isObjectType t1 && isObjectType t2 ->
+ | TPtr t1, TPtr t2 when isObjectType t1 && isObjectType t2 ->
(* ISO 6.3.2.3.7 *) ()
- | TPtr (t1, _), TPtr (t2, _) when isFunctionType t1 && isFunctionType t2 ->
+ | TPtr t1, TPtr t2 when isFunctionType t1 && isFunctionType t2 ->
(* ISO 6.3.2.3.8 *)
if not (areCompatibleTypes ?context oldt newt)
then
@@ -6242,12 +6255,12 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
(* accept converting a ptr to function to/from a ptr to void, even though
not really accepted by the standard.
Main compilers supports it. *)
- | TPtr (TFun _, _), TPtr (TVoid _, _) -> ()
- | TPtr (TVoid _, _), TPtr (TFun _, _) -> ()
+ | TPtr { tnode = TFun _ }, TPtr { tnode = TVoid } -> ()
+ | TPtr { tnode = TVoid } , TPtr { tnode = TFun _ } -> ()
- | TFun _, TPtr (TFun _, _) -> (* ISO 6.3.2.1.4 *) ()
+ | TFun _, TPtr { tnode = TFun _ } -> (* ISO 6.3.2.1.4 *) ()
- | TArray (t1, _, _), TPtr (t2, _) ->
+ | TArray (t1, _), TPtr t2 ->
(* ISO 6.3.2.1.3 *)
if not (areCompatibleTypes ?context t1 t2)
then
@@ -6258,7 +6271,7 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
%a@ and@ %a"
Cil_datatype.Typ.pretty oldt Cil_datatype.Typ.pretty newt
- | TArray (t1, _, _), TArray (t2, _, _) ->
+ | TArray (t1, _), TArray (t2, _) ->
if not (areCompatibleTypes ?context t1 t2)
then
Kernel.warning
@@ -6272,10 +6285,15 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
use unrollTypeDeep above in order to avoid needless divergence with
original type in the sources.
*)
- | TPtr (TFun _, _), TPtr (TNamed (ti, nattr), pattr) ->
- default_rec oldt (TPtr (typeAddAttributes nattr ti.ttype, pattr))
- | TPtr (TNamed (ti, nattr), pattr), TPtr (TFun _, _) ->
- default_rec (TPtr (typeAddAttributes nattr ti.ttype, pattr)) newt
+ | TPtr { tnode = TFun _ }, TPtr { tnode = TNamed ti; tattr } ->
+ let t' = typeAddAttributes tattr ti.ttype in
+ let t'' = Cil_const.mk_tptr ~tattr:newt'.tattr t' in
+ default_rec t'' newt
+
+ | TPtr { tnode = TNamed ti; tattr }, TPtr { tnode = TFun _ } ->
+ let t' = typeAddAttributes tattr ti.ttype in
+ let t'' = Cil_const.mk_tptr ~tattr:oldt'.tattr t' in
+ default_rec t'' newt
| TFloat _, TPtr _
| TPtr _, TFloat _ ->
@@ -6284,24 +6302,24 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
(* No other conversion implying a pointer to function
and a pointer to object are supported. *)
- | TPtr (t1, _), TPtr (t2, _) when isFunctionType t1 && isObjectType t2 ->
+ | TPtr t1, TPtr t2 when isFunctionType t1 && isObjectType t2 ->
if not nullptr_cast then
Kernel.warning
~wkey:Kernel.wkey_incompatible_pointer_types
~current:true
"casting function to %a" Cil_datatype.Typ.pretty newt
- | TPtr (t1, _), TPtr (t2, _) when isFunctionType t2 && isObjectType t1 ->
+ | TPtr t1, TPtr t2 when isFunctionType t2 && isObjectType t1 ->
if not nullptr_cast then
Kernel.warning
~wkey:Kernel.wkey_incompatible_pointer_types
~current:true
"casting function from %a" Cil_datatype.Typ.pretty oldt
- | _, TPtr (t1, _) when isFunctionType t1 ->
+ | _, TPtr t1 when isFunctionType t1 ->
error "cannot cast %a to function type"
Cil_datatype.Typ.pretty oldt
- | t1, t2 when isArithmeticType t1 && isArithmeticType t2 ->
+ | _, _ when isArithmeticType oldt' && isArithmeticType newt' ->
(* ISO 6.5.16.1.1#1 *) ()
@@ -6313,7 +6331,7 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
have been changed to the type of the first argument, and we'll
see a cast from a union to the type of the first argument. Turn
that into a field access *)
- | TComp (_, _), _ ->
+ | TComp _, _ ->
begin
match isTransparentUnion oldt with
| None ->
@@ -6322,13 +6340,13 @@ let checkCast ?context ?(nullptr_cast=false) ?(fromsource=false) =
| Some _ -> ()
end
- | TBuiltin_va_list _, (TInt _ | TPtr _) -> ()
+ | TBuiltin_va_list, (TInt _ | TPtr _) -> ()
- | (TInt _ | TPtr _), TBuiltin_va_list _ ->
+ | (TInt _ | TPtr _), TBuiltin_va_list ->
Kernel.debug ~dkey ~current:true
"Casting %a to __builtin_va_list" Cil_datatype.Typ.pretty oldt
- | _, t1 when fromsource && not (isScalarType t1) ->
+ | _, _ when fromsource && not (isScalarType newt') ->
(* ISO 6.5.4.2 *)
error "cast over a non-scalar type %a" Cil_datatype.Typ.pretty newt
@@ -6345,16 +6363,17 @@ let rec castReduce fromsource force =
let loc = e.eloc in
let normalized_newt = type_remove_attributes_for_c_cast (unrollType newt) in
let res e = new_exp ~loc (CastE (type_remove_qualifier_attributes newt, e)) in
- match unrollType oldt, normalized_newt, e.enode with
+ let oldt' = unrollType oldt in
+ match oldt'.tnode, (normalized_newt).tnode, e.enode with
(* In the case were we have a representation for the literal,
explicitly add the cast. *)
- | _, TInt (newik, []), Const (CInt64 (i, _, None)) ->
+ | _, TInt newik, Const (CInt64 (i, _, None)) ->
(* ISO 6.3.1.3.2 *) kinteger64 ~loc ~kind:newik i
| _, TPtr _, CastE (_, e') ->
begin
match unrollType (typeOf e'), e'.enode with
- | (TPtr _ as typ''), _ ->
+ | { tnode = TPtr _ } as typ'', _ ->
(* Old cast can be removed...*)
if need_cast ~force newt typ'' then res e'
else (* In fact, both casts can be removed. *) e'
@@ -6362,13 +6381,13 @@ let rec castReduce fromsource force =
| _ -> res e
end
- | TInt (ik, _), TEnum (ei, _), Const (CEnum { eihost = ei'}) when
+ | TInt ik, TEnum ei, Const (CEnum { eihost = ei'}) when
ei.ename = ei'.ename && not fromsource &&
bytesSizeOfInt ik = bytesSizeOfInt ei'.ekind -> e
- | TFun _, TPtr (TFun _, _), Lval lv -> mkAddrOf ~loc lv
+ | TFun _, TPtr { tnode = TFun _ }, Lval lv -> mkAddrOf ~loc lv
- | t, TInt (IBool, _), _ when isScalarType t ->
+ | _, TInt IBool, _ when isScalarType oldt' ->
if is_boolean_result e then begin
Kernel.debug ~dkey "Explicit cast to Boolean: %a" !pp_exp_ref e;
res e
@@ -6416,7 +6435,7 @@ and mkCastTGen ?(check=true) ?context ?(fromsource=false) ?(force=false)
begin
Kernel.debug ~dkey "no cast to perform";
let returned_type =
- match newt with
+ match newt.tnode with
| TNamed _ -> newt
| _ -> oldt
in
@@ -6560,12 +6579,12 @@ let existsType (f: typ -> existsAction) (t: typ) : bool =
ExistsTrue -> true
| ExistsFalse -> false
| ExistsMaybe ->
- (match t with
- TNamed (t', _) -> loop t'.ttype
- | TComp (c,_) -> loopComp c
- | TArray (t', _, _) -> loop t'
- | TPtr (t', _) -> loop t'
- | TFun (rt, args, _, _) ->
+ (match t.tnode with
+ | TNamed t' -> loop t'.ttype
+ | TComp c -> loopComp c
+ | TArray (t', _) -> loop t'
+ | TPtr t' -> loop t'
+ | TFun (rt, args, _) ->
(loop rt || List.exists (fun (_, at, _) -> loop at)
(argsToList args))
| _ -> false)
@@ -6586,8 +6605,8 @@ let increm (e: exp) (i: int) =
let e' = constFold false e in
let et = typeOf e' in
let bop = if isPointerType et then PlusPI else PlusA in
- let i = match et with
- | TInt (k, _) | TEnum ({ekind = k },_) -> kinteger k ~loc:e.eloc i
+ let i = match et.tnode with
+ | TInt k | TEnum {ekind = k } -> kinteger k ~loc:e.eloc i
| _ -> integer ~loc:e.eloc i
in
constFoldBinOp ~loc:e.eloc false bop e' i et
@@ -6628,12 +6647,13 @@ let lenOfArray eo =
(*** Make an initializer for zeroing a data type ***)
let rec makeZeroInit ~loc (t: typ) : init =
- match unrollType t with
- TInt (ik, _) ->
+ let t' = unrollType t in
+ match t'.tnode with
+ | TInt ik ->
SingleInit (new_exp ~loc (Const(CInt64(Integer.zero, ik, None))))
- | TFloat(fk, _) -> SingleInit(new_exp ~loc (Const(CReal(0.0, fk, None))))
+ | TFloat fk -> SingleInit(new_exp ~loc (Const(CReal(0.0, fk, None))))
| TEnum _ -> SingleInit (zero ~loc)
- | TComp (comp, _) as t' when comp.cstruct ->
+ | TComp comp when comp.cstruct ->
let inits =
List.fold_right
(fun f acc ->
@@ -6644,7 +6664,7 @@ let rec makeZeroInit ~loc (t: typ) : init =
(Option.value ~default:[] comp.cfields) []
in
CompoundInit (t', inits)
- | TComp (comp, _) when not comp.cstruct ->
+ | TComp comp when not comp.cstruct ->
(match comp.cfields with
| Some [] -> CompoundInit(t, []) (* tolerate empty initialization. *)
| Some (f :: _rest) ->
@@ -6653,7 +6673,7 @@ let rec makeZeroInit ~loc (t: typ) : init =
CompoundInit(t, [(Field(f, NoOffset), makeZeroInit ~loc f.ftype)])
| None ->
Kernel.fatal "Initialization of incomplete struct")
- | TArray(bt, Some len, _) as t' ->
+ | TArray (bt, Some len) ->
let n =
match constFoldToInt len with
| Some n -> Integer.to_int_exn n
@@ -6666,16 +6686,16 @@ let rec makeZeroInit ~loc (t: typ) : init =
in
CompoundInit(t', loopElems [] (n - 1))
- | TArray (_bt, None, _) as t' ->
+ | TArray (_bt, None) ->
(* Unsized array, allow it and fill it in later
* (see cabs2cil.ml, collectInitializer) *)
CompoundInit (t', [])
- | TPtr _ as t ->
+ | TPtr _ ->
SingleInit(
- if (insert_implicit_casts ()) then mkCast ~newt:t (zero ~loc)
+ if (insert_implicit_casts ()) then mkCast ~newt:t' (zero ~loc)
else zero ~loc)
- | x -> Kernel.fatal ~current:true "Cannot initialize type: %a" !pp_typ_ref x
+ | _ -> Kernel.fatal ~current:true "Cannot initialize type: %a" !pp_typ_ref t'
(** Fold over the list of initializers in a Compound (not also the nested
* ones). [doinit] is called on every present initializer, even if it is of
@@ -6691,8 +6711,8 @@ let foldLeftCompound
~(ct: typ)
~(initl: (offset * init) list)
~(acc: 'a) : 'a =
- match unrollType ct with
- | TArray(bt, leno, _) -> begin
+ match unrollTypeNode ct with
+ | TArray (bt, leno) -> begin
let default () =
(* iter over the supplied initializers *)
List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl
@@ -6740,7 +6760,7 @@ let foldLeftCompound
else default ()
end
- | TComp (_comp, _) ->
+ | TComp _comp ->
let getTypeOffset = function
Field(f, NoOffset) -> f.ftype
| _ -> Kernel.fatal ~current:true "foldLeftCompound: malformed initializer"
@@ -6752,13 +6772,13 @@ let foldLeftCompound
let rec has_flexible_array_member t =
let is_flexible_array t =
- match unrollType t with
- | TArray (_, None, _) -> true
- | TArray (_, Some z, _) -> (msvcMode() || gccMode()) && isZero z
+ match unrollTypeSkel t with
+ | TArray (_, None) -> true
+ | TArray (_, Some z) -> (msvcMode() || gccMode()) && isZero z
| _ -> false
in
- match unrollType t with
- | TComp ({ cfields = Some ((_::_) as l) },_) ->
+ match unrollTypeSkel t with
+ | TComp { cfields = Some ((_::_) as l) } ->
let last = (Extlib.last l).ftype in
is_flexible_array last ||
((gccMode() || msvcMode()) && has_flexible_array_member last)
@@ -6769,21 +6789,21 @@ let rec has_flexible_array_member t =
the array type isn't. *)
let rec isCompleteType ?(allowZeroSizeArrays=gccMode ())
?(last_field=false) t =
- match unrollType t with
- | TVoid _ -> false (* void is an incomplete type by definition (6.2.5§19) *)
- | TArray(t, None, _) ->
+ match unrollTypeNode t with
+ | TVoid -> false (* void is an incomplete type by definition (6.2.5§19) *)
+ | TArray(t, None) ->
last_field && is_complete_agg_member ~allowZeroSizeArrays ~last_field t
- | TArray(t, Some z, _) when isZero z ->
+ | TArray(t, Some z) when isZero z ->
allowZeroSizeArrays &&
is_complete_agg_member ~allowZeroSizeArrays ~last_field t
- | TArray(t, Some _, _) ->
+ | TArray(t, Some _) ->
is_complete_agg_member ~allowZeroSizeArrays ~last_field t
- | TComp ( { cfields = None }, _) -> false
- | TComp ( { cstruct ; cfields = Some flds }, _) -> (* Struct or union *)
+ | TComp { cfields = None } -> false
+ | TComp { cstruct ; cfields = Some flds } -> (* Struct or union *)
complete_type_fields ~allowZeroSizeArrays cstruct flds
- | TEnum({eitems = []},_) -> false
+ | TEnum {eitems = []} -> false
| TEnum _ -> true
- | TInt _ | TFloat _ | TPtr _ | TBuiltin_va_list _ -> true
+ | TInt _ | TFloat _ | TPtr _ | TBuiltin_va_list -> true
| TFun _ -> true (* only object types can be incomplete (6.2.5§1) *)
| TNamed _ -> assert false (* unroll should have removed it. *)
@@ -6809,10 +6829,11 @@ let isCompleteType ?allowZeroSizeArrays t =
isCompleteType ?allowZeroSizeArrays t
let pointer_decay t =
- match unrollType t with
- | TArray (typ, _, _) -> TPtr(typ, [])
- | TFun _ as typ -> TPtr(typ, [])
- | t -> t
+ let t' = unrollType t in
+ match t'.tnode with
+ | TArray (typ, _) -> Cil_const.mk_tptr typ
+ | TFun _ -> Cil_const.mk_tptr t'
+ | _ -> t'
(* C11 6.3.2.1: If the lvalue has qualified type, the value has the
unqualified version of the type of the lvalue; additionally, if the lvalue
@@ -6832,8 +6853,8 @@ let lvalue_conversion (t : typ) : (typ, string) result =
Ok (type_remove_qualifier_attributes_deep t')
let rec is_variably_modified_type (t : typ) : bool =
- match unrollType t with
- | TArray(t', osize, _) -> begin
+ match unrollTypeNode t with
+ | TArray(t', osize) -> begin
match osize with
| None -> is_variably_modified_type t'
| Some s ->
@@ -6844,20 +6865,21 @@ let rec is_variably_modified_type (t : typ) : bool =
(* GCC supports VLA fields as an extension; if we ever support it,
add extra code here to take them into account *)
false
- | TVoid _ | TInt _ | TEnum _ | TFloat _
- | TPtr _ | TFun _ | TNamed _ | TBuiltin_va_list _ -> false
+ | TVoid | TInt _ | TEnum _ | TFloat _
+ | TPtr _ | TFun _ | TNamed _ | TBuiltin_va_list -> false
let is_mutable (lhost, offset) =
let rec aux can_mutate typ off =
let can_mutate = can_mutate && not (isConstType typ) in
- match unrollType typ, off with
+ let typ' = unrollType typ in
+ match typ'.tnode, off with
| _, NoOffset -> can_mutate
| _, Field (fi, off) ->
let can_mutate = can_mutate || hasAttribute frama_c_mutable fi.fattr in
aux can_mutate fi.ftype off
- | TArray(typ, _, _), Index(_, off) -> aux can_mutate typ off
- | typ, Index _ ->
- Kernel.fatal "Index on a non-array type '%a'" Cil_datatype.Typ.pretty typ
+ | TArray (typ, _), Index(_, off) -> aux can_mutate typ off
+ | _, Index _ ->
+ Kernel.fatal "Index on a non-array type '%a'" Cil_datatype.Typ.pretty typ'
in
aux false (typeOfLhost lhost) offset
@@ -6882,7 +6904,7 @@ let is_mutable_or_initialized lval =
let is_modifiable_lval lv =
let t = typeOfLval lv in
- match unrollType t with
+ match unrollTypeSkel t with
| TArray _ -> false
| TFun _ -> false
| _ -> (not (isConstType t)
@@ -7328,11 +7350,11 @@ let create_alpha_renaming old_args new_args =
(** Returns [true] whenever the type contains only arithmetic types *)
let is_fully_arithmetic ty =
not (existsType
- (fun typ -> match typ with
+ (fun typ -> match typ.tnode with
| TNamed _
| TComp _
| TArray _ -> ExistsMaybe
- | TPtr _ | TBuiltin_va_list _ | TFun _ | TVoid _ -> ExistsTrue
+ | TPtr _ | TBuiltin_va_list | TFun _ | TVoid -> ExistsTrue
| TEnum _ |TFloat _ | TInt _ -> ExistsFalse)
ty)
@@ -7411,23 +7433,25 @@ class dropAttributes ?select () = object(self)
(match a with
| (Attr (s,_) | AttrAnnot s) when List.mem s l -> ChangeTo []
| Attr _ | AttrAnnot _ -> DoChildren)
- method! vtype ty = match ty with
- | TNamed (internal_ty, attrs) ->
- let tty = typeAddAttributes attrs internal_ty.ttype in
+ method! vtype ty = match ty.tnode with
+ | TNamed internal_ty ->
+ let tty = typeAddAttributes ty.tattr internal_ty.ttype in
(* keep the original type whenever possible *)
ChangeToPost
(visitCilType (self:>cilVisitor) tty,
fun x -> if x == internal_ty.ttype then ty else x)
- | TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
- | TComp _ | TEnum _ | TBuiltin_va_list _ -> DoChildren
+ | TVoid | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
+ | TComp _ | TEnum _ | TBuiltin_va_list -> DoChildren
end
let typeDeepDropAllAttributes t =
let vis = new dropAttributes () in
visitCilType vis t
-(*
-Local Variables:
-compile-command: "make -C ../../.."
-End:
-*)
+(******************************************************************************)
+(** Deprecated typ manipulation *)
+(******************************************************************************)
+
+let typeAttr { tattr } = tattr
+
+let setTypeAttrs t tattr = { t with tattr }
diff --git a/src/kernel_services/ast_queries/cil.mli b/src/kernel_services/ast_queries/cil.mli
index 599e2c668e1..dc335469209 100644
--- a/src/kernel_services/ast_queries/cil.mli
+++ b/src/kernel_services/ast_queries/cil.mli
@@ -324,10 +324,16 @@ val has_flexible_array_member: typ -> bool
@before 24.0-Chromium this function didn't take in account the GCC/MSVC mode
*)
-(** Unroll a type until it exposes a non
- [TNamed]. Will collect all attributes appearing in [TNamed]!!! *)
+(** Unroll a type until it exposes a non [TNamed]. Will collect all attributes
+ appearing in [TNamed] and add them to the final type using
+ {!Cil.typeAddAttributes}. *)
val unrollType: typ -> typ
+(** Same than {!Cil.unrollType} but discard the final type attributes and only
+ return its node.
+ @since Frama-c+Dev *)
+val unrollTypeNode: typ -> typ_node
+
(** Unroll all the TNamed in a type (even under type constructors such as
[TPtr], [TFun] or [TArray]. Does not unroll the types of fields in [TComp]
types. Will collect all attributes *)
@@ -1464,14 +1470,8 @@ val findAttribute: string -> attribute list -> attrparam list
of the type structure, in case of composite, enumeration and named types *)
val typeAttrs: typ -> attribute list
-(** Returns the attributes of a type. *)
-val typeAttr: typ -> attribute list
-
-(** Sets the attributes of the type to the given list. Previous attributes
- are discarded. *)
-val setTypeAttrs: typ -> attributes -> typ
-
-(** Add some attributes to a type.
+(** Add some attributes to a type. Qualifiers attributes are recursively pushed
+ into array elements type until a non-array type is found.
[combine] explains how to combine attributes. Default is [addAttributes].
@before 28.0-Nickel [combine] does not exist *)
@@ -2463,6 +2463,17 @@ val set_extension_handler:
@before 30.0-Zinc This function did not take a [plugin:string] parameter
*)
+(** Returns the attributes of a type.
+ @deprecated Frama-C+dev *)
+val typeAttr: typ -> attribute list
+[@@alert deprecated "Use [t.tattr] instead."]
+
+(** Sets the attributes of the type to the given list. Previous attributes
+ are discarded.
+ @deprecated Frama-C+dev *)
+val setTypeAttrs: typ -> attributes -> typ
+[@@alert deprecated "Use [{t with tattr = ...}] instead."]
+
(*
Local Variables:
compile-command: "make -C ../../.."
diff --git a/src/kernel_services/ast_queries/cil_builtins.ml b/src/kernel_services/ast_queries/cil_builtins.ml
index d12e5ddc27e..46eb4bc7103 100644
--- a/src/kernel_services/ast_queries/cil_builtins.ml
+++ b/src/kernel_services/ast_queries/cil_builtins.ml
@@ -256,41 +256,41 @@ let build_type_table () : (string, typ option) Hashtbl.t =
let uint16_t = try Some (Cil.uint16_t ()) with Not_found -> None in
let uint32_t = try Some (Cil.uint32_t ()) with Not_found -> None in
let uint64_t = try Some (Cil.uint64_t ()) with Not_found -> None in
- let ptr_of = Option.map (fun t -> TPtr(t,[])) in
- let volatile_ptr_of = Option.map (fun t -> TPtr(typeAddVolatile t,[])) in
+ let ptr_of = Option.map (fun t -> Cil_const.mk_tptr t) in
+ let volatile_ptr_of = Option.map (fun t -> Cil_const.mk_tptr (typeAddVolatile t)) in
let types =
[
("__builtin_va_list",
Some (if Machine.has_builtin_va_list ()
- then TBuiltin_va_list []
+ then Cil_const.mk_tbuiltin ()
else Cil_const.voidPtrType));
("char *", Some Cil_const.charPtrType);
("char const *", Some Cil_const.charConstPtrType);
("double", Some Cil_const.doubleType);
- ("double *", Some (TPtr(Cil_const.doubleType,[])));
+ ("double *", Some Cil_const.(mk_tptr doubleType));
("float", Some Cil_const.floatType);
- ("float *", Some (TPtr(Cil_const.floatType,[])));
+ ("float *", Some Cil_const.(mk_tptr floatType));
("int", Some Cil_const.intType);
("int *", Some Cil_const.intPtrType);
- ("int volatile *", Some (TPtr(typeAddVolatile Cil_const.intType,[])));
+ ("int volatile *", Some Cil_const.(mk_tptr (typeAddVolatile intType)));
("long", Some Cil_const.longType);
("long double", Some Cil_const.longDoubleType);
- ("long double *", Some (TPtr(Cil_const.longDoubleType,[])));
+ ("long double *", Some Cil_const.(mk_tptr longDoubleType));
("long long", Some Cil_const.longLongType);
- ("long long volatile *", Some (TPtr(typeAddVolatile Cil_const.longLongType,[])));
+ ("long long volatile *", Some Cil_const.(mk_tptr (typeAddVolatile longLongType)));
("short", Some Cil_const.shortType);
- ("short volatile *", Some (TPtr(typeAddVolatile Cil_const.shortType,[])));
+ ("short volatile *", Some Cil_const.(mk_tptr (typeAddVolatile shortType)));
("signed char", Some Cil_const.scharType);
- ("signed char volatile *", Some (TPtr(typeAddVolatile Cil_const.scharType,[])));
+ ("signed char volatile *", Some Cil_const.(mk_tptr (typeAddVolatile scharType)));
("unsigned char", Some Cil_const.ucharType);
- ("unsigned char volatile *", Some (TPtr(typeAddVolatile Cil_const.ucharType,[])));
+ ("unsigned char volatile *", Some Cil_const.(mk_tptr (typeAddVolatile ucharType)));
("unsigned int", Some Cil_const.uintType);
- ("unsigned int volatile *", Some (TPtr(typeAddVolatile Cil_const.uintType,[])));
+ ("unsigned int volatile *", Some Cil_const.(mk_tptr (typeAddVolatile uintType)));
("unsigned long", Some Cil_const.ulongType);
("unsigned long long", Some Cil_const.ulongLongType);
- ("unsigned long long volatile *", Some (TPtr(typeAddVolatile Cil_const.ulongLongType,[])));
+ ("unsigned long long volatile *", Some Cil_const.(mk_tptr (typeAddVolatile ulongLongType)));
("unsigned short", Some Cil_const.ushortType);
- ("unsigned short volatile *", Some (TPtr(typeAddVolatile Cil_const.ushortType,[])));
+ ("unsigned short volatile *", Some Cil_const.(mk_tptr (typeAddVolatile ushortType)));
("void", Some Cil_const.voidType);
("void *", Some Cil_const.voidPtrType);
("void const *", Some Cil_const.voidConstPtrType);
diff --git a/src/kernel_services/ast_queries/cil_const.ml b/src/kernel_services/ast_queries/cil_const.ml
index 019ba5281b3..bb1b53f1429 100644
--- a/src/kernel_services/ast_queries/cil_const.ml
+++ b/src/kernel_services/ast_queries/cil_const.ml
@@ -46,34 +46,51 @@ open Cil_types
(* Types *)
-let voidType = TVoid([])
-let boolType = TInt(IBool,[])
-let intType = TInt(IInt,[])
-let uintType = TInt(IUInt,[])
-let shortType = TInt(IShort, [])
-let ushortType = TInt(IUShort, [])
-let longType = TInt(ILong,[])
-let longLongType = TInt(ILongLong,[])
-let ulongType = TInt(IULong,[])
-let ulongLongType = TInt(IULongLong, [])
-let charType = TInt(IChar, [])
-let scharType = TInt(ISChar, [])
-let ucharType = TInt(IUChar, [])
-
-let charPtrType = TPtr(charType,[])
-let scharPtrType = TPtr(scharType,[])
-let ucharPtrType = TPtr(ucharType,[])
-let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[])
-
-let voidPtrType = TPtr(voidType, [])
-let voidConstPtrType = TPtr(TVoid [Attr ("const", [])], [])
-
-let intPtrType = TPtr(intType, [])
-let uintPtrType = TPtr(uintType, [])
-
-let doubleType = TFloat(FDouble, [])
-let floatType = TFloat(FFloat, [])
-let longDoubleType = TFloat (FLongDouble, [])
+let mk_typ ?(tattr=[]) tnode = { tnode; tattr }
+
+let mk_tvoid ?tattr () = mk_typ ?tattr TVoid
+let mk_tint ?tattr ik = mk_typ ?tattr (TInt ik)
+let mk_tfloat ?tattr fk = mk_typ ?tattr (TFloat fk)
+let mk_tptr ?tattr t = mk_typ ?tattr (TPtr t )
+let mk_tarray ?tattr t len = mk_typ ?tattr (TArray (t, len))
+let mk_tfun ?tattr f args va = mk_typ ?tattr (TFun (f, args, va))
+let mk_tnamed ?tattr ti = mk_typ ?tattr (TNamed ti)
+let mk_tcomp ?tattr ci = mk_typ ?tattr (TComp ci)
+let mk_tenum ?tattr ei = mk_typ ?tattr (TEnum ei)
+let mk_tbuiltin ?tattr () = mk_typ ?tattr TBuiltin_va_list
+
+let voidType = mk_tvoid ()
+let boolType = mk_tint IBool
+let intType = mk_tint IInt
+let uintType = mk_tint IUInt
+let shortType = mk_tint IShort
+let ushortType = mk_tint IUShort
+let longType = mk_tint ILong
+let longLongType = mk_tint ILongLong
+let ulongType = mk_tint IULong
+let ulongLongType = mk_tint IULongLong
+let charType = mk_tint IChar
+let scharType = mk_tint ISChar
+let ucharType = mk_tint IUChar
+
+let charPtrType = mk_tptr charType
+let scharPtrType = mk_tptr scharType
+let ucharPtrType = mk_tptr ucharType
+let charConstPtrType =
+ let charConst = mk_tint ~tattr:[Attr ("const", [])] IChar in
+ mk_tptr charConst
+
+let voidPtrType = mk_tptr voidType
+let voidConstPtrType =
+ let voidConst = mk_tvoid ~tattr:[Attr ("const", [])] () in
+ mk_tptr voidConst
+
+let intPtrType = mk_tptr intType
+let uintPtrType = mk_tptr uintType
+
+let doubleType = mk_tfloat FDouble
+let floatType = mk_tfloat FFloat
+let longDoubleType = mk_tfloat FLongDouble
module Vid = State_builder.SharedCounter(struct let name = "vid_counter" end)
module Sid = State_builder.SharedCounter(struct let name = "sid" end)
diff --git a/src/kernel_services/ast_queries/cil_const.mli b/src/kernel_services/ast_queries/cil_const.mli
index 58007d81a2f..5a12d467ca2 100644
--- a/src/kernel_services/ast_queries/cil_const.mli
+++ b/src/kernel_services/ast_queries/cil_const.mli
@@ -45,6 +45,62 @@
(** Smart constructors for some CIL data types *)
open Cil_types
+(** Create a typ record, [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_typ : ?tattr:attributes -> typ_node -> typ
+
+(** Create a typ record [TVoid], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tvoid : ?tattr:attributes -> unit -> typ
+
+(** Create a typ record [TInt ik], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tint : ?tattr:attributes -> ikind -> typ
+
+(** Create a typ record [TFloat fk], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tfloat : ?tattr:attributes -> fkind -> typ
+
+(** Create a typ record [TPtr t], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tptr : ?tattr:attributes -> typ -> typ
+
+(** Create a typ record [TArray (t, len)], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tarray : ?tattr:attributes -> typ -> exp option -> typ
+
+(** Create a typ record [TFun (rt, args, is_va)], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tfun : ?tattr:attributes -> typ ->
+ (string * typ * attributes) list option -> bool -> typ
+
+(** Create a typ record [TNamed ti], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tnamed : ?tattr:attributes -> typeinfo -> typ
+
+(** Create a typ record [TComp ci], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tcomp : ?tattr:attributes -> compinfo -> typ
+
+(** Create a typ record [TEnum ei], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tenum : ?tattr:attributes -> enuminfo -> typ
+
+(** Create a typ record [TBuiltin_va_list], [tattr] defaults to empty list.
+ @since Frama-C+dev
+*)
+val mk_tbuiltin : ?tattr:attributes -> unit -> typ
+
(** void *)
val voidType: typ
diff --git a/src/kernel_services/ast_queries/cil_datatype.ml b/src/kernel_services/ast_queries/cil_datatype.ml
index 581b4d7c118..30cbd6c1509 100644
--- a/src/kernel_services/ast_queries/cil_datatype.ml
+++ b/src/kernel_services/ast_queries/cil_datatype.ml
@@ -380,8 +380,9 @@ let index_attrparam = function
| AIndex _ -> 14
| AQuestion _ -> 15
-let index_typ = function
- | TVoid _ -> 0
+let index_typ t =
+ match t.tnode with
+ | TVoid -> 0
| TInt _ -> 1
| TFloat _ -> 2
| TPtr _ -> 3
@@ -390,7 +391,7 @@ let index_typ = function
| TNamed _ -> 6
| TComp _ -> 7
| TEnum _ -> 8
- | TBuiltin_va_list _ -> 9
+ | TBuiltin_va_list -> 9
let constfoldtoint = Extlib.mk_fun "constfoldtoint"
let punrollType = Extlib.mk_fun "punrollType"
@@ -476,51 +477,46 @@ and compare_array_sizes e1o e2o =
and compare_type config t1 t2 =
if t1 == t2 then 0
else
- let typs =
+ let t1, t2 =
if config.unroll then !punrollType t1, !punrollType t2
else t1,t2
in
- match typs with
- | TVoid l1, TVoid l2 -> compare_attributes config l1 l2
- | TInt (i1, l1), TInt (i2, l2) ->
- compare_chain (=?=) i1 i2 (compare_attributes config) l1 l2
- | TFloat (f1, l1), TFloat (f2, l2) ->
- compare_chain (=?=) f1 f2 (compare_attributes config) l1 l2
- | TPtr (t1, l1), TPtr (t2, l2) ->
- compare_chain
- (compare_type config) t1 t2
- (compare_attributes config) l1 l2
- | TArray (t1', e1, l1), TArray (t2', e2, l2) ->
+ let comp_tattr () = compare_attributes config t1.tattr t2.tattr in
+ let compare_chain_tattr cmp x1 x2 =
+ let res = cmp x1 x2 in if res = 0 then comp_tattr () else res
+ in
+ match t1.tnode, t2.tnode with
+ | TVoid, TVoid -> comp_tattr ()
+ | TInt i1, TInt i2 ->
+ compare_chain_tattr (=?=) i1 i2
+ | TFloat f1, TFloat f2 ->
+ compare_chain_tattr (=?=) f1 f2
+ | TPtr t1, TPtr t2 ->
+ compare_chain_tattr (compare_type config) t1 t2
+ | TArray (t1', e1), TArray (t2', e2) ->
compare_chain compare_array_sizes e1 e2
- (compare_chain
- (compare_type config) t1' t2'
- (compare_attributes config)) l1 l2
- | TFun (r1, a1, v1, l1), TFun (r2, a2, v2, l2) ->
+ (compare_chain_tattr (compare_type config)) t1' t2'
+ | TFun (r1, a1, v1), TFun (r2, a2, v2) ->
compare_chain (compare_type config) r1 r2
(compare_chain (=?=) v1 v2
- (compare_chain (compare_arg_list config) a1 a2
- (compare_attributes config))) l1 l2
- | TNamed (t1,a1), TNamed (t2,a2) ->
+ (compare_chain_tattr (compare_arg_list config))) a1 a2
+ | TNamed t1, TNamed t2 ->
assert (not config.unroll);
- compare_chain (=?=) t1.tname t2.tname
- (compare_attributes config) a1 a2
- | TComp (c1, l1), TComp (c2, l2) ->
+ compare_chain_tattr (=?=) t1.tname t2.tname
+ | TComp c1, TComp c2 ->
let res =
if config.by_name
then (=?=) c1.cname c2.cname
else (=?=) c1.ckey c2.ckey
in
if res <> 0 then res
- else compare_attributes config l1 l2
- | TEnum (e1, l1), TEnum (e2, l2) ->
- compare_chain
- (=?=) e1.ename e2.ename
- (compare_attributes config) l1 l2
- | TBuiltin_va_list l1, TBuiltin_va_list l2 ->
- compare_attributes config l1 l2
- | (TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ |
- TComp _ | TEnum _ | TBuiltin_va_list _ as a1), a2 ->
- index_typ a1 - index_typ a2
+ else comp_tattr ()
+ | TEnum e1, TEnum e2 ->
+ compare_chain_tattr (=?=) e1.ename e2.ename
+ | TBuiltin_va_list, TBuiltin_va_list -> comp_tattr ()
+ | (TVoid | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ |
+ TComp _ | TEnum _ | TBuiltin_va_list), _ ->
+ index_typ t1 - index_typ t2
and compare_arg_list config l1 l2 =
Option.compare
@@ -540,26 +536,27 @@ let hash_attributes config l =
let rec hash_type config t =
let t = if config.unroll then !punrollType t else t in
- match t with
- | TVoid l -> Hashtbl.hash (hash_attributes config l, 1)
- | TInt (i, l) -> Hashtbl.hash (i, 2, hash_attributes config l)
- | TFloat (f, l) -> Hashtbl.hash (f, 3, hash_attributes config l)
- | TPtr (t, l) ->
- Hashtbl.hash (hash_type config t, 4, hash_attributes config l)
- | TArray (t, _, l) ->
- Hashtbl.hash (hash_type config t, 5, hash_attributes config l)
- | TFun (r, a, v, l) ->
+ let tattr_hash = hash_attributes config t.tattr in
+ match t.tnode with
+ | TVoid -> Hashtbl.hash (tattr_hash, 1)
+ | TInt i -> Hashtbl.hash (i, 2, tattr_hash)
+ | TFloat f -> Hashtbl.hash (f, 3, tattr_hash)
+ | TPtr t ->
+ Hashtbl.hash (hash_type config t, 4, tattr_hash)
+ | TArray (t, _) ->
+ Hashtbl.hash (hash_type config t, 5, tattr_hash)
+ | TFun (r, a, v) ->
Hashtbl.hash
- (hash_type config r, 6, hash_args config a, v, hash_attributes config l)
- | TNamed (ti, l) ->
- Hashtbl.hash (ti.tname, 7, hash_attributes config l)
- | TComp (c, l) ->
+ (hash_type config r, 6, hash_args config a, v, tattr_hash)
+ | TNamed ti ->
+ Hashtbl.hash (ti.tname, 7, tattr_hash)
+ | TComp c ->
Hashtbl.hash
((if config.by_name then Hashtbl.hash c.cname else c.ckey), 8,
- hash_attributes config l)
- | TEnum (e, l) ->
- Hashtbl.hash (e.ename, 9, hash_attributes config l)
- | TBuiltin_va_list l -> Hashtbl.hash (hash_attributes config l, 10)
+ tattr_hash)
+ | TEnum e ->
+ Hashtbl.hash (e.ename, 9, tattr_hash)
+ | TBuiltin_va_list -> Hashtbl.hash (tattr_hash, 10)
and hash_args config = function
| None -> 11713
| Some l ->
@@ -599,7 +596,7 @@ struct
(struct
type t = typ
let name = M.name
- let reprs = [ TVoid [] ]
+ let reprs = [ { tnode = TVoid; tattr = [] } ]
let compare = compare_type M.config
let hash = hash_type M.config
let equal = Datatype.from_compare
@@ -617,17 +614,6 @@ module Typ= struct
unroll = true; no_attrs = false}
let name = "Typ"
end)
- let toplevel_attr = function
- | TVoid a -> a
- | TInt (_, a) -> a
- | TFloat (_, a) -> a
- | TNamed (_, a) -> a
- | TPtr (_, a) -> a
- | TArray (_, _,a) -> a
- | TComp (_, a) -> a
- | TEnum (_, a) -> a
- | TFun (_, _, _, a) -> a
- | TBuiltin_va_list a -> a
end
module TypByName =
@@ -664,7 +650,7 @@ module Typeinfo =
let reprs =
[ { torig_name = "";
tname = "";
- ttype = TVoid [];
+ ttype = { tnode = TVoid; tattr = [] };
treferenced = false } ]
let compare v1 v2 = String.compare v1.tname v2.tname
let hash v = Hashtbl.hash v.tname
@@ -729,7 +715,7 @@ module Varinfo_Id = struct
let dummy =
{ vname = "";
vorig_name = "";
- vtype = TVoid [];
+ vtype = { tnode = TVoid; tattr = [] };
vattr = [];
vstorage = NoStorage;
vglob = false;
@@ -953,26 +939,26 @@ struct
(* Return true if the types have the same size, machine-indepently *)
let rec compare_structural_typ_size (t1 : typ) (t2 : typ) : int =
- match !punrollType t1, !punrollType t2 with
- | TPtr (t1, _), TPtr (t2, _) when
- (match t1, t2 with
- | (TVoid _ | TInt ((IChar | ISChar | IUChar) , _)),
- (TVoid _ | TInt ((IChar | ISChar | IUChar) , _)) -> true
+ match (!punrollType t1).tnode, (!punrollType t2).tnode with
+ | TPtr t1, TPtr t2 when
+ (match t1.tnode, t2.tnode with
+ | (TVoid | TInt (IChar | ISChar | IUChar)),
+ (TVoid | TInt (IChar | ISChar | IUChar)) -> true
| _ -> false) ->
(* Void and characters pointers have the same size.
ISO.6.2.5.28 *)
0
- | TPtr (TComp (comp1, _), _), TPtr (TComp (comp2, _), _)
+ | TPtr { tnode = TComp comp1 }, TPtr { tnode = TComp comp2 }
when comp1.cstruct = comp2.cstruct ->
(* Struct pointers have the same size.
Union pointers have the same size.
ISO.6.2.5.28 *)
0
- | TPtr (t1, _), TPtr (t2, _) ->
+ | TPtr t1, TPtr t2 ->
(* Pointers aren't force to have the same size. Depends on the type.
ISO.6.2.5.28 *)
Typ.compare t1 t2
- | TComp (c1, _), TComp (c2, _) ->
+ | TComp c1, TComp c2 ->
(* Struct/union's id are not necessarily unified.
We structurally compare them. *)
begin
@@ -2394,7 +2380,7 @@ module Global = struct
let attr = function
| GVar (vi,_,_) | GFun ({svar = vi},_) | GVarDecl (vi,_) | GFunDecl (_,vi,_)->
vi.vattr
- | GType (t,_) -> Typ.toplevel_attr t.ttype
+ | GType (t,_) -> t.ttype.tattr
| GCompTag(ci,_) | GCompTagDecl(ci,_) -> ci.cattr
| GEnumTag(ei,_) | GEnumTagDecl(ei,_) -> ei.eattr
| GAnnot (g,_) -> Global_annotation.attr g
diff --git a/src/kernel_services/ast_queries/cil_datatype.mli b/src/kernel_services/ast_queries/cil_datatype.mli
index 9b64f68a203..e3923f1ea0e 100644
--- a/src/kernel_services/ast_queries/cil_datatype.mli
+++ b/src/kernel_services/ast_queries/cil_datatype.mli
@@ -254,13 +254,7 @@ module Attributes: S_with_collections with type t = attributes
(** Types, with comparison over struct done by key and unrolling of typedefs. *)
-module Typ: sig
- include S_with_collections_pretty with type t = typ
- val toplevel_attr: t -> attributes
- (** returns the attributes associated to the toplevel type, without adding
- attributes from compinfo, enuminfo or typeinfo. Use {!Cil.typeAttrs}
- to retrieve the complete set of attributes. *)
-end
+module Typ: S_with_collections_pretty with type t = typ
(** Types, with comparison over struct done by name and no unrolling. *)
module TypByName: S_with_collections_pretty with type t = typ
diff --git a/src/kernel_services/ast_queries/file.ml b/src/kernel_services/ast_queries/file.ml
index b866e935d55..c663a3524be 100644
--- a/src/kernel_services/ast_queries/file.ml
+++ b/src/kernel_services/ast_queries/file.ml
@@ -1428,13 +1428,13 @@ class reorder_ast: Visitor.frama_c_visitor =
*)
method! vtype ty =
- (match ty with
- | TVoid _ | TInt _ | TFloat _ | TPtr _
- | TFun _ | TBuiltin_va_list _ | TArray _ -> ()
+ (match ty.tnode with
+ | TVoid | TInt _ | TFloat _ | TPtr _
+ | TFun _ | TBuiltin_va_list | TArray _ -> ()
- | TNamed (ty,_) ->
- let g = find_typeinfo ty in
- if not (Cil_datatype.Typeinfo.Set.mem ty known_typeinfo) then begin
+ | TNamed ti ->
+ let g = find_typeinfo ti in
+ if not (Cil_datatype.Typeinfo.Set.mem ti known_typeinfo) then begin
self#add_needed_decl g;
Stack.push g typedefs;
Stack.push true subvisit;
@@ -1449,14 +1449,14 @@ class reorder_ast: Visitor.frama_c_visitor =
Kernel.fatal
"Globals' reordering failed: \
recursive definition of type %s"
- ty.tname)
+ ti.tname)
typedefs
- | TComp(ci,_) ->
+ | TComp ci ->
if not (Cil_datatype.Compinfo.Set.mem ci known_compinfo) then begin
self#add_needed_decl(GCompTagDecl(ci,Cil_datatype.Location.unknown));
self#add_known_compinfo ci
end
- | TEnum(ei,_) ->
+ | TEnum ei ->
if not (Cil_datatype.Enuminfo.Set.mem ei known_enuminfo) then begin
self#add_needed_decl(GEnumTagDecl(ei,Cil_datatype.Location.unknown));
self#add_known_enuminfo ei
diff --git a/src/kernel_services/ast_queries/filecheck.ml b/src/kernel_services/ast_queries/filecheck.ml
index 0a33fbce649..8f8ec74a4f9 100644
--- a/src/kernel_services/ast_queries/filecheck.ml
+++ b/src/kernel_services/ast_queries/filecheck.ml
@@ -25,8 +25,8 @@ open Cil_datatype
let same_integral_types t1 t2 =
- match Cil.unrollType t1, Cil.unrollType t2 with
- | TInt(ik1,[]), TInt(ik2,[]) ->
+ match Cil.unrollTypeNode t1, Cil.unrollTypeNode t2 with
+ | TInt ik1, TInt ik2 ->
Cil.bitsSizeOfInt ik1 = Cil.bitsSizeOfInt ik2 &&
Cil.isSigned ik1 = Cil.isSigned ik2
| _ -> false
@@ -36,8 +36,8 @@ let is_admissible_conversion e ot nt =
let nt' = Cil.typeDeepDropAllAttributes nt in
not (Cil.need_cast ot' nt') ||
same_integral_types ot' nt' ||
- (match e.enode, Cil.unrollType nt with
- | Const(CEnum { eihost = ei }), TEnum(ei',_) -> ei.ename = ei'.ename
+ (match e.enode, Cil.unrollTypeNode nt with
+ | Const(CEnum { eihost = ei }), TEnum ei' -> ei.ename = ei'.ename
| _ -> false)
let pretty_logic_var_kind fmt = function
@@ -1322,15 +1322,15 @@ module Base_checker = struct
| _ -> Cil.DoChildren
method! vtype ty =
- match ty with
- | TArray (_, _, la) ->
- let elt, _ = Cil.splitArrayAttributes la in
+ match ty.tnode with
+ | TArray _ ->
+ let elt, _ = Cil.splitArrayAttributes ty.tattr in
if elt != [] then
Kernel.fatal
"Element attribute on array type itself: %a"
Printer.pp_attributes elt;
Cil.DoChildren
- | TFun(rt, _, _, attrs) ->
+ | TFun(rt, _, _) ->
(* we do not visit parameters. This is handled elsewhere, and it
is not possible to perform a sensible check for dependent types
at this level, e.g. for
@@ -1340,7 +1340,7 @@ module Base_checker = struct
arr[10][n] is well formed.
*)
ignore (Cil.visitCilType (self:>Cil.cilVisitor) rt);
- ignore (Cil.visitCilAttributes (self:>Cil.cilVisitor) attrs);
+ ignore (Cil.visitCilAttributes (self:>Cil.cilVisitor) ty.tattr);
Cil.SkipChildren
| _ -> Cil.DoChildren
diff --git a/src/kernel_services/ast_queries/logic_const.ml b/src/kernel_services/ast_queries/logic_const.ml
index d68f15cafd5..eef7a520d52 100644
--- a/src/kernel_services/ast_queries/logic_const.ml
+++ b/src/kernel_services/ast_queries/logic_const.ml
@@ -307,7 +307,7 @@ let treal_zero ?(loc=Cil_datatype.Location.unknown) ?(ltyp=Lreal) () =
let tstring ?(loc=Cil_datatype.Location.unknown) s =
(* Cannot refer to Cil_const.charConstPtrType in this module... *)
- let typ = TPtr(TInt(IChar, [Attr("const", [])]),[]) in
+ let typ = Cil_const.(mk_tptr (mk_tint ~tattr:[Attr("const", [])] IChar)) in
term ~loc (TConst (LStr s)) (Ctype typ)
let tat ?(loc=Cil_datatype.Location.unknown) (t,label) =
diff --git a/src/kernel_services/ast_queries/logic_env.ml b/src/kernel_services/ast_queries/logic_env.ml
index 8005b366b9f..1a025f318d7 100644
--- a/src/kernel_services/ast_queries/logic_env.ml
+++ b/src/kernel_services/ast_queries/logic_env.ml
@@ -324,8 +324,8 @@ let find_model_field s typ =
unrollType will unroll until it finds something other
than TNamed. We want to go step by step.
*)
- (match typ with
- | TNamed(ti,_) -> find_cons ti.ttype
+ (match typ.tnode with
+ | TNamed ti -> find_cons ti.ttype
| _ -> raise e)
in find_cons typ
diff --git a/src/kernel_services/ast_queries/logic_to_c.ml b/src/kernel_services/ast_queries/logic_to_c.ml
index 2d8abd63a29..f75aef98fac 100644
--- a/src/kernel_services/ast_queries/logic_to_c.ml
+++ b/src/kernel_services/ast_queries/logic_to_c.ml
@@ -29,10 +29,10 @@ let error_lval () = raise No_conversion
let rec logic_type_to_typ = function
| Ctype typ -> typ
- | Linteger -> TInt(ILongLong,[]) (*TODO: to have an unlimited integer type
- in the logic interpretation*)
- | Lreal -> TFloat(FDouble,[]) (* TODO: handle reals, not floats... *)
- | Lboolean -> TInt(ILongLong,[])
+ | Linteger -> Cil_const.longLongType (*TODO: to have an unlimited integer type
+ in the logic interpretation*)
+ | Lreal -> Cil_const.doubleType (* TODO: handle reals, not floats... *)
+ | Lboolean -> Cil_const.longLongType
| Ltype({lt_name = "set"},[t]) -> logic_type_to_typ t
| Ltype _ | Lvar _ | Larrow _ -> error_lval ()
@@ -142,7 +142,7 @@ and loc_to_exp ?result {term_node = lnode ; term_type = ltype; term_loc = loc} =
Logic_utils.is_same_type
(Logic_typing.type_of_set_elem set) t.term_type ->
loc_to_exp ?result t
- | Tnull -> [ Cil.mkCast ~newt:(TPtr(TVoid [], [])) (Cil.zero ~loc) ]
+ | Tnull -> [ Cil.mkCast ~newt:(Cil_const.voidPtrType) (Cil.zero ~loc) ]
(* additional constructs *)
| Tapp _ | Tlambda _ | Trange _ | Tlet _
diff --git a/src/kernel_services/ast_queries/logic_typing.ml b/src/kernel_services/ast_queries/logic_typing.ml
index e5b91cea2bc..f201b14cc3e 100644
--- a/src/kernel_services/ast_queries/logic_typing.ml
+++ b/src/kernel_services/ast_queries/logic_typing.ml
@@ -885,8 +885,8 @@ struct
let check_fun_ptr loc ty =
let is_fun_ptr t =
- match Cil.unrollType t with
- | TPtr(t,_) when Cil.isFunctionType t -> true
+ match Cil.unrollTypeNode t with
+ | TPtr t when Cil.isFunctionType t -> true
| _ -> false
in
if not (Logic_utils.isLogicType is_fun_ptr ty) then
@@ -895,8 +895,8 @@ struct
let check_object_ptr loc ty =
let is_object_ptr t =
- match Cil.unrollType t with
- | TPtr(t,_) when not (Cil.isFunctionType t) -> true
+ match Cil.unrollTypeNode t with
+ | TPtr t when not (Cil.isFunctionType t) -> true
| _ -> false
in
if not (Logic_utils.isLogicType is_object_ptr ty) then
@@ -919,19 +919,19 @@ struct
try
ignore (Logic_env.find_model_field f ty); true
with Not_found ->
- (match Cil.unrollType ty with
- | TComp(comp,_) ->
+ (match Cil.unrollTypeNode ty with
+ | TComp ci ->
List.exists
(fun x -> x.fname = f)
- (Option.value ~default:[] comp.cfields)
+ (Option.value ~default:[] ci.cfields)
| _ -> false)
let plain_type_of_c_field loc f ty =
match Cil.unrollType ty with
- | TComp (comp, attrs) ->
+ | { tnode = TComp ci; tattr } ->
(try
- let attrs = Cil.filter_qualifier_attributes attrs in
- let field = C.find_comp_field comp f in
+ let attrs = Cil.filter_qualifier_attributes tattr in
+ let field = C.find_comp_field ci f in
let typ = Cil.typeOffset ty field in
Logic_utils.offset_to_term_offset field,
Ctype (Cil.typeAddAttributes attrs typ)
@@ -956,7 +956,7 @@ struct
let offs,typ = plain_type_of_field loc f t in offs, Ltype(lt,[typ])
| t -> type_of_c_field loc f t
- let c_void_star = Ctype (TPtr (TVoid [], []))
+ let c_void_star = Ctype Cil_const.voidPtrType
(* keep in sync with fresh_type below *)
let generated_var s = String.contains s '#'
@@ -1053,9 +1053,9 @@ struct
let ltype t = ctxt.logic_type ctxt loc env t in
let ctype t = ltype t |> c_type_of loc in
match t with
- | LTvoid -> Ctype (TVoid [])
- | LTint ikind -> Ctype (TInt (ikind, []))
- | LTfloat fkind -> Ctype (TFloat (fkind, []))
+ | LTvoid -> Ctype Cil_const.voidType
+ | LTint ikind -> Ctype (Cil_const.mk_tint ikind)
+ | LTfloat fkind -> Ctype (Cil_const.mk_tfloat fkind)
| LTarray (ty,length) ->
let size = match length with
@@ -1087,9 +1087,9 @@ struct
in size_exp size
with Not_found ->
ctxt.error loc "size of array must be an integral value";
- in Ctype (TArray (ctype ty, size,[]))
+ in Ctype (Cil_const.mk_tarray (ctype ty) size)
- | LTpointer ty -> Ctype (TPtr (ctype ty, []))
+ | LTpointer ty -> Ctype (Cil_const.mk_tptr (ctype ty))
| LTenum e ->
(try Ctype (ctxt.find_type Enum e)
with Not_found -> ctxt.error loc "no such enum %s" e)
@@ -1106,11 +1106,11 @@ struct
let rt = ctype rt in
begin
match prms with
- | [] -> Ctype (TFun(rt,None,false,[]))
+ | [] -> Ctype (Cil_const.mk_tfun rt None false)
| [(_,arg_typ,_)] when isVoidType arg_typ ->
(* Same invariant as in C *)
- Ctype (TFun(rt,Some [],false,[]))
- | _ -> Ctype (TFun(rt,Some prms,false,[]))
+ Ctype (Cil_const.mk_tfun rt (Some []) false)
+ | _ -> Ctype (Cil_const.mk_tfun rt (Some prms) false)
end
| LTnamed (id,[]) ->
@@ -1277,10 +1277,10 @@ struct
end else if isPointerType oldt && isArrayType newt then
(* transforms '(T[size])ptr' into an equivalent '*(T( * )[size])ptr'
to get an explicit access to the memory *)
- mk_mem (c_mk_cast ~force e oldt (TPtr(newt,[]))) TNoOffset
+ mk_mem (c_mk_cast ~force e oldt (Cil_const.mk_tptr newt)) TNoOffset
else begin
- match Cil.unrollType newt, e.term_node with
- | TEnum (ei,[]), TConst (LEnum { eihost = ei'})
+ match Cil.unrollTypeNode newt, e.term_node with
+ | TEnum ei, TConst (LEnum { eihost = ei'})
when ei.ename = ei'.ename && not force -> e
| _ ->
{ e with term_node =
@@ -1349,7 +1349,7 @@ struct
let is_enum_cst e t =
match e.term_node with
- | TConst (LEnum ei) -> is_same_type (Ctype (TEnum (ei.eihost,[]))) t
+ | TConst (LEnum ei) -> is_same_type (Ctype (Cil_const.mk_tenum ei.eihost)) t
| _ -> false
let logic_coerce t e =
@@ -1500,12 +1500,12 @@ struct
else
begin
Cil.checkCast ot nt;
- match Cil.unrollType ot, Cil.unrollType nt with
+ match Cil.unrollTypeNode ot, Cil.unrollTypeNode nt with
| TPtr _, TPtr _ when isVoidPtrType nt ->
nt, e
- | (TInt _ | TEnum _ | TPtr _ ), TVoid _ ->
+ | (TInt _ | TEnum _ | TPtr _ ), TVoid ->
ot, e
- | TComp (comp1, _), TComp (comp2, _) when comp1.ckey = comp2.ckey ->
+ | TComp comp1, TComp comp2 when comp1.ckey = comp2.ckey ->
nt, e
| _ -> nt, mk_cast e (Ctype nt)
end
@@ -1538,8 +1538,8 @@ struct
C.error loc "invalid implicit conversion from '%a' to '%a'"
Cil_printer.pp_typ ty1 Cil_printer.pp_typ ty2
end else if is_implicit_pointer_conversion oterm ty1 ty2
- || (match unrollType ty1, unrollType ty2 with
- | (TFloat (f1,_), TFloat (f2,_)) ->
+ || (match unrollTypeNode ty1, unrollTypeNode ty2 with
+ | TFloat f1, TFloat f2 ->
f1 <= f2
(*[BM]
relies on internal representation of OCaml constant
@@ -1853,8 +1853,8 @@ struct
| Linteger -> Linteger
| Lreal -> Lreal
| Ctype ty ->
- (match Cil.unrollType ty with
- TFloat _ -> Lreal
+ (match Cil.unrollTypeNode ty with
+ | TFloat _ -> Lreal
| _ ->
Kernel.fatal ~current:true
"logic arithmetic promotion on non-arithmetic type %a"
@@ -1941,10 +1941,10 @@ struct
| None -> lty1
| Some rel ->
let kind =
- match Cil.unrollType ty1 with
- | TFloat (FFloat,_) -> "float"
- | TFloat (FDouble,_) -> "double"
- | TFloat (FLongDouble,_) -> "long double"
+ match Cil.unrollTypeNode ty1 with
+ | TFloat FFloat -> "float"
+ | TFloat FDouble -> "double"
+ | TFloat FLongDouble -> "long double"
| _ -> Kernel.fatal "floating point type expected"
in
let source = fst loc in
@@ -2700,7 +2700,7 @@ struct
TConst (LStr (unescape s)), Ctype Cil_const.charPtrType
| PLconstant (WStringConstant s) ->
TConst (LWStr (wcharlist_of_string s)),
- Ctype (TPtr(Machine.wchar_type (),[]))
+ Ctype (Cil_const.mk_tptr (Machine.wchar_type ()))
| PLvar x ->
let old_val info =
let typ =
@@ -2736,7 +2736,7 @@ struct
*)
let lv = Lenv.find_var x env in
(match lv.lv_type with
- | Ctype (TVoid _)->
+ | Ctype ({ tnode = TVoid })->
if ctxt.silent then raise Backtrack;
ctxt.error (Current_loc.get())
"Variable %s is bound to a predicate, not a term" x
@@ -2752,9 +2752,9 @@ struct
lv.vreferenced <- true
| None -> ());
(match info.lv_type with
- | Ctype(TFun _ as t) ->
+ | Ctype ({ tnode = TFun _ } as t) ->
(* function decays as a pointer *)
- TAddrOf (TVar info, TNoOffset), Ctype (TPtr (t,[]))
+ TAddrOf (TVar info, TNoOffset), Ctype (Cil_const.mk_tptr t)
| _ -> old_val info)
with Not_found ->
try
diff --git a/src/kernel_services/ast_queries/logic_utils.ml b/src/kernel_services/ast_queries/logic_utils.ml
index edc587dddaf..100ead5d7f9 100644
--- a/src/kernel_services/ast_queries/logic_utils.ml
+++ b/src/kernel_services/ast_queries/logic_utils.ml
@@ -99,7 +99,7 @@ let logicCType t =
let plain_array_to_ptr ty =
let open Current_loc.Operators in
match unroll_type ty with
- | Ctype(TArray(ty,lo,attr) as tarr) ->
+ | Ctype({ tnode = TArray(ty,lo); tattr } as tarr) ->
let length_attr =
match lo with
| None -> []
@@ -122,7 +122,8 @@ let plain_array_to_ptr ty =
"Cannot represent length of array as an attribute";
[]
in
- Ctype(TPtr(ty, Cil.addAttributes length_attr attr))
+ let tattr = Cil.addAttributes length_attr tattr in
+ Ctype (Cil_const.mk_tptr ~tattr ty)
| ty -> ty
let array_to_ptr = plain_or_set plain_array_to_ptr
@@ -214,7 +215,7 @@ let rec mk_logic_StartOf t =
let mk_logic_AddrOf ?(loc=Cil_datatype.Location.unknown) lval typ =
let lift_set typ =
Logic_const.transform_element
- (fun typ -> (Ctype (TPtr (logicCType typ,[])))) typ
+ (fun typ -> Ctype (Cil_const.mk_tptr (logicCType typ))) typ
in
match lval with
| TMem e, TNoOffset -> Logic_const.term ~loc e.term_node e.term_type
@@ -324,7 +325,7 @@ let parse_float ?loc literal =
else real_of_parsed literal v in
let vreal = Logic_const.term ?loc (TConst(LReal creal)) Lreal in
if is_flt then
- let ty = TFloat(fk,[]) in
+ let ty = Cil_const.mk_tfloat fk in
Logic_const.term ?loc (TCast(false, Ctype ty,vreal)) (Ctype ty)
else vreal
@@ -342,12 +343,12 @@ let rec numeric_coerce ltyp t =
| TConst(LReal _ ) when ltyp = Lreal ->
{ t with term_type = Lreal }
| TCast (false, Ctype ty,e) ->
- begin match ltyp, Cil.unrollType ty, e.term_node with
- | Linteger, TInt(ik,_), TConst(Integer(v,_))
+ begin match ltyp, Cil.unrollTypeNode ty, e.term_node with
+ | Linteger, TInt ik, TConst(Integer(v,_))
when Cil.fitsInInt ik v -> { e with term_type = Linteger }
- | Lreal, TFloat(fk,_), TConst(LReal r)
+ | Lreal, TFloat fk, TConst(LReal r)
when Cil.isExactFloat fk r -> { e with term_type = Lreal }
- | Linteger, TInt(ik,_), TConst(LEnum { eival }) ->
+ | Linteger, TInt ik, TConst(LEnum { eival }) ->
( match Cil.constFoldToInt eival with
| Some i when Cil.fitsInInt ik i -> { e with term_type = Linteger }
| _ -> mk_coerce ltyp t )
@@ -380,8 +381,8 @@ and numeric_bound ltyp = function
let is_zero_comparable t =
match unroll_type t.term_type with
- | Ctype (TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TEnum _) -> true
- | Ctype (TVoid _ | TNamed _ | TComp _ | TBuiltin_va_list _) -> false
+ | Ctype { tnode = (TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TEnum _) } -> true
+ | Ctype { tnode = (TVoid | TNamed _ | TComp _ | TBuiltin_va_list) } -> false
| Linteger | Lreal | Lboolean -> true
| Ltype _ -> false
| Lvar _ | Larrow _ -> false
@@ -397,18 +398,18 @@ let scalar_term_conversion conversion t =
let bool_conversion t =
conversion ~loc true t (Logic_const.tboolean ~loc true) in
match unroll_type t.term_type with
- | Ctype (TInt _ | TEnum _) -> int_conversion t
- | Ctype (TFloat _) as ltyp -> real_conversion ~ltyp t
- | Ctype (TPtr _) -> ptr_conversion t
- | Ctype (TArray _) -> ptr_conversion t
+ | Ctype { tnode = (TInt _ | TEnum _) } -> int_conversion t
+ | Ctype { tnode = TFloat _ } as ltyp -> real_conversion ~ltyp t
+ | Ctype { tnode = TPtr _ } -> ptr_conversion t
+ | Ctype { tnode = TArray _ } -> ptr_conversion t
(* Could be transformed to \true: an array is never \null *)
- | Ctype (TFun _) -> ptr_conversion t
+ | Ctype { tnode = TFun _ } -> ptr_conversion t
(* decay as pointer *)
| Linteger -> int_conversion t
| Lreal -> real_conversion t
| Lboolean -> bool_conversion t
| Ltype _ | Lvar _ | Larrow _
- | Ctype (TVoid _ | TNamed _ | TComp _ | TBuiltin_va_list _)
+ | Ctype { tnode = (TVoid | TNamed _ | TComp _ | TBuiltin_va_list) }
-> Kernel.fatal
"Cannot convert a term of type %a"
!Cil.pp_logic_type_ref t.term_type
@@ -447,16 +448,16 @@ let float_builtin prefix fkind =
| _ -> Kernel.fatal "Missing or ambiguous builtin %S" name
let get_float_binop op typ =
- match Cil.unrollType typ, op with
- | TFloat(fkind,_) , PlusA -> float_builtin "add" fkind
- | TFloat(fkind,_) , MinusA -> float_builtin "sub" fkind
- | TFloat(fkind,_) , Mult -> float_builtin "mul" fkind
- | TFloat(fkind,_) , Div -> float_builtin "div" fkind
+ match Cil.unrollTypeNode typ, op with
+ | TFloat fkind, PlusA -> float_builtin "add" fkind
+ | TFloat fkind, MinusA -> float_builtin "sub" fkind
+ | TFloat fkind, Mult -> float_builtin "mul" fkind
+ | TFloat fkind, Div -> float_builtin "div" fkind
| _ -> None
let get_float_unop op typ =
- match Cil.unrollType typ, op with
- | TFloat(fkind,_) , Neg -> float_builtin "neg" fkind
+ match Cil.unrollTypeNode typ, op with
+ | TFloat fkind, Neg -> float_builtin "neg" fkind
| _ -> None
let is_boolean_exp e =
@@ -523,7 +524,7 @@ let rec expr_to_term ?(coerce=false) e =
in
let v = mk_cast ~loc typ @@ Logic_const.term ~loc node ltyp in
if coerce then
- match Cil.unrollType typ with
+ match Cil.unrollTypeNode typ with
| TInt _ -> numeric_coerce Linteger v
| TFloat _ -> numeric_coerce Lreal v
| _ -> v
@@ -2223,8 +2224,8 @@ let lhost_c_type thost =
| TVar v -> extract_ctype v.lv_type
| TMem t ->
let ty = extract_ctype t.term_type in
- (match Cil.unrollType ty with
- | TPtr(ty, _) -> ty
+ (match Cil.unrollTypeNode ty with
+ | TPtr ty -> ty
| _ -> assert false)
| TResult ty -> ty
@@ -2337,23 +2338,23 @@ let complete_types f = Cil.visitCilFile (new complete_types) f
let pointer_comparable ?loc ?(label=Logic_const.here_label) t1 t2 =
let preds = Logic_env.find_all_logic_functions "\\pointer_comparable" in
- let cfct_ptr = TPtr (TFun(Cil_const.voidType,None,false,[]),[]) in
+ let cfct_ptr = Cil_const.(mk_tptr (mk_tfun Cil_const.voidType None false)) in
let fct_ptr = Ctype cfct_ptr in
let obj_ptr = Ctype Cil_const.voidPtrType in
let discriminate t =
let loc = t.term_loc in
match Logic_const.unroll_ltdef t.term_type with
| Ctype ty ->
- (match Cil.unrollTypeDeep ty with
- | TPtr(TFun _,_) ->
+ (match Cil.(unrollTypeDeep ty).tnode with
+ | TPtr { tnode = TFun _ } ->
mk_cast ~loc cfct_ptr t, fct_ptr
- | TPtr(TVoid _,_) -> t, obj_ptr
+ | TPtr { tnode = TVoid } -> t, obj_ptr
| TPtr _ | TInt _ | TFloat _ | TEnum _ ->
(* Value may emit pointer_comparable alarms on anything that
may be compared. We cast scalar to void* to account for
this *)
mk_cast ~loc Cil_const.voidPtrType t, obj_ptr
- | TVoid _ | TFun _ | TNamed _ | TComp _ | TBuiltin_va_list _
+ | TVoid | TFun _ | TNamed _ | TComp _ | TBuiltin_va_list
| TArray _ (* in logic array do not decay implicitly
into pointers. *)
->
@@ -2436,10 +2437,10 @@ let rec constFoldTermToInt ?(machdep=true) (e: term) : Integer.t option =
and constFoldCastToInt ~machdep typ e =
try
- let ik = match Cil.unrollType typ with
- | TInt (ik, _) -> ik
+ let ik = match Cil.unrollTypeNode typ with
+ | TInt ik -> ik
| TPtr _ -> Machine.uintptr_kind ()
- | TEnum (ei,_) -> ei.ekind
+ | TEnum ei -> ei.ekind
| _ -> raise Exit
in
match constFoldTermToInt ~machdep e with
@@ -2594,8 +2595,8 @@ let const_fold_trange_bounds typ b e =
let e = match e with
| Some te -> extract (constFoldTermToInt te)
| None ->
- match Cil.unrollType typ with
- | TArray (_, Some size, _) ->
+ match Cil.unrollTypeNode typ with
+ | TArray (_, Some size) ->
Integer.pred (extract (Cil.isInteger size))
| _ -> raise CannotSimplify
in
diff --git a/src/kernel_services/ast_transformations/filter.ml b/src/kernel_services/ast_transformations/filter.ml
index 54a546991ad..64080502f66 100644
--- a/src/kernel_services/ast_transformations/filter.ml
+++ b/src/kernel_services/ast_transformations/filter.ml
@@ -819,14 +819,14 @@ end = struct
Varinfo.Hashtbl.add fi_table new_var finfo;
debug "@[[build_cil_proto] -> %s@\n@]@." new_var.vname;
let action =
- let (rt,args,va,attrs) = Cil.splitFunctionType new_var.vtype in
+ let (rt,args,va,tattr) = Cil.splitFunctionType new_var.vtype in
(match args with
| None -> ()
| Some args ->
let old_formals = Kernel_function.get_formals kf in
let old_formals = filter_params finfo old_formals in
let args = filter_params finfo args in
- let mytype = TFun(rt,Some args,va,attrs) in
+ let mytype = Cil_const.mk_tfun ~tattr rt (Some args) va in
let new_formals = List.map makeFormalsVarDecl args in
self#add_formals_bindings new_var new_formals;
Cil.update_var_type new_var mytype;
diff --git a/src/kernel_services/ast_transformations/inline.ml b/src/kernel_services/ast_transformations/inline.ml
index 2c4d8a9d1ba..97378735c23 100644
--- a/src/kernel_services/ast_transformations/inline.ml
+++ b/src/kernel_services/ast_transformations/inline.ml
@@ -175,8 +175,8 @@ let inline_call loc caller callee return args =
in
callee_fd.sbody
-let is_variadic_function vi = match vi.vtype with
- | TFun(_, _, is_v, _) -> is_v
+let is_variadic_function vi = match vi.vtype.tnode with
+ | TFun(_, _, is_v) -> is_v
| _ -> false
let inliner functions_to_inline = object (self)
diff --git a/src/plugins/alias/src/abstract_state.ml b/src/plugins/alias/src/abstract_state.ml
index 9e35a352c70..12796a955df 100644
--- a/src/plugins/alias/src/abstract_state.ml
+++ b/src/plugins/alias/src/abstract_state.ml
@@ -381,8 +381,8 @@ let create_var_vertex var s =
let s = {graph = G.add_vertex s.graph v;
varmap = VarMap.add var v s.varmap;
vmap = VMap.add v (VarSet.singleton var) s.vmap} in
- let rec create_typ_vertex s v ty = match ty with
- | TArray (ty, _, _) | TPtr (ty, _) ->
+ let rec create_typ_vertex s v ty = match ty.tnode with
+ | TArray (ty, _) | TPtr ty ->
(* create more vertices for each level of dereferentiation *)
let v', s = create_empty_vertex s in
let s = {s with graph = G.add_edge s.graph v v'} in
diff --git a/src/plugins/alias/src/simplified.ml b/src/plugins/alias/src/simplified.ml
index 6db03852872..f4431acdb60 100644
--- a/src/plugins/alias/src/simplified.ml
+++ b/src/plugins/alias/src/simplified.ml
@@ -41,8 +41,8 @@ exception Explicit_pointer_address of location
let check_cast_compatibility e to_type =
let rec cast_preserves_indirection_level from_type to_type =
let recurse = cast_preserves_indirection_level in
- match Cil.unrollType from_type, Cil.unrollType to_type with
- | TPtr (from_type, _), TPtr (to_type, _) -> recurse from_type to_type
+ match Cil.unrollTypeNode from_type, Cil.unrollTypeNode to_type with
+ | TPtr from_type, TPtr to_type -> recurse from_type to_type
| TPtr _, _ -> false
| _, TPtr _ -> false
| _ -> true
diff --git a/src/plugins/aorai/aorai_utils.ml b/src/plugins/aorai/aorai_utils.ml
index b2c342825aa..0c55dd68efc 100644
--- a/src/plugins/aorai/aorai_utils.ml
+++ b/src/plugins/aorai/aorai_utils.ml
@@ -420,8 +420,8 @@ let rec term_to_exp t res =
new_exp ~loc
(BinOp(binop, term_to_exp t1 res, term_to_exp t2 res, Cil_const.intType))
| TCast (false, Ctype ty, {term_node = TConst(LReal lreal)}) when Cil.isFloatingType ty ->
- (match Cil.unrollType ty with
- | TFloat(fk,_) ->
+ (match Cil.unrollTypeNode ty with
+ | TFloat fk ->
new_exp ~loc
(Const (CReal (lreal.r_nearest,fk,Some lreal.r_literal)))
| _ ->
@@ -482,7 +482,7 @@ let get_bhv_aux_fct kf bhv =
vi.vdefined <- false;
vi.vghost <- true;
let (_,args,varargs,_) = Cil.splitFunctionTypeVI ovi in
- let typ = TFun(Cil_const.intType, args, varargs,[]) in
+ let typ = Cil_const.(mk_tfun intType args varargs) in
Cil.update_var_type vi typ;
Cil.setFormalsDecl vi typ;
vi.vattr <- [];
@@ -755,7 +755,7 @@ let mk_global_c_enum_type name elements =
ignore (mk_global_c_enum_type_tagged name elements)
let mk_gvar_enum ?init name name_enuminfo =
- mk_gvar ?init ~ty:(TEnum(get_usedinfo name_enuminfo,[])) name
+ mk_gvar ?init ~ty:(Cil_const.mk_tenum (get_usedinfo name_enuminfo)) name
(* ************************************************************************* *)
@@ -778,7 +778,7 @@ let mk_offseted_array host off =
let int2enumstate nums =
let enum = find_enum nums in
- Logic_const.term (TConst (LEnum enum)) (Ctype (TEnum (enum.eihost,[])))
+ Logic_const.term (TConst (LEnum enum)) (Ctype (Cil_const.mk_tenum enum.eihost))
let int2enumstate_exp loc nums = new_exp ~loc (Const (CEnum (find_enum nums)))
@@ -789,7 +789,7 @@ let mk_offseted_array_states_as_enum host off =
(TLval
(Logic_const.addTermOffsetLval
(TIndex(Logic_const.term
- (TConst(LEnum enum)) (Ctype (TEnum (enum.eihost,[]))),
+ (TConst(LEnum enum)) (Ctype (Cil_const.mk_tenum enum.eihost)),
TNoOffset))
host))
(Ctype Cil_const.intType)
@@ -1124,7 +1124,7 @@ let initGlobals root complete =
mk_global_comment "//* Some constants";
let states_typ =
if Aorai_option.Deterministic.get ()
- then Some (TEnum (make_enum_states (), []))
+ then Some (Cil_const.mk_tenum (make_enum_states ()))
else None
in
(* non deterministic mode uses one variable for each possible state *)
diff --git a/src/plugins/aorai/aorai_visitors.ml b/src/plugins/aorai/aorai_visitors.ml
index 07251dce3ea..f974f092d41 100644
--- a/src/plugins/aorai/aorai_visitors.ml
+++ b/src/plugins/aorai/aorai_visitors.ml
@@ -163,7 +163,7 @@ class visit_adding_code_for_synchronisation =
- what about varargs?
*)
let (rettype,args,varargs,_) = Cil.splitFunctionTypeVI vi_pre in
- Cil.update_var_type vi_pre (TFun(Cil_const.voidType, args, varargs,[]));
+ Cil.update_var_type vi_pre Cil_const.(mk_tfun voidType args varargs);
vi_pre.vattr <- [];
(* in particular get rid of __no_return if set in vi*)
@@ -176,7 +176,7 @@ class visit_adding_code_for_synchronisation =
let vi_post =
Cil.makeGlobalVar ~ghost:true
(Data_for_aorai.get_fresh (vi.vname ^ "_post_func"))
- (TFun(Cil_const.voidType,Some arg,false,[]))
+ Cil_const.(mk_tfun voidType (Some arg) false)
in
Kernel_function.Hashtbl.add aux_post_table kf vi_post;
Aux_funcs.(add vi_post (Post kf));
@@ -186,9 +186,9 @@ class visit_adding_code_for_synchronisation =
we have to update the function's formals. Search
for LBLsformals. *)
Cil.setFunctionTypeMakeFormals
- fun_dec_pre (TFun(Cil_const.voidType, args, varargs,[]));
+ fun_dec_pre Cil_const.(mk_tfun voidType args varargs);
Cil.setFunctionTypeMakeFormals
- fun_dec_post (TFun(Cil_const.voidType, Some arg, false,[]));
+ fun_dec_post Cil_const.(mk_tfun voidType (Some arg) false);
(* We will now fill the function with the result
of the automaton's analysis. *)
Globals.Functions.replace_by_definition
diff --git a/src/plugins/aorai/data_for_aorai.ml b/src/plugins/aorai/data_for_aorai.ml
index 0b2adcfabed..931bbfca261 100644
--- a/src/plugins/aorai/data_for_aorai.ml
+++ b/src/plugins/aorai/data_for_aorai.ml
@@ -558,7 +558,7 @@ let memo_aux_variable tr counter used_prms vi =
let my_type =
match counter with
| None -> vi.vtype
- | Some _ -> TArray(vi.vtype,None,[])
+ | Some _ -> Cil_const.mk_tarray vi.vtype None
in
let my_var =
Cil.makeGlobalVar ~ghost:true (get_fresh ("aorai_" ^ vi.vname)) my_type
@@ -737,7 +737,7 @@ let type_expr metaenv env ?tr ?current e =
let t =
Logic_const.term
(TConst (LWStr (Logic_typing.wcharlist_of_string s)))
- (Ctype (TPtr(Machine.wchar_type (),[])))
+ (Ctype (Cil_const.mk_tptr (Machine.wchar_type ())))
in env,t,cond
| PBinop(bop,e1,e2) ->
let op = Logic_typing.type_binop bop in
@@ -1139,7 +1139,7 @@ let rec type_seq default_state tr metaenv env needs_pebble curr_start curr_end s
(* TODO: makes it an integer *)
let counter =
let ty = if needs_pebble then
- Cil_types.TArray (Cil_const.intType,None,[])
+ Cil_const.(mk_tarray intType None)
else Cil_const.intType
in (* We won't always need a counter *)
lazy (
@@ -2271,13 +2271,13 @@ let get_cenum_option name =
None
let func_enum_type () =
- try TEnum(Hashtbl.find used_enuminfo listOp,[])
+ try Cil_const.mk_tenum (Hashtbl.find used_enuminfo listOp)
with Not_found ->
Aorai_option.fatal
"Enum type indicating current function (%s) is unknown" listOp
let status_enum_type () =
- try TEnum(Hashtbl.find used_enuminfo listStatus,[])
+ try Cil_const.mk_tenum (Hashtbl.find used_enuminfo listStatus)
with Not_found ->
Aorai_option.fatal
"Enum type indicating current event (%s) is unknown" listStatus
diff --git a/src/plugins/aorai/yaparser.mly b/src/plugins/aorai/yaparser.mly
index 91a4471f7a9..bb2e20c82f3 100644
--- a/src/plugins/aorai/yaparser.mly
+++ b/src/plugins/aorai/yaparser.mly
@@ -27,7 +27,6 @@
/* Originated from http://www.ltl2dstar.de/down/ltl2dstar-0.4.2.zip */
%{
-open Cil_types
open Logic_ptree
open Automaton_ast
open Bool3
@@ -91,9 +90,9 @@ let set_accept_state id =
let add_metavariable map (name,typename) =
let ty = match typename with
- | "int" -> TInt(IInt, [])
- | "char" -> TInt(IChar, [])
- | "long" -> TInt(ILong, [])
+ | "int" -> Cil_const.intType
+ | "char" -> Cil_const.charType
+ | "long" -> Cil_const.longType
| _ ->
Aorai_option.abort "Unrecognized type %s for metavariable %s"
typename name
diff --git a/src/plugins/constant_propagation/api.ml b/src/plugins/constant_propagation/api.ml
index 1e8e5b441d4..f77d6eb7ef1 100644
--- a/src/plugins/constant_propagation/api.ml
+++ b/src/plugins/constant_propagation/api.ml
@@ -86,9 +86,10 @@ class propagate project fnames ~cast_intro = object(self)
let oldt, newt =
if ignore_const_cast then
match Cil.unrollType oldt, Cil.unrollType newt with
- | TPtr(typ, attrs), TPtr(typ', attrs') ->
+ | { tnode = TPtr typ; tattr = attrs }, { tnode = TPtr typ'; tattr = attrs' } ->
let drop_const ty = Cil.typeRemoveAttributes ["const"] ty in
- TPtr(drop_const typ, attrs), TPtr(drop_const typ', attrs')
+ Cil_const.mk_tptr ~tattr:attrs (drop_const typ),
+ Cil_const.mk_tptr ~tattr:attrs' (drop_const typ')
| _ -> oldt, newt
else
oldt, newt
@@ -124,11 +125,8 @@ class propagate project fnames ~cast_intro = object(self)
let loc = expr.eloc in
let typ = Cil.typeOf expr in
let typ_e = Cil.unrollType typ in
- begin match typ_e with
- | (TInt _
- | TFloat _
- | TPtr _
- | TEnum _) -> ()
+ begin match typ_e.tnode with
+ | TInt _ | TFloat _ | TPtr _ | TEnum _ -> ()
| _ -> raise Cannot_expand
end;
let stmt = match self#current_stmt with
@@ -233,9 +231,9 @@ class propagate project fnames ~cast_intro = object(self)
with Fval.Not_Singleton_Float->
raise Cannot_expand
in
- (match typ_e with
- | TFloat (fkind, _) -> const_float m fkind
- | TInt (ikind, _) | TEnum ({ ekind = ikind}, _) ->
+ (match typ_e.tnode with
+ | TFloat fkind -> const_float m fkind
+ | TInt ikind | TEnum { ekind = ikind} ->
const_integer m ikind
| _ -> raise Cannot_expand)
diff --git a/src/plugins/dive/build.ml b/src/plugins/dive/build.ml
index 8edca172df0..322db1406e8 100644
--- a/src/plugins/dive/build.ml
+++ b/src/plugins/dive/build.ml
@@ -164,10 +164,10 @@ let get_loc_filename loc =
Filepath.(Normalized.to_pretty_string (fst loc).pos_path)
let is_foldable_type typ =
- match Cil.unrollType typ with
+ match Cil.unrollTypeNode typ with
| TArray _ | TComp _ -> true
- | TVoid _ | TInt _ | TEnum _ | TFloat _ | TPtr _ | TFun _
- | TBuiltin_va_list _ -> false
+ | TVoid | TInt _ | TEnum _ | TFloat _ | TPtr _ | TFun _
+ | TBuiltin_va_list -> false
| TNamed _ -> assert false (* the type have been unrolled *)
diff --git a/src/plugins/dive/node_range.ml b/src/plugins/dive/node_range.ml
index b759aac28e9..e7da173a1a4 100644
--- a/src/plugins/dive/node_range.ml
+++ b/src/plugins/dive/node_range.ml
@@ -70,11 +70,11 @@ let float_range fkind l u =
let evaluate cvalue typ =
let cardinal = Cvalue.V.cardinal cvalue in
- match typ, cardinal with
+ match typ.Cil_types.tnode, cardinal with
| _, Some card when Integer.is_zero card -> Empty
| _, Some card when Integer.is_one card -> Singleton
- | Cil_types.TInt (ikind,_), Some cardinal -> integer_range cardinal ikind
- | Cil_types.TFloat (fkind,_), _ ->
+ | TInt ikind, Some cardinal -> integer_range cardinal ikind
+ | TFloat fkind, _ ->
begin match Ival.min_and_max_float (Cvalue.V.project_ival cvalue) with
| Some (l, u), _can_be_nan -> float_range fkind l u
| _, _ -> Wide
diff --git a/src/plugins/e-acsl/src/analyses/interval.ml b/src/plugins/e-acsl/src/analyses/interval.ml
index 52d63f153ee..c9f3d079fec 100644
--- a/src/plugins/e-acsl/src/analyses/interval.ml
+++ b/src/plugins/e-acsl/src/analyses/interval.ml
@@ -413,7 +413,7 @@ let rec infer ~force ~logic_env t =
ignore (infer ~force ~logic_env t1);
ignore (infer ~force ~logic_env t2);
(match Cil.unrollType (get_cty t1) with
- | TArray(_, _, _) as ta ->
+ | { tnode = TArray(_, _) } as ta ->
begin
try
let n = Cil.bitsSizeOf ta in
@@ -425,13 +425,13 @@ let rec infer ~force ~logic_env t =
with Cil.SizeOfError _ ->
Lazy.force interv_of_unknown_block
end
- | TPtr _ -> Lazy.force interv_of_unknown_block
+ | { tnode = TPtr _ } -> Lazy.force interv_of_unknown_block
| _ -> assert false)
| Tblock_length (_, t)
| Toffset(_, t) ->
ignore (infer ~force ~logic_env t);
(match Cil.unrollType (get_cty t) with
- | TArray(_, _, _) as ta ->
+ | { tnode = TArray (_, _) } as ta ->
begin
try
let n = Cil.bitsSizeOf ta in
@@ -440,7 +440,7 @@ let rec infer ~force ~logic_env t =
with Cil.SizeOfError _ ->
Lazy.force interv_of_unknown_block
end
- | TPtr _ -> Lazy.force interv_of_unknown_block
+ | { tnode = TPtr _ } -> Lazy.force interv_of_unknown_block
| _ -> assert false)
| Tnull -> singleton_of_int 0
| Tapp (li,_,args) ->
@@ -628,7 +628,7 @@ and infer_term_host ~force ~logic_env thost =
match v.lv_type with
| Lboolean -> ival Z.zero Z.one
| Linteger -> top_ival
- | Ctype (TFloat(fk, _)) -> Float(fk, None)
+ | Ctype { tnode = TFloat fk } -> Float(fk, None)
| Lreal -> Real
| Ctype _ -> interv_of_typ (Logic_utils.logicCType v.lv_type)
| Ltype _ | Lvar _ | Larrow _ ->
@@ -638,8 +638,8 @@ and infer_term_host ~force ~logic_env thost =
| TMem t ->
ignore (infer ~force ~logic_env t);
let ty = Logic_utils.logicCType t.term_type in
- match Cil.unrollType ty with
- | TPtr(ty, _) | TArray(ty, _, _) ->
+ match Cil.unrollTypeNode ty with
+ | TPtr ty | TArray (ty, _) ->
interv_of_typ ty
| _ ->
Options.fatal "unexpected type %a for term %a"
diff --git a/src/plugins/e-acsl/src/analyses/typing.ml b/src/plugins/e-acsl/src/analyses/typing.ml
index 14d257e34d2..fe3db88a6e6 100644
--- a/src/plugins/e-acsl/src/analyses/typing.ml
+++ b/src/plugins/e-acsl/src/analyses/typing.ml
@@ -57,9 +57,9 @@ let ty_of_interv = Interval.ty_of_interv
let join_cty ty1 ty2 =
let ty = Cil.arithmeticConversion ty1 ty2 in
- match ty with
- | TInt(i, _) -> C_integer i
- | TFloat(f, _) -> C_float f
+ match ty.tnode with
+ | TInt ik -> C_integer ik
+ | TFloat fk -> C_float fk
| _ ->
Options.fatal "[typing] join failure: unexpected result %a"
Printer.pp_typ ty
@@ -87,20 +87,20 @@ let join ty1 ty2 =
| C_integer _, Gmpz ->
Gmpz
| C_float f1, C_float f2 ->
- join_cty (TFloat(f1, [])) (TFloat(f2, []))
+ join_cty (Cil_const.mk_tfloat f1) (Cil_const.mk_tfloat f2)
| C_float f, C_integer n
| C_integer n, C_float f ->
- join_cty (TFloat(f, [])) (TInt(n, []))
+ join_cty (Cil_const.mk_tfloat f) (Cil_const.mk_tint n)
| C_integer i1, C_integer i2 ->
if Options.Gmp_only.get () then Gmpz
- else join_cty (TInt(i1, [])) (TInt(i2, []))
+ else join_cty (Cil_const.mk_tint i1) (Cil_const.mk_tint i2)
exception Not_a_number
let typ_of_number_ty = function
| C_integer _ when Options.Gmp_only.get () -> Gmp_types.Z.t ()
- | C_integer ik -> TInt(ik, [])
+ | C_integer ik -> Cil_const.mk_tint ik
| C_float _ when Options.Gmp_only.get () -> Gmp_types.Q.t ()
- | C_float fk -> TFloat(fk, [])
+ | C_float fk -> Cil_const.mk_tfloat fk
| Gmpz -> Gmp_types.Z.t ()
(* for the time being, no reals but rationals instead *)
| Rational -> Gmp_types.Q.t ()
@@ -266,10 +266,10 @@ let number_ty_of_typ ~post ty =
if post && Gmp_types.Z.is_t ty then Gmpz
else if post && Gmp_types.Q.is_t ty then Rational
else
- match Cil.unrollType ty with
- | TInt(ik, _) | TEnum({ ekind = ik }, _) -> C_integer ik
- | TFloat(fk, _) -> C_float fk
- | TVoid _ | TPtr _ | TArray _ | TFun _ | TComp _ | TBuiltin_va_list _ -> Nan
+ match Cil.unrollTypeNode ty with
+ | TInt ik | TEnum { ekind = ik } -> C_integer ik
+ | TFloat fk -> C_float fk
+ | TVoid | TPtr _ | TArray _ | TFun _ | TComp _ | TBuiltin_va_list -> Nan
| TNamed _ -> assert false
let ty_of_logic_ty ?term ~profile lty =
@@ -311,15 +311,15 @@ let c_type_or_int_in_ival_of t i =
let t = Logic_utils.remove_logic_coerce t in
match t.term_type with
| Ctype typ ->
- (match Cil.unrollType typ with
- | TInt (ik, _) | TEnum({ ekind = ik }, _) when
+ (match Cil.unrollTypeNode typ with
+ | TInt ik | TEnum { ekind = ik } when
Interval.is_included_in_typ i typ
->
if Cil.intTypeIncluded ik IInt
then Some (C_integer IInt)
else Some (C_integer ik)
- | TInt _ | TEnum _ | TFloat _ | TVoid _ | TPtr _ | TArray _ | TFun _
- | TComp _ | TBuiltin_va_list _ -> None
+ | TInt _ | TEnum _ | TFloat _ | TVoid | TPtr _ | TArray _ | TFun _
+ | TComp _ | TBuiltin_va_list -> None
| TNamed _ -> assert false)
| _ -> None
@@ -372,7 +372,7 @@ let rec type_term
if the infered context for the lambda is gmp *)
ty_of_interv ?ctx ~use_gmp_opt:under_lambda i
- | TLval ((TVar {lv_type = Ctype (TInt (ik, _))}, _) as tlv) ->
+ | TLval ((TVar {lv_type = Ctype { tnode = TInt ik }}, _) as tlv) ->
type_term_lval ~profile tlv;
C_integer ik
@@ -604,19 +604,20 @@ let rec type_term
function returning this type, otherwise we use the interval
inference *)
(match li.l_type with
- | Some (Ctype (TInt (ikind, _))) ->
+ | Some (Ctype { tnode = TInt ikind }) ->
C_integer ikind
- | Some (Ctype (TFloat (fkind, _))) ->
+ | Some (Ctype { tnode = TFloat fkind }) ->
C_float fkind
| None
- | Some (Ctype (TVoid _
- | TPtr _
- | TEnum _
- | TArray _
- | TFun _
- | TNamed _
- | TComp _
- | TBuiltin_va_list _))
+ | Some (Ctype { tnode =
+ ( TVoid
+ | TPtr _
+ | TEnum _
+ | TArray _
+ | TFun _
+ | TNamed _
+ | TComp _
+ | TBuiltin_va_list) })
| Some (Lboolean | Linteger | Lreal | Ltype _ | Lvar _ | Larrow _) ->
ty_of_interv
?ctx:ctx_body
@@ -747,12 +748,13 @@ and number_ty_bound_variable ~profile (t1, lv, t2) =
| None -> ty_of_interv ~ctx:Gmpz i
in mk_ctx ~use_gmp_opt:true ty
| Ctype ty ->
- (match Cil.unrollType ty with
- | TInt(ik, _) | TEnum({ ekind = ik}, _) ->
+ let ty = Cil.unrollType ty in
+ (match ty.tnode with
+ | TInt ik | TEnum { ekind = ik} ->
join
(ty_of_interv i)
(mk_ctx ~use_gmp_opt:true (C_integer ik))
- | ty ->
+ | _ ->
Options.fatal "unexpected C type %a for quantified variable %a"
Printer.pp_typ ty
Printer.pp_logic_var lv)
diff --git a/src/plugins/e-acsl/src/code_generator/assert.ml b/src/plugins/e-acsl/src/code_generator/assert.ml
index 7b3787937c8..0b01e166cd5 100644
--- a/src/plugins/e-acsl/src/code_generator/assert.ml
+++ b/src/plugins/e-acsl/src/code_generator/assert.ml
@@ -144,19 +144,20 @@ let add_pending_register_data ~loc { data_ptr } name e =
else if Gmp_types.Q.is_t ty then
"mpq", [ e ]
else
- match Cil.unrollType ty with
- | TInt (ikind, _) -> ikind_to_string ikind, [ Cil.zero ~loc; e ]
- | TFloat (FFloat, _) -> "float", [ e ]
- | TFloat (FDouble, _) -> "double", [ e ]
- | TFloat (FLongDouble, _) -> "longdouble", [ e ]
+ let ty = Cil.unrollType ty in
+ match ty.tnode with
+ | TInt ikind -> ikind_to_string ikind, [ Cil.zero ~loc; e ]
+ | TFloat FFloat -> "float", [ e ]
+ | TFloat FDouble -> "double", [ e ]
+ | TFloat FLongDouble -> "longdouble", [ e ]
| TPtr _ -> "ptr", [ e ]
| TArray _ -> "array", [ e ]
| TFun _ -> "fun", []
- | TComp ({ cstruct = true }, _) -> "struct", []
- | TComp ({ cstruct = false }, _) -> "union", []
- | TEnum ({ ekind }, _) -> ikind_to_string ekind, [ Cil.one ~loc; e ]
- | TVoid _
- | TBuiltin_va_list _ -> "other", []
+ | TComp { cstruct = true} -> "struct", []
+ | TComp { cstruct = false } -> "union", []
+ | TEnum { ekind } -> ikind_to_string ekind, [ Cil.one ~loc; e ]
+ | TVoid
+ | TBuiltin_va_list -> "other", []
| TNamed _ ->
Options.fatal
"named types in '%a' should have been unrolled"
diff --git a/src/plugins/e-acsl/src/code_generator/assigns.ml b/src/plugins/e-acsl/src/code_generator/assigns.ml
index 7f1e8dd6f8e..dffe5abcd26 100644
--- a/src/plugins/e-acsl/src/code_generator/assigns.ml
+++ b/src/plugins/e-acsl/src/code_generator/assigns.ml
@@ -30,21 +30,21 @@ exception NoAssigns
(* If an argument contains a pointer type, then it is undecidable which assigns
clause should be generated, so skip the assigns generation in this case *)
-let rec is_ptr_free typ = match Cil.unrollType typ with
- | TVoid _
- | TInt (_, _)
- | TFloat (_, _) -> true
- | TPtr (_, _) -> false
- | TArray (ty, _, _) -> is_ptr_free ty
- | TFun (_, _, _, _) ->
+let rec is_ptr_free typ = match Cil.unrollTypeNode typ with
+ | TVoid
+ | TInt _
+ | TFloat _ -> true
+ | TPtr _ -> false
+ | TArray (ty, _) -> is_ptr_free ty
+ | TFun (_, _, _) ->
(* a function cannot be an argument of a function *)
assert false
- | TNamed (_, _) ->
+ | TNamed _ ->
(* The named types are unfolded with [Cil.unrolltype] *)
assert false
- | TEnum (_, _)
- | TBuiltin_va_list _ -> true
- | TComp (cinfo, _) ->
+ | TEnum _
+ | TBuiltin_va_list -> true
+ | TComp cinfo ->
match cinfo.cfields with
| None -> raise NoAssigns
| Some fields ->
diff --git a/src/plugins/e-acsl/src/code_generator/contract.ml b/src/plugins/e-acsl/src/code_generator/contract.ml
index 0b75638b07a..990f467c1f9 100644
--- a/src/plugins/e-acsl/src/code_generator/contract.ml
+++ b/src/plugins/e-acsl/src/code_generator/contract.ml
@@ -69,7 +69,7 @@ end = struct
let init ~loc ~result_name env kf count =
(* Add a call to init in the environment *)
- let ty = TPtr(Lazy.force ctyp_lazy, []) in
+ let ty = Cil_const.mk_tptr (Lazy.force ctyp_lazy) in
Env.new_var
~loc
~name:result_name
diff --git a/src/plugins/e-acsl/src/code_generator/global_observer.ml b/src/plugins/e-acsl/src/code_generator/global_observer.ml
index 9f9d5db5004..c0495e3e33d 100644
--- a/src/plugins/e-acsl/src/code_generator/global_observer.ml
+++ b/src/plugins/e-acsl/src/code_generator/global_observer.ml
@@ -68,7 +68,7 @@ let mk_function name =
let vi =
Cil.makeGlobalVar ~source:true
name
- (TFun(Cil_const.voidType, Some [], false, []))
+ Cil_const.(mk_tfun voidType (Some []) false)
in
vi.vdefined <- true;
(* There is no contract associated with the function *)
@@ -157,7 +157,7 @@ let mk_init_function () =
Cil.makeLocalVar
fundec
(Functions.RTL.mk_api_name "already_run")
- (TInt(IChar, []))
+ Cil_const.charType
in
vi_already_run.vdefined <- true;
vi_already_run.vreferenced <- true;
diff --git a/src/plugins/e-acsl/src/code_generator/gmp.ml b/src/plugins/e-acsl/src/code_generator/gmp.ml
index 265ef30818f..8d4ede3b260 100644
--- a/src/plugins/e-acsl/src/code_generator/gmp.ml
+++ b/src/plugins/e-acsl/src/code_generator/gmp.ml
@@ -72,8 +72,8 @@ let get_set_suffix_and_arg res_ty e =
[TODO] check the statement above *)
| C_float FLongDouble, _ -> Error.not_yet "creating gmp from long double"
| Gmpz, _ | Rational, _ | Real, _ | Nan, _ ->
- match Cil.unrollType ty with
- | TPtr(TInt(IChar, _), _) ->
+ match Cil.unrollTypeNode ty with
+ | TPtr { tnode = TInt IChar } ->
"_str",
(* decimal base for the number given as string *)
[ e; Cil.integer ~loc:e.eloc 10 ]
@@ -114,7 +114,7 @@ let init_set ~loc lv ev e =
[ ev;
Cil.one ~loc;
Cil.one ~loc;
- Cil.sizeOf ~loc (TInt(IULongLong, []));
+ Cil.sizeOf ~loc Cil_const.ulongLongType;
Cil.zero ~loc;
Cil.zero ~loc;
Cil.mkAddrOf ~loc elv ]
@@ -368,13 +368,13 @@ module Q = struct
in
e, env
in
- match Cil.unrollType ty with
- | TFloat(FLongDouble, _) ->
+ match Cil.unrollTypeNode ty with
+ | TFloat FLongDouble ->
(* The biggest floating-point type we can extract from GMPQ is double *)
Error.not_yet "R to long double"
- | TFloat(FDouble, _) ->
+ | TFloat FDouble ->
get_double e env
- | TFloat(FFloat, _) ->
+ | TFloat FFloat ->
(* No "get_float" in GMPQ, but fortunately, [float] \subset [double].
HOWEVER: going through double as intermediate step might be unsound
since it could cause double rounding. See: [Boldo2013, Sec 2.2]
@@ -383,7 +383,7 @@ module Q = struct
Options.warning
~once:true "R to float: double rounding might cause unsoundness";
Cil.mkCastT ~force:false ~oldt:Cil_const.doubleType ~newt:ty e, env
- | TInt(IULongLong, _) ->
+ | TInt IULongLong ->
(* The biggest C integer type we can extract from GMP is ulong *)
Error.not_yet "R to unsigned long long"
| TInt _ ->
diff --git a/src/plugins/e-acsl/src/code_generator/injector.ml b/src/plugins/e-acsl/src/code_generator/injector.ml
index 1356c74d3ab..b1b90732c18 100644
--- a/src/plugins/e-acsl/src/code_generator/injector.ml
+++ b/src/plugins/e-acsl/src/code_generator/injector.ml
@@ -638,10 +638,11 @@ let unghost_vi vi =
if vi.vstorage <> Extern then vi.vghost <- false;
Cil.update_var_type vi (Cil.typeRemoveAttributesDeep ["ghost"] vi.vtype);
match Cil.unrollType vi.vtype with
- | TFun(res, Some l, va, attr) ->
+ | { tnode = TFun (res, Some l, va); tattr } ->
(* unghostify function's parameters *)
let retype (n, t, a) = n, t, Cil.dropAttribute Cil.frama_c_ghost_formal a in
- Cil.update_var_type vi (TFun(res, Some (List.map retype l), va, attr))
+ Cil.update_var_type vi
+ (Cil_const.mk_tfun ~tattr res (Some (List.map retype l)) va)
| _ ->
()
diff --git a/src/plugins/e-acsl/src/code_generator/logic_functions.ml b/src/plugins/e-acsl/src/code_generator/logic_functions.ml
index a0dab61aace..4d4cffbd85b 100644
--- a/src/plugins/e-acsl/src/code_generator/logic_functions.ml
+++ b/src/plugins/e-acsl/src/code_generator/logic_functions.ml
@@ -57,10 +57,10 @@ let term_to_exp_ref
first extra argument at each call *)
let result_as_extra_argument typ =
let is_composite typ =
- match Cil.unrollType typ with
+ match Cil.unrollTypeNode typ with
| TComp _ | TPtr _ | TArray _ -> true
- | TInt _ | TVoid _ | TFloat _ | TFun _ | TNamed _ | TEnum _
- | TBuiltin_va_list _ -> false
+ | TInt _ | TVoid | TFloat _ | TFun _ | TNamed _ | TEnum _
+ | TBuiltin_va_list -> false
in
Gmp_types.is_t typ || is_composite typ
@@ -140,9 +140,9 @@ let generate_kf ~loc fname env params_ty ret_ty params_ival li =
parameters *)
Gmp_types.Z.t_as_ptr ()
| C_integer _ when Options.Gmp_only.get () -> Gmp_types.Z.t_as_ptr ()
- | C_integer ik -> TInt(ik, [])
+ | C_integer ik -> Cil_const.mk_tint ik
| C_float _ when Options.Gmp_only.get () -> Gmp_types.Q.t_as_ptr ()
- | C_float ik -> TFloat(ik, [])
+ | C_float fk -> Cil_const.mk_tfloat fk
(* for the time being, no reals but rationals instead *)
| Rational -> Gmp_types.Q.t ()
| Real -> Error.not_yet "real number"
@@ -162,7 +162,7 @@ let generate_kf ~loc fname env params_ty ret_ty params_ival li =
let ret_vi, ret_ty, params_with_ret, params_ty_with_ret =
let vname = "__retres" in
if res_as_extra_arg then
- let ret_ty_ptr = TPtr(ret_ty, []) (* call by reference *) in
+ let ret_ty_ptr = Cil_const.mk_tptr ret_ty (* call by reference *) in
let vname = vname ^ "_arg" in
let vi = Cil.makeVarinfo false true vname ret_ty_ptr in
vi, Cil_const.voidType, vi :: params, (vname, ret_ty_ptr, []) :: params_ty_vi
@@ -173,11 +173,11 @@ let generate_kf ~loc fname env params_ty ret_ty params_ival li =
let vi =
Cil.makeGlobalVar
fname
- (TFun
- (ret_ty,
- Some params_ty_with_ret,
- false,
- li.l_var_info.lv_attr))
+ (Cil_const.mk_tfun
+ ~tattr:li.l_var_info.lv_attr
+ ret_ty
+ (Some params_ty_with_ret)
+ false)
in
vi.vdefined <- true;
(* create the fundec *)
@@ -438,8 +438,8 @@ let function_to_exp ~loc ?tapp fname env kf li params_ty profile args =
(* create the function call for the tapp *)
let mkcall vi =
let mk_args types args =
- match types (* generated by E-ACSL: no need to unroll *) with
- | TFun(_, Some params, _, _) ->
+ match types.tnode (* generated by E-ACSL: no need to unroll *) with
+ | TFun(_, Some params, _) ->
(* additional casts are necessary whenever the argument is GMP and the
parameter is a (small) integralType: after handling the context in
[Translate] through [add_cast], the GMP has been translated into a
diff --git a/src/plugins/e-acsl/src/code_generator/memory_translate.ml b/src/plugins/e-acsl/src/code_generator/memory_translate.ml
index 7bd76dbce01..045f1809d33 100644
--- a/src/plugins/e-acsl/src/code_generator/memory_translate.ml
+++ b/src/plugins/e-acsl/src/code_generator/memory_translate.ml
@@ -200,8 +200,8 @@ let range_to_ptr_and_size ~adata ~loc kf env ptr r p =
assert false
in
(* s *)
- let ty = match Cil.unrollType (Misc.cty ptr.term_type) with
- | TPtr(ty, _) | TArray(ty, _, _) -> ty
+ let ty = match Cil.unrollTypeNode (Misc.cty ptr.term_type) with
+ | TPtr ty | TArray (ty, _) -> ty
| _ -> assert false
in
let s = Logic_const.term ~loc (TSizeOf ty) Linteger in
@@ -351,7 +351,7 @@ let extract_quantifiers ~loc args =
| TAddrOf(TVar _, TIndex({ term_node = Trange _ }, TNoOffset)) ->
(* Case A: explicit range *)
arg, quantifiers
- | TAddrOf(TVar ({ lv_type = Ctype (TArray _) } as lv), toffset) ->
+ | TAddrOf(TVar ({ lv_type = Ctype { tnode = TArray _ } } as lv), toffset) ->
if has_set_as_index toffset then
(* Case B: non-explicit range, try to extract quantifiers with
range elimination. *)
diff --git a/src/plugins/e-acsl/src/code_generator/smart_exp.ml b/src/plugins/e-acsl/src/code_generator/smart_exp.ml
index f4c94cb75ce..04c8db33084 100644
--- a/src/plugins/e-acsl/src/code_generator/smart_exp.ml
+++ b/src/plugins/e-acsl/src/code_generator/smart_exp.ml
@@ -40,8 +40,8 @@ let subscript ~loc array idx =
array
let ptr_sizeof ~loc typ =
- match Cil.unrollType typ with
- | TPtr (t', _) -> Cil.new_exp ~loc (SizeOf t')
+ match Cil.unrollTypeNode typ with
+ | TPtr t' -> Cil.new_exp ~loc (SizeOf t')
| _ -> assert false
let lnot ~loc e =
@@ -69,7 +69,7 @@ let lnot ~loc e =
Cil.zero ~loc
let null ~loc =
- Cil.mkCast ~newt:(TPtr (TVoid [], [])) (Cil.zero ~loc)
+ Cil.mkCast ~newt:Cil_const.voidPtrType (Cil.zero ~loc)
let mem ~loc vi =
lval
diff --git a/src/plugins/e-acsl/src/code_generator/smart_stmt.ml b/src/plugins/e-acsl/src/code_generator/smart_stmt.ml
index ac140165541..5c275252bce 100644
--- a/src/plugins/e-acsl/src/code_generator/smart_stmt.ml
+++ b/src/plugins/e-acsl/src/code_generator/smart_stmt.ml
@@ -37,8 +37,8 @@ let assigns ~loc ~result e = instr (Set(result, e, loc))
let assigns_field ~loc vi name value =
let ty = vi.vtype in
let compinfo =
- match Cil.unrollType ty with
- | TComp (compinfo, _) -> compinfo
+ match Cil.unrollTypeNode ty with
+ | TComp compinfo -> compinfo
| _ ->
Options.fatal
"type of %a (%a) is not a structure"
@@ -66,8 +66,8 @@ let struct_local_init ~loc vi fields =
vi.vdefined <- true;
let ty = vi.vtype in
let compinfo =
- match Cil.unrollType ty with
- | TComp (compinfo, _) -> compinfo
+ match Cil.unrollTypeNode ty with
+ | TComp compinfo -> compinfo
| _ ->
Options.fatal
"type of %a (%a) is not a structure"
@@ -109,7 +109,7 @@ let do_call ~loc ?result vi args =
match args, param_ty with
| arg :: args_tl, (_, ty, _) :: param_ty_tl ->
let e =
- match ty, Cil.unrollType (Cil.typeOf arg), arg.enode with
+ match ty.tnode, Cil.(unrollTypeNode (typeOf arg)), arg.enode with
| TPtr _, TArray _, Lval lv -> Cil.new_exp ~loc (StartOf lv)
| TPtr _, TArray _, _ -> assert false
| _, _, _ -> arg
@@ -126,9 +126,9 @@ let do_call ~loc ?result vi args =
in
List.rev (make_rev_args [] args param_ty)
in
- let args = match Cil.unrollType vi.vtype with
- | TFun(_, Some params, variadic, _) -> make_args ~variadic args params
- | TFun(_, None, _, _) -> []
+ let args = match Cil.unrollTypeNode vi.vtype with
+ | TFun (_, Some params, variadic) -> make_args ~variadic args params
+ | TFun (_, None, _) -> []
| _ -> assert false
in
call_instr ~loc ?result f args
@@ -174,10 +174,10 @@ let named_store_stmt name ?str_size vi =
let ty = Cil.unrollType vi.vtype in
let loc = vi.vdecl in
let store = rtl_call ~loc name in
- match ty, str_size with
- | TArray(_, Some _,_), None ->
+ match ty.tnode, str_size with
+ | TArray (_, Some _), None ->
store [ Cil.evar ~loc vi; Cil.sizeOf ~loc ty ]
- | TPtr(TInt(IChar, _), _), Some size ->
+ | TPtr { tnode = TInt IChar }, Some size ->
store [ Cil.evar ~loc vi ; size ]
| TPtr _, Some size ->
(* a VLA that has been converted into a pointer by the kernel *)
@@ -202,8 +202,8 @@ let duplicate_store_stmt ?str_size vi =
let delete_stmt ?(is_addr=false) vi =
let loc = vi.vdecl in
let mk = rtl_call ~loc "delete_block" in
- match is_addr, Cil.unrollType vi.vtype with
- | _, TArray(_, Some _, _) | true, _ -> mk [ Cil.evar ~loc vi ]
+ match is_addr, Cil.unrollTypeNode vi.vtype with
+ | _, TArray (_, Some _) | true, _ -> mk [ Cil.evar ~loc vi ]
| _ -> mk [ Cil.mkAddrOfVi vi ]
let mark_readonly vi =
diff --git a/src/plugins/e-acsl/src/code_generator/temporal.ml b/src/plugins/e-acsl/src/code_generator/temporal.ml
index 13ab62cebb0..371eab61f4c 100644
--- a/src/plugins/e-acsl/src/code_generator/temporal.ml
+++ b/src/plugins/e-acsl/src/code_generator/temporal.ml
@@ -108,7 +108,7 @@ end = struct
| false -> "pull_return"
in
(* TODO: Returning structs is unsupported so far *)
- (match (Cil.typeOf lhs) with
+ (match Cil.(typeOf lhs).tnode with
| TPtr _ -> ()
| _ -> Error.not_yet "Struct in return");
Smart_stmt.rtl_call ~loc ~prefix fname [ lhs ]
@@ -145,7 +145,7 @@ let assign ?(ltype) lhs rhs loc =
| Some l -> l
| None -> Cil.typeOfLval lhs
in
- match Cil.unrollType ltype with
+ match Cil.unrollTypeNode ltype with
| TPtr _ ->
let base = Misc.ptr_base ~loc:rhs.eloc rhs in
let rhs, flow =
@@ -199,10 +199,10 @@ let assign ?(ltype) lhs rhs loc =
in Some (lhs, rhs, Copy)
(* va_list is a builtin type, we assume it has no pointers here and treat
it as a "big" integer rather than a struct *)
- | TBuiltin_va_list _ -> None
+ | TBuiltin_va_list -> None
| TArray _ -> Some (lhs, rhs, Direct)
(* void type should not happen as we are dealing with assignments *)
- | TVoid _ -> Options.fatal "Void type in assignment"
+ | TVoid -> Options.fatal "Void type in assignment"
| TFun _ -> Options.fatal "TFun type in assignment"
(* Generate a statement tracking temporal metadata associated with assignment
@@ -399,14 +399,14 @@ end
associated with adding a function argument to a stack frame *)
let track_argument ?(typ) param index env =
let typ = Option.value ~default:param.vtype typ in
- match Cil.unrollType typ with
+ match Cil.unrollTypeNode typ with
| TPtr _
| TComp _ ->
let stmt = Mk.pull_param ~loc:Location.unknown param index in
Env.add_stmt ~post:false env stmt
- | TInt _ | TFloat _ | TEnum _ | TBuiltin_va_list _ -> env
+ | TInt _ | TFloat _ | TEnum _ | TBuiltin_va_list -> env
| TNamed _ -> assert false
- | TVoid _ |TArray _ | TFun _ ->
+ | TVoid |TArray _ | TFun _ ->
Options.fatal "Failed to handle function parameter"
(* }}} *)
diff --git a/src/plugins/e-acsl/src/code_generator/translate_ats.ml b/src/plugins/e-acsl/src/code_generator/translate_ats.ml
index abd64d14c54..39e08f7eb14 100644
--- a/src/plugins/e-acsl/src/code_generator/translate_ats.ml
+++ b/src/plugins/e-acsl/src/code_generator/translate_ats.ml
@@ -330,7 +330,7 @@ let pretranslate_to_exp_with_lscope ~loc ~lscope kf env pot =
Error.not_yet "\\at on purely logic variables and over gmp type"
end
in
- let ty_ptr = TPtr(ty, []) in
+ let ty_ptr = Cil_const.mk_tptr ty in
let vi_at, e_at, env = Env.new_var
~loc
~name:"at"
diff --git a/src/plugins/e-acsl/src/code_generator/translate_terms.ml b/src/plugins/e-acsl/src/code_generator/translate_terms.ml
index 7acfb5299dd..901308d3bf5 100644
--- a/src/plugins/e-acsl/src/code_generator/translate_terms.ml
+++ b/src/plugins/e-acsl/src/code_generator/translate_terms.ml
@@ -926,9 +926,9 @@ let untyped_to_exp typ t =
if Gmp_types.Z.is_t ty then Typing.gmpz
else if Gmp_types.Q.is_t ty then Typing.rational
else
- match ty with
- | TInt(ik, _) | TEnum({ ekind = ik }, _) -> Typing.ikind ik
- | TFloat(fk, _) -> Typing.fkind fk
+ match ty.tnode with
+ | TInt ik | TEnum { ekind = ik } -> Typing.ikind ik
+ | TFloat fk -> Typing.fkind fk
| _ -> Typing.nan
in
let ctx = Option.map ctx_of_typ typ in
diff --git a/src/plugins/e-acsl/src/libraries/builtins.ml b/src/plugins/e-acsl/src/libraries/builtins.ml
index 1bc6796a452..a8f0b49948e 100644
--- a/src/plugins/e-acsl/src/libraries/builtins.ml
+++ b/src/plugins/e-acsl/src/libraries/builtins.ml
@@ -45,10 +45,10 @@ let add_builtin vi already =
if not already then
let bl_name = vi.vname in
if Options.Builtins.mem bl_name then
- match Cil.unrollType vi.vtype with
- | TFun(ret_typ, param_typs, _, _) ->
- let bl_type = match Cil.unrollType ret_typ with
- | TVoid _ ->
+ match Cil.unrollTypeNode vi.vtype with
+ | TFun(ret_typ, param_typs, _) ->
+ let bl_type = match Cil.unrollTypeNode ret_typ with
+ | TVoid ->
Options.fatal
"Expecting a non-void return type for the E-ACSL built-in %s"
bl_name
diff --git a/src/plugins/e-acsl/src/libraries/functions.ml b/src/plugins/e-acsl/src/libraries/functions.ml
index 569ccc20e25..27ebb55e598 100644
--- a/src/plugins/e-acsl/src/libraries/functions.ml
+++ b/src/plugins/e-acsl/src/libraries/functions.ml
@@ -160,18 +160,18 @@ module Libc = struct
| FLongDouble -> "E" (* [long double] *)
in
(* get a character representing a pointer type *)
- let get_pkind_str a ty = match ty with
- | TInt(IChar,_) | TInt(ISChar,_) -> "s" (* [char*] *)
- | TInt(IUChar,_) -> "S" (* [unsigned char*] *)
- | TInt(IShort,_) -> "q" (* [short*] *)
- | TInt(IUShort,_) -> "Q" (* [unsigned short*] *)
- | TInt(IInt,_) -> "i" (* [int*] *)
- | TInt(IUInt,_) -> "I" (* [unsigned int*] *)
- | TInt(ILong,_) -> "z" (* [long int*] *)
- | TInt(IULong,_) -> "Z" (* [unsigned long int*] *)
- | TInt(ILongLong,_) -> "w" (* [long int*] *)
- | TInt(IULongLong,_) -> "W" (* [unsigned long int*] *)
- | TVoid _ -> "p" (* [void*] *)
+ let get_pkind_str a ty = match ty.tnode with
+ | TInt IChar | TInt ISChar -> "s" (* [char*] *)
+ | TInt IUChar -> "S" (* [unsigned char*] *)
+ | TInt IShort -> "q" (* [short*] *)
+ | TInt IUShort -> "Q" (* [unsigned short*] *)
+ | TInt IInt -> "i" (* [int*] *)
+ | TInt IUInt -> "I" (* [unsigned int*] *)
+ | TInt ILong -> "z" (* [long int*] *)
+ | TInt IULong -> "Z" (* [unsigned long int*] *)
+ | TInt ILongLong -> "w" (* [long int*] *)
+ | TInt IULongLong -> "W" (* [unsigned long int*] *)
+ | TVoid -> "p" (* [void*] *)
| _ ->
Options.fatal "unexpected argument type in printf: type %a of arg %a@."
Printer.pp_typ ty
@@ -180,12 +180,12 @@ module Libc = struct
let exps = drop (printf_fmt_position fn) args in
let param_str =
List.fold_right
- (fun exp acc -> match Cil.unrollType (Cil.typeOf exp) with
- | TInt(k, _) -> get_ikind_str k ^ acc
- | TFloat(k, _) -> get_fkind_str k ^ acc
- | TPtr(ty, _) -> get_pkind_str exp (Cil.unrollType ty) ^ acc
- | TVoid _ | TArray _ | TFun _ | TNamed _ | TComp _ | TEnum _
- | TBuiltin_va_list _ -> assert false)
+ (fun exp acc -> match Cil.(unrollTypeNode (typeOf exp)) with
+ | TInt k -> get_ikind_str k ^ acc
+ | TFloat k -> get_fkind_str k ^ acc
+ | TPtr ty -> get_pkind_str exp (Cil.unrollType ty) ^ acc
+ | TVoid | TArray _ | TFun _ | TNamed _ | TComp _ | TEnum _
+ | TBuiltin_va_list -> assert false)
exps
""
in
diff --git a/src/plugins/e-acsl/src/libraries/gmp_types.ml b/src/plugins/e-acsl/src/libraries/gmp_types.ml
index ff29828ad1a..2c1cab948ac 100644
--- a/src/plugins/e-acsl/src/libraries/gmp_types.ml
+++ b/src/plugins/e-acsl/src/libraries/gmp_types.ml
@@ -32,7 +32,7 @@ let mk_dummy_type_info_ref () =
ref
{ torig_name = "";
tname = "";
- ttype = TVoid [];
+ ttype = Cil_const.voidType;
treferenced = false }
module type S = sig
@@ -52,7 +52,7 @@ module Make() = struct
let is_now_referenced () = !t_torig_ref.treferenced <- true
- let t () = TNamed(!t_torig_ref, [])
+ let t () = Cil_const.mk_tnamed !t_torig_ref
(* create a unique shared representation in order to use [==] in [is_t] *)
let t_as_ptr_info =
@@ -60,17 +60,16 @@ module Make() = struct
{
torig_name = "";
tname = !t_struct_torig_ref.tname ^ " *";
- ttype = TArray(
- TNamed(!t_struct_torig_ref, []),
- Some (Cil.one ~loc:Cil_datatype.Location.unknown),
- []);
+ ttype =
+ Cil_const.(mk_tarray (mk_tnamed !t_struct_torig_ref)
+ (Some (Cil.one ~loc:Cil_datatype.Location.unknown)));
treferenced = true;
}
- let t_as_ptr () = TNamed (Lazy.force t_as_ptr_info, [])
+ let t_as_ptr () = Cil_const.mk_tnamed (Lazy.force t_as_ptr_info)
- let is_t ty = match ty with
- | TNamed(tinfo, []) ->
+ let is_t ty = match ty.tnode with
+ | TNamed tinfo ->
tinfo == !t_torig_ref || tinfo == Lazy.force t_as_ptr_info
| _ -> false
@@ -82,7 +81,7 @@ module Q = Make()
let bitcnt_type_info_ref = mk_dummy_type_info_ref ()
let set_bitcnt_t tinfo = bitcnt_type_info_ref := tinfo
-let bitcnt_t () = TNamed(!bitcnt_type_info_ref, [])
+let bitcnt_t () = Cil_const.mk_tnamed !bitcnt_type_info_ref
(**************************************************************************)
(******************* Initialization of mpz and mpq types ******************)
diff --git a/src/plugins/e-acsl/src/libraries/interval_utils.ml b/src/plugins/e-acsl/src/libraries/interval_utils.ml
index b066e1347a1..ef070f5b744 100644
--- a/src/plugins/e-acsl/src/libraries/interval_utils.ml
+++ b/src/plugins/e-acsl/src/libraries/interval_utils.ml
@@ -233,7 +233,7 @@ let interv_of_unknown_block =
lazy (ival Integer.zero (Bit_utils.max_byte_address ()))
let ival_of_ikind ik =
- let n = Cil.bitsSizeOf (TInt (ik, [])) in
+ let n = Cil.bitsSizeOf (Cil_const.mk_tint ik) in
let l, u =
if Cil.isSigned ik then Cil.min_signed_number n, Cil.max_signed_number n
else Integer.zero, Cil.max_unsigned_number n
@@ -241,18 +241,18 @@ let ival_of_ikind ik =
Ival.inject_range (Some l) (Some u)
(* The boolean indicates whether we have real numbers *)
-let rec interv_of_typ ty = match Cil.unrollType ty with
- | TInt (k,_) ->
+let rec interv_of_typ ty = match Cil.unrollTypeNode ty with
+ | TInt k ->
Ival (ival_of_ikind k)
- | TEnum(enuminfo, _) ->
- interv_of_typ (TInt(enuminfo.ekind, []))
+ | TEnum enuminfo ->
+ interv_of_typ (Cil_const.mk_tint enuminfo.ekind)
| _ when Gmp_types.Z.is_t ty ->
top_ival
- | TFloat (k, _) ->
- Float(k, None)
+ | TFloat k ->
+ Float (k, None)
| _ when Gmp_types.Q.is_t ty ->
Rational (* only rationals are implemented *)
- | TVoid _ | TPtr _ | TArray _ | TFun _ | TComp _ | TBuiltin_va_list _ ->
+ | TVoid | TPtr _ | TArray _ | TFun _ | TComp _ | TBuiltin_va_list ->
Nan
| TNamed _ ->
assert false
diff --git a/src/plugins/e-acsl/src/libraries/logic_aggr.ml b/src/plugins/e-acsl/src/libraries/logic_aggr.ml
index 1674e8941bf..44e51f9fda6 100644
--- a/src/plugins/e-acsl/src/libraries/logic_aggr.ml
+++ b/src/plugins/e-acsl/src/libraries/logic_aggr.ml
@@ -34,9 +34,9 @@ let rec get_array_typ_opt ty =
*)
None
else
- match ty with
- | TNamed (r, _) -> get_array_typ_opt r.ttype
- | TArray (t, eo, a) -> Some (t, eo, a)
+ match ty.tnode with
+ | TNamed ti -> get_array_typ_opt ti.ttype
+ | TArray (t, eo) -> Some (t, eo, ty.tattr)
| _ -> None
(** @return true iff the type is an array *)
diff --git a/src/plugins/e-acsl/src/libraries/misc.ml b/src/plugins/e-acsl/src/libraries/misc.ml
index 134bd50eee3..3c8849e72a9 100644
--- a/src/plugins/e-acsl/src/libraries/misc.ml
+++ b/src/plugins/e-acsl/src/libraries/misc.ml
@@ -158,8 +158,8 @@ let is_range_free t =
let is_bitfield_pointers lty =
let is_bitfield_pointer = function
| Ctype typ ->
- begin match Cil.unrollType typ with
- | TPtr(typ, _) ->
+ begin match Cil.unrollTypeNode typ with
+ | TPtr typ ->
let attrs = Cil.typeAttrs typ in
Cil.hasAttribute Cil.bitfield_attribute_name attrs
| _ ->
diff --git a/src/plugins/e-acsl/src/project_initializer/prepare_ast.ml b/src/plugins/e-acsl/src/project_initializer/prepare_ast.ml
index 37f2c3a2477..f3bfc216fb3 100644
--- a/src/plugins/e-acsl/src/project_initializer/prepare_ast.ml
+++ b/src/plugins/e-acsl/src/project_initializer/prepare_ast.ml
@@ -574,8 +574,9 @@ let sound_verdict_vi =
let sound_verdict () = Lazy.force sound_verdict_vi
-let is_variadic_function vi = match Cil.unrollType vi.vtype with
- | TFun(_, _, variadic, _) -> variadic
+let is_variadic_function vi =
+ match Cil.unrollTypeNode vi.vtype with
+ | TFun(_, _, variadic) -> variadic
| _ -> false
(* set of functions that must never be duplicated *)
diff --git a/src/plugins/eva/alarmset.ml b/src/plugins/eva/alarmset.ml
index 80c008f0413..f24515c5e8f 100644
--- a/src/plugins/eva/alarmset.ml
+++ b/src/plugins/eva/alarmset.ml
@@ -388,8 +388,8 @@ let height_alarm = let open Eva_utils in function
| Alarms.Overlap (lv1,lv2) -> max (height_lval lv1) (height_lval lv2) + 1
| Alarms.Is_nan_or_infinite (e, fkind)
| Alarms.Is_nan (e, fkind) ->
- let trivial = match Cil.typeOf e with
- | TFloat (fk, _) -> fk = fkind
+ let trivial = match Cil.(typeOf e).tnode with
+ | TFloat fk -> fk = fkind
| _ -> false
in
if trivial then height_expr e else height_expr e + 1
diff --git a/src/plugins/eva/api/values_request.ml b/src/plugins/eva/api/values_request.ml
index 83aec8185f7..0a526a863a7 100644
--- a/src/plugins/eva/api/values_request.ml
+++ b/src/plugins/eva/api/values_request.ml
@@ -462,7 +462,7 @@ module Proxy(A : Analysis.Engine) : EvaProxy = struct
find_offsetmap cvalue_state precise_loc
let eval_lval (lval : Eva_ast.lval) state =
- match Cil.unrollType lval.typ with
+ match Cil.unrollTypeNode lval.typ with
| TInt _ | TEnum _ | TPtr _ | TFloat _ ->
A.copy_lvalue state lval >>=: fun value -> Value value
| _ ->
diff --git a/src/plugins/eva/ast/eva_ast_builder.ml b/src/plugins/eva/ast/eva_ast_builder.ml
index ad113ab9870..20053ab038c 100644
--- a/src/plugins/eva/ast/eva_ast_builder.ml
+++ b/src/plugins/eva/ast/eva_ast_builder.ml
@@ -212,8 +212,8 @@ struct
let field (base : lval) (field : Cil_types.fieldinfo) : lval =
let field_belongs_to_typ fi typ =
- match typ with
- | Cil_types.TComp (ci,_attr) -> ci == fi.Cil_types.fcomp
+ match typ.Cil_types.tnode with
+ | TComp ci -> ci == fi.Cil_types.fcomp
| _ -> false
in
assert (field_belongs_to_typ field base.typ);
@@ -237,15 +237,15 @@ end
(* --- Condition normalization --- *)
let zero_typed (typ : Cil_types.typ) =
- match typ with
- | TFloat (fk, _) -> mk_exp (Const (CReal (0., fk, None)))
- | TEnum ({ekind = ik },_)
- | TInt (ik, _) -> mk_exp (Const (CInt64 (Integer.zero, ik, None)))
+ match typ.tnode with
+ | TFloat fk -> mk_exp (Const (CReal (0., fk, None)))
+ | TEnum {ekind = ik }
+ | TInt ik -> mk_exp (Const (CInt64 (Integer.zero, ik, None)))
| TPtr _ ->
let ik = Machine.uintptr_kind () in
let zero = mk_exp (Const (CInt64 (Integer.zero, ik, None))) in
Build.cast typ zero
- | typ ->
+ | _ ->
Self.fatal ~current:true "non-scalar type %a" Printer.pp_typ typ
(* Transform an expression supposed to be [positive] into an equivalent
diff --git a/src/plugins/eva/ast/eva_ast_typing.ml b/src/plugins/eva/ast/eva_ast_typing.ml
index 7b5974c8778..a14775fd2c4 100644
--- a/src/plugins/eva/ast/eva_ast_typing.ml
+++ b/src/plugins/eva/ast/eva_ast_typing.ml
@@ -23,13 +23,13 @@
open Eva_ast_types
let type_of_const : constant -> typ = function
- | CTopInt ik -> Cil_types.TInt (ik, [])
- | CInt64 (_, ik, _) -> Cil_types.TInt (ik, [])
+ | CTopInt ik -> Cil_const.mk_tint ik
+ | CInt64 (_, ik, _) -> Cil_const.mk_tint ik
| CChr _ -> Cil_const.intType
| CString (String (_, Base.CSString _)) -> Machine.string_literal_type ()
- | CString (String (_, Base.CSWstring _)) -> TPtr (Machine.wchar_type (), [])
+ | CString (String (_, Base.CSWstring _)) -> Cil_const.mk_tptr (Machine.wchar_type ())
| CString (_) -> assert false (* it must be a String base*)
- | CReal (_, fk, _) -> TFloat (fk, [])
+ | CReal (_, fk, _) -> Cil_const.mk_tfloat fk
| CEnum (_ei, e) -> e.typ
let rec type_of_offset (basetyp : typ) : offset -> typ = function
@@ -37,7 +37,7 @@ let rec type_of_offset (basetyp : typ) : offset -> typ = function
| Index (_, o) ->
type_of_offset (Cil.typeOf_array_elem basetyp) o
| Field (fi, o) ->
- let base_attrs = Cil.typeAttr (Cil.unrollType basetyp) in
+ let base_attrs = (Cil.unrollType basetyp).tattr in
let base_attrs = Cil.filter_qualifier_attributes base_attrs in
let base_attrs =
if Cil.hasAttribute Cil.frama_c_mutable fi.fattr then
@@ -61,8 +61,8 @@ let type_of_exp_node : exp_node -> typ = function
| UnOp (_, _, t) -> t
| BinOp (_, _, _, t) -> t
| CastE (t, _) -> t
- | AddrOf lv -> TPtr (lv.typ, [])
+ | AddrOf lv -> Cil_const.mk_tptr lv.typ
| StartOf lv ->
match Cil.unrollType lv.typ with
- | TArray (t, _, attrs) -> TPtr (t, attrs)
+ | { tnode = TArray (t, _); tattr } -> Cil_const.mk_tptr ~tattr t
| _ -> assert false
diff --git a/src/plugins/eva/ast/eva_ast_utils.ml b/src/plugins/eva/ast/eva_ast_utils.ml
index 41ac838c7e3..5bb2c6e93af 100644
--- a/src/plugins/eva/ast/eva_ast_utils.ml
+++ b/src/plugins/eva/ast/eva_ast_utils.ml
@@ -116,13 +116,14 @@ let is_mutable (lval : lval) : bool =
let (lhost, offset) = lval.node in
let rec aux base_mutable typ off =
let base_mutable = base_mutable && not (Cil.isConstType typ) in
- match Cil.unrollType typ, off with
+ let typ = Cil.unrollType typ in
+ match typ.tnode, off with
| _, NoOffset -> base_mutable
| _, Field (fi, off) ->
let base_mutable = base_mutable || Cil.(hasAttribute frama_c_mutable fi.fattr) in
aux base_mutable fi.ftype off
- | TArray(typ, _, _), Index(_, off) -> aux base_mutable typ off
- | typ, Index _ ->
+ | TArray(typ, _), Index(_, off) -> aux base_mutable typ off
+ | _, Index _ ->
Self.fatal "Index on non-array type %a" Printer.pp_typ typ
in
aux false (Eva_ast_typing.type_of_lhost lhost) offset
@@ -308,9 +309,9 @@ let to_value exp =
| _ -> `None
let type_kind typ =
- match Cil.unrollType typ with
- | TInt (ikind, _) | TEnum ({ekind = ikind}, _) -> `Int ikind
- | TFloat (fkind, _) -> `Float fkind
+ match Cil.unrollTypeNode typ with
+ | TInt ikind | TEnum {ekind = ikind} -> `Int ikind
+ | TFloat fkind -> `Float fkind
| _ -> `None
(* These functions are largely based on Cil.constFold. See there for details. *)
@@ -329,7 +330,7 @@ let rec const_fold (exp: exp) : exp =
and const_fold_cast (t : typ) (e : exp) : exp =
let e = const_fold e in
let default () = mk_exp (CastE (t, e)) in
- if Cil.typeAttr t <> [] then
+ if t.tattr <> [] then
default ()
else
match to_value e, type_kind t with
diff --git a/src/plugins/eva/domains/apron/apron_domain.ml b/src/plugins/eva/domains/apron/apron_domain.ml
index be834113d07..c8824d7ede9 100644
--- a/src/plugins/eva/domains/apron/apron_domain.ml
+++ b/src/plugins/eva/domains/apron/apron_domain.ml
@@ -180,7 +180,7 @@ let reduce eval expr range =
If overflows are not allowed for the type [typ], then [texpr = e]. *)
let coerce ?(cast=false) eval typ texpr =
match Cil.unrollType typ with
- | TInt (ikind, attrs) | TEnum ({ ekind = ikind}, attrs) ->
+ | { tnode = (TInt ikind | TEnum { ekind = ikind }); tattr } ->
let signed = Cil.isSigned ikind in
if
not cast
@@ -189,13 +189,13 @@ let coerce ?(cast=false) eval typ texpr =
then
texpr
else
- let range = Eval_typ.ik_attrs_range ikind attrs in
+ let range = Eval_typ.ik_attrs_range ikind tattr in
reduce eval texpr range
| _ -> raise (Out_of_Scope "coerce not integer")
let translate_typ typ =
- match Cil.unrollType typ with
+ match Cil.unrollTypeNode typ with
| TInt _ | TEnum _ -> Texpr1.Int
| _ -> raise (Out_of_Scope "translate_typ not int")
@@ -225,8 +225,8 @@ let translate_varinfo varinfo =
if not (is_relevant_varinfo varinfo)
then raise (Out_of_Scope "translate_varinfo irrelevant")
else
- match Cil.unrollType varinfo.vtype with
- | TInt (ik, _) | TEnum ({ekind=ik}, _) ->
+ match Cil.unrollTypeNode varinfo.vtype with
+ | TInt ik | TEnum {ekind=ik} ->
let id = "_" ^ string_of_int varinfo.vid in
let name = varinfo.vname ^ id in
let var = Var.of_string name in
@@ -300,13 +300,13 @@ let constraint_reduction env expr interval =
let truncate_interval typ interval =
match Cil.unrollType typ with
- | TInt (ikind, attrs) | TEnum ({ ekind = ikind }, attrs) ->
+ | { tnode = (TInt ikind | TEnum { ekind = ikind }); tattr } ->
let signed = Cil.isSigned ikind in
if
(signed && not (Kernel.SignedOverflow.get ()))
|| ((not signed) && not (Kernel.UnsignedOverflow.get ()))
then
- let range = Eval_typ.ik_attrs_range ikind attrs in
+ let range = Eval_typ.ik_attrs_range ikind tattr in
let inf, sup, _size = bounds_of_typ range in
let inf = Scalar.of_mpqf (Mpqf.of_mpz inf)
and sup = Scalar.of_mpqf (Mpqf.of_mpz sup) in
diff --git a/src/plugins/eva/domains/cvalue/builtins.ml b/src/plugins/eva/domains/cvalue/builtins.ml
index deb6c2b4a9e..b1419f6673d 100644
--- a/src/plugins/eva/domains/cvalue/builtins.ml
+++ b/src/plugins/eva/domains/cvalue/builtins.ml
@@ -133,8 +133,8 @@ let inconsistent_builtin_typ kf = function
| None -> false (* No expected type provided with the builtin, no check. *)
| Some typ ->
let expected_result, expected_args = typ () in
- match Kernel_function.get_type kf with
- | TFun (result, args, _, _) ->
+ match (Kernel_function.get_type kf).tnode with
+ | TFun (result, args, _) ->
(* If a builtin expects a void pointer, then accept all pointer types. *)
let need_cast typ expected =
Cil.need_cast typ expected
diff --git a/src/plugins/eva/domains/cvalue/builtins_float.ml b/src/plugins/eva/domains/cvalue/builtins_float.ml
index 0662cbfec4b..ccef92af88f 100644
--- a/src/plugins/eva/domains/cvalue/builtins_float.ml
+++ b/src/plugins/eva/domains/cvalue/builtins_float.ml
@@ -60,7 +60,7 @@ let arity2 fk caml_fun _state actuals =
let register_arity2 c_name fk f =
let name = "Frama_C_" ^ c_name in
let replace = c_name in
- let t = Cil_types.TFloat (fk, []) in
+ let t = Cil_const.mk_tfloat fk in
let typ () = t, [t; t] in
Builtins.register_builtin name ~replace ~typ Cacheable (arity2 fk f)
@@ -99,7 +99,7 @@ let arity1 name fk caml_fun _state actuals =
let register_arity1 c_name fk f =
let name = "Frama_C_" ^ c_name in
let replace = c_name in
- let t = Cil_types.TFloat (fk, []) in
+ let t = Cil_const.mk_tfloat fk in
let typ () = t, [t] in
Builtins.register_builtin name ~replace ~typ Cacheable (arity1 name fk f)
diff --git a/src/plugins/eva/domains/cvalue/builtins_malloc.ml b/src/plugins/eva/domains/cvalue/builtins_malloc.ml
index 8ec8dba4557..0d2978f299d 100644
--- a/src/plugins/eva/domains/cvalue/builtins_malloc.ml
+++ b/src/plugins/eva/domains/cvalue/builtins_malloc.ml
@@ -208,8 +208,8 @@ let guess_intended_malloc_type stack sizev constant_size =
else None
in
let mk_typed_size t =
- match Cil.unrollType t with
- | TPtr (t, _) when not (Cil.isVoidType t) ->
+ match Cil.unrollTypeNode t with
+ | TPtr t when not (Cil.isVoidType t) ->
let s = Int.of_int (Cil.bytesSizeOf t) in
if Int.(equal s zero) ||
(Int.equal (Int.e_rem size_min s) Int.zero &&
@@ -239,22 +239,23 @@ let guess_intended_malloc_type stack sizev constant_size =
let type_from_nb_elems tsize =
let typ = tsize.elem_typ in
match tsize.nb_elems with
- | None -> TArray (typ, None, [])
+ | None -> Cil_const.mk_tarray typ None
| Some nb ->
if Int.equal Int.one nb
then typ
else
let loc = Current_loc.get () in
let esize_arr = Cil.kinteger64 ~loc nb in (* [nb] fits in size_t *)
- TArray (typ, Some esize_arr, [])
+ Cil_const.mk_tarray typ (Some esize_arr)
(* Generalize a type into an array type without size. Useful for variables
whose size is mutated. *)
let weaken_type typ =
match Cil.unrollType typ with
- | TArray (_, None, _) -> typ
- | TArray (typ, Some _, _) | typ ->
- TArray (typ, None, [])
+ | { tnode = TArray (_, None) } -> typ
+ | { tnode = TArray (typ, Some _) }
+ | typ ->
+ Cil_const.mk_tarray typ None
(* size for which the base is certain to be valid *)
let size_sure_valid b = match Base.validity b with
@@ -385,9 +386,7 @@ let string_of_region = function
(* Only called when the 'weakest base' needs to be allocated. *)
let create_weakest_base region =
let stack = { (Eva_utils.current_call_stack ()) with stack = [] } in
- let type_base =
- TArray (Cil_const.charType, None, [])
- in
+ let type_base = Cil_const.(mk_tarray charType None) in
let var = create_new_var stack "alloc" type_base Weak in
Self.warning ~wkey:wkey_imprecise_alloc ~current:true ~once:true
"allocating a single weak variable for ALL dynamic allocations %s: %a"
diff --git a/src/plugins/eva/domains/cvalue/builtins_memory.ml b/src/plugins/eva/domains/cvalue/builtins_memory.ml
index 92ccde4b0c8..368c28eb9df 100644
--- a/src/plugins/eva/domains/cvalue/builtins_memory.ml
+++ b/src/plugins/eva/domains/cvalue/builtins_memory.ml
@@ -388,7 +388,7 @@ let memset_typ_offsm_int full_typ i =
let vinit = V_Or_Uninitialized.initialized v in
V_Offsetmap.add bounds (vinit, size, Rel.zero) offsm
in
- match Cil.unrollType styp with
+ match Cil.unrollTypeNode styp with
| TInt _ | TEnum _ | TPtr _ ->
let size = Eval_typ.sizeof_lval_typ styp (* handles bitfields *) in
let size = Int_Base.project size in
@@ -404,16 +404,16 @@ let memset_typ_offsm_int full_typ i =
(* Do not produce NaN or infinites here (unless they are accepted
by the engine). *)
if Fval.is_finite f = True then update size v' else update size v
- | TComp ({ cstruct = true ; cfields = l}, _) -> (* struct *)
+ | TComp { cstruct = true ; cfields = l} -> (* struct *)
let aux_field offsm fi =
let offset_fi = Int.of_int (fst (Cil.fieldBitsOffset fi)) in
aux fi.ftype (Int.add offset offset_fi) offsm
in
List.fold_left aux_field offsm (Option.value ~default:[] l)
- | TComp ({ cstruct = false ; cfields = l}, _) -> (* union *)
+ | TComp { cstruct = false ; cfields = l} -> (* union *)
(* Use only the first field. This is somewhat arbitrary *)
aux (List.hd (Option.get l)).ftype offset offsm
- | TArray (typelt, nb, _) -> begin
+ | TArray (typelt, nb) -> begin
let nb = Cil.lenOfArray64 nb in (* always succeeds, we computed the
size of the entire type earlier *)
if Integer.(gt nb zero) then begin
@@ -451,7 +451,7 @@ let memset_typ_offsm_int full_typ i =
else offsm (* size = 0. Do nothing, this is supposed to be invalid
anyway *)
end
- | TVoid _ | TFun _ | TBuiltin_va_list _ ->
+ | TVoid | TFun _ | TBuiltin_va_list ->
raise (ImpreciseMemset UnsupportedType)
| TNamed _ -> assert false (* unrolled *)
in
diff --git a/src/plugins/eva/domains/cvalue/cvalue_init.ml b/src/plugins/eva/domains/cvalue/cvalue_init.ml
index b346feec54e..4eb908e4a98 100644
--- a/src/plugins/eva/domains/cvalue/cvalue_init.ml
+++ b/src/plugins/eva/domains/cvalue/cvalue_init.ml
@@ -67,8 +67,8 @@ let create_hidden_base ~libc ~valid ~hidden_var_name ~name_desc pointed_typ =
let validity =
(* Add a special case for void* pointers: we do not want to compute the
size of void *)
- let validity = match Cil.unrollType pointed_typ with
- | TVoid _ -> Base.Unknown (Integer.zero, None, Bit_utils.max_bit_address ())
+ let validity = match Cil.unrollTypeNode pointed_typ with
+ | TVoid -> Base.Unknown (Integer.zero, None, Bit_utils.max_bit_address ())
| _ -> Base.validity_from_type hidden_var
in
match validity with
@@ -96,8 +96,8 @@ let create_hidden_base ~libc ~valid ~hidden_var_name ~name_desc pointed_typ =
let reject_empty_struct b offset typ =
- match Cil.unrollType typ with
- | TComp (ci, _) ->
+ match Cil.unrollTypeNode typ with
+ | TComp ci ->
if ci.cfields = Some [] && not (Machine.acceptEmptyCompinfo ()) then
Self.abort ~current:true
"@[empty %ss@ are unsupported@ (type '%a',@ location %a%a)@ \
@@ -116,11 +116,11 @@ let initialize_var_using_type varinfo state =
let bind_entire_loc ?(state=state) v = (* Shortcut *)
add_initialized state (Lazy.force loc) v
in
- match typ with
- | TInt _ | TEnum (_, _)->
+ match typ.tnode with
+ | TInt _ | TEnum _ ->
bind_entire_loc Cvalue.V.top_int
- | TFloat (fkind, _) -> begin
+ | TFloat fkind -> begin
(* TODO: depend on the option for finitness *)
bind_entire_loc
(Cvalue.V.inject_float (Fval.top_finite (Fval.kind fkind)))
@@ -128,14 +128,14 @@ let initialize_var_using_type varinfo state =
| TFun _ -> state
- | TPtr (typ, _) as full_typ
+ | TPtr typ'
when depth <= Parameters.AutomaticContextMaxDepth.get () ->
- let attr = Cil.typeAttrs full_typ in
+ let attr = Cil.typeAttrs typ in
let libc = Cil.is_in_libc varinfo.vattr in
let context_max_width =
Parameters.AutomaticContextMaxWidth.get ()
in begin
- match Cil.isVoidType typ, Cil.isFunctionType typ with
+ match Cil.isVoidType typ', Cil.isFunctionType typ' with
| false, false -> (* non-void, non-function *)
let i =
match Cil.findAttribute "arraylen" attr with
@@ -143,9 +143,7 @@ let initialize_var_using_type varinfo state =
| _ -> Integer.of_int context_max_width
in
let arr_pointed_typ =
- TArray(typ,
- Some (Cil.kinteger64 ~loc:varinfo.vdecl i),
- [])
+ Cil_const.mk_tarray typ' (Some (Cil.kinteger64 ~loc:varinfo.vdecl i))
in
let hidden_var_name =
Cabs2cil.fresh_global ("S_" ^ name)
@@ -154,7 +152,7 @@ let initialize_var_using_type varinfo state =
(* Make first cell of the array valid. The NULL pointer takes
care of a potential invalid pointer. *)
let valid =
- try KnownThenUnknownValidity (Integer.of_int (Cil.bitsSizeOf typ))
+ try KnownThenUnknownValidity (Integer.of_int (Cil.bitsSizeOf typ'))
with Cil.SizeOfError _ -> UnknownValidity
in
let hidden_base =
@@ -184,7 +182,7 @@ let initialize_var_using_type varinfo state =
let name_desc = "*"^name_desc in
let valid = UnknownValidity in
let hidden_base =
- create_hidden_base ~libc ~valid ~hidden_var_name ~name_desc typ
+ create_hidden_base ~libc ~valid ~hidden_var_name ~name_desc typ'
in
make_well hidden_base state (Lazy.force loc)
| false, true -> (* function *)
@@ -194,7 +192,7 @@ let initialize_var_using_type varinfo state =
| true, true -> assert false (* inconsistent *)
end
- | TArray (typ, len, _) ->
+ | TArray (typ, len) ->
begin try
let size = Cil.lenOfArray len in
let size_elt = Integer.of_int (Cil.bitsSizeOf typ) in
@@ -298,7 +296,7 @@ let initialize_var_using_type varinfo state =
bind_entire_loc Cvalue.V.top_int;
end
- | TComp ({cstruct=true;} as compinfo, _) -> (* Struct *)
+ | TComp ({cstruct=true} as compinfo) -> (* Struct *)
reject_empty_struct b offset_orig typ;
let treat_field state field =
match field.fbitfield with
@@ -319,7 +317,7 @@ let initialize_var_using_type varinfo state =
bind_entire_loc Cvalue.V.top_int;
end
- | TComp ({cstruct=false}, _) when Cil.is_fully_arithmetic typ ->
+ | TComp {cstruct=false} when Cil.is_fully_arithmetic typ ->
reject_empty_struct b offset_orig typ;
(* Union of arithmetic types *)
bind_entire_loc Cvalue.V.top_int
@@ -328,7 +326,7 @@ let initialize_var_using_type varinfo state =
(* deep pointers map to NULL in this case *)
bind_entire_loc Cvalue.V.singleton_zero
- | TBuiltin_va_list _ | TComp _ | TVoid _ | TPtr _ ->
+ | TBuiltin_va_list | TComp _ | TVoid | TPtr _ ->
reject_empty_struct b offset_orig typ;
(* variable arguments or union with non-arithmetic type
or deep pointers *)
@@ -344,7 +342,7 @@ let initialize_var_using_type varinfo state =
let validity = Base.Known (Integer.zero, Bit_utils.max_bit_address ()) in
let hidden_base = Base.register_memory_var hidden_var validity in
make_well hidden_base state (Lazy.force loc)
- | TNamed (_, _) -> assert false
+ | TNamed _ -> assert false
in
add_offsetmap
0
diff --git a/src/plugins/eva/domains/multidim/abstract_offset.ml b/src/plugins/eva/domains/multidim/abstract_offset.ml
index 7f0dcce69f2..2ce48afb2dc 100644
--- a/src/plugins/eva/domains/multidim/abstract_offset.ml
+++ b/src/plugins/eva/domains/multidim/abstract_offset.ml
@@ -125,8 +125,8 @@ let rec of_eva_offset (oracle : Eva_ast.exp -> Int_val.t) base_typ = function
let+ sub' = of_eva_offset oracle fi.ftype sub in
Field (fi, sub')
| Index (exp, sub) ->
- match Cil.unrollType base_typ with
- | TArray (elem_typ, array_size, _) ->
+ match Cil.unrollTypeNode base_typ with
+ | TArray (elem_typ, array_size) ->
let idx = oracle exp in
let+ () = assert_valid_index idx array_size
and+ sub' = of_eva_offset oracle elem_typ sub in
@@ -137,8 +137,8 @@ let rec of_int_val ~base_typ ~typ ival =
if Int_val.is_zero ival && Bit_utils.type_compatible base_typ typ then
`Value (NoOffset typ)
else
- match Cil.unrollType base_typ with
- | TArray (elem_typ, array_size, _) ->
+ match Cil.unrollTypeNode base_typ with
+ | TArray (elem_typ, array_size) ->
let* range, rem =
try
let elem_size = Integer.of_int (Cil.bitsSizeOf elem_typ) in
@@ -164,7 +164,7 @@ let rec of_int_val ~base_typ ~typ ival =
and+ sub' = of_int_val ~base_typ:elem_typ ~typ rem in
Index (None, range, elem_typ, sub')
- | TComp (ci, _) ->
+ | TComp ci ->
if not ci.cstruct then
(* Ignore unions for now *)
`Top
@@ -225,8 +225,8 @@ let rec of_term_offset base_typ = function
let+ sub' = of_term_offset fi.ftype sub in
Field (fi, sub')
| TIndex (index, sub) ->
- begin match Cil.unrollType base_typ with
- | TArray (elem_typ, array_size, _) ->
+ begin match Cil.unrollTypeNode base_typ with
+ | TArray (elem_typ, array_size) ->
let* idx = index_of_term array_size index in
let+ () = assert_valid_index idx array_size
and+ sub' = of_term_offset elem_typ sub in
diff --git a/src/plugins/eva/domains/multidim/multidim.ml b/src/plugins/eva/domains/multidim/multidim.ml
index 0687f585da8..caee80f840f 100644
--- a/src/plugins/eva/domains/multidim/multidim.ml
+++ b/src/plugins/eva/domains/multidim/multidim.ml
@@ -220,8 +220,8 @@ let of_offset oracle base_typ offset =
let field_offset, field_size = Cil.fieldBitsOffset fi in
aux fi.ftype (Integer.of_int field_size) (add_int x field_offset) sub
| Index (exp, sub) ->
- match base_typ with
- | TArray (elem_typ, _array_size, _) ->
+ match base_typ.tnode with
+ | TArray (elem_typ, _array_size) ->
let idx = of_exp oracle exp in
let elem_size = Integer.of_int (Cil.bitsSizeOf elem_typ) in
let x' = add x (mul_integer idx elem_size) in
diff --git a/src/plugins/eva/domains/multidim/multidim_domain.ml b/src/plugins/eva/domains/multidim/multidim_domain.ml
index 3d51abbdecf..e8aa12a9d77 100644
--- a/src/plugins/eva/domains/multidim/multidim_domain.ml
+++ b/src/plugins/eva/domains/multidim/multidim_domain.ml
@@ -499,7 +499,7 @@ struct
Value.inject_float (Fval.singleton (Fval.F.of_float f))
| UnOp (op, e, typ) ->
Value.forward_unop typ op (oracle e)
- | BinOp (op, e1, e2, TFloat (fkind, _)) ->
+ | BinOp (op, e1, e2, { tnode = TFloat fkind }) ->
Value.forward_binop_float (Fval.kind fkind) (oracle e1) op (oracle e2)
| BinOp (op, e1, e2, typ) ->
Value.forward_binop_int ~typ (oracle e1) op (oracle e2)
@@ -824,8 +824,8 @@ struct
begin match Location.of_term env arg with
| `Top -> `Value state (* can't resolve location, ignore *)
| `Value (loc,typ) ->
- begin match Cil.unrollType (Logic_utils.logicCType typ) with
- | TFloat (fkind,_) ->
+ begin match Cil.unrollTypeNode (Logic_utils.logicCType typ) with
+ | TFloat fkind ->
let update = Value.backward_is_finite positive fkind
and oracle = mk_oracle state in
reinforce ~oracle (Value_or_Uninitialized.map' update) state loc
diff --git a/src/plugins/eva/domains/octagons.ml b/src/plugins/eva/domains/octagons.ml
index 37469f52eb3..31ee16fefa2 100644
--- a/src/plugins/eva/domains/octagons.ml
+++ b/src/plugins/eva/domains/octagons.ml
@@ -56,7 +56,7 @@ end
type kind = Integer | Float
let typ_kind typ =
- match Cil.unrollType typ with
+ match Cil.unrollTypeNode typ with
| TInt _ | TEnum _ | TPtr _ -> Integer
| TFloat _ -> Float
| _ -> assert false
diff --git a/src/plugins/eva/engine/evaluation.ml b/src/plugins/eva/engine/evaluation.ml
index c661e6c5a77..6fd966e4057 100644
--- a/src/plugins/eva/engine/evaluation.ml
+++ b/src/plugins/eva/engine/evaluation.ml
@@ -161,11 +161,12 @@ let signed_ikind = function
| ILongLong | IULongLong -> ILongLong
let rec signed_counterpart typ =
- match Cil.unrollType typ with
- | TInt (ik, attrs) -> TInt (signed_ikind ik, attrs)
- | TEnum ({ekind = ik} as info, attrs) ->
- let info = { info with ekind = signed_ikind ik} in
- TEnum (info, attrs)
+ let typ = Cil.unrollType typ in
+ match typ.tnode with
+ | TInt ik -> Cil_const.mk_tint ~tattr:typ.tattr (signed_ikind ik)
+ | TEnum ei ->
+ let info = { ei with ekind = signed_ikind ei.ekind } in
+ Cil_const.mk_tenum ~tattr:typ.tattr info
| TPtr _ -> signed_counterpart ((Machine.uintptr_type ()))
| _ -> assert false
@@ -510,12 +511,12 @@ module Make
let assume_valid_value context lval res =
let open Evaluated.Operators in
let* value, origin = res in
- match Cil.unrollType lval.typ with
- | TFloat (fkind, _) ->
+ match Cil.unrollTypeNode lval.typ with
+ | TFloat fkind ->
let expr = Eva_ast.Build.lval lval in
let+ new_value = remove_special_float expr fkind value in
new_value, origin
- | TInt (IBool, _) when Kernel.InvalidBool.get () ->
+ | TInt IBool when Kernel.InvalidBool.get () ->
let one = Abstract_value.Int Integer.one in
let truth = Value.assume_bounded Alarms.Upper_bound one value in
let alarm () = Alarms.Invalid_bool (Eva_ast.to_cil_lval lval) in
@@ -970,8 +971,8 @@ module Make
| CastE (dst_typ, e) ->
let* value, volatile = root_forward_eval env e in
let v = forward_cast env.context ~dst_typ e value in
- let v = match Cil.unrollType dst_typ with
- | TFloat (fkind, _) -> let* v in remove_special_float expr fkind v
+ let v = match Cil.unrollTypeNode dst_typ with
+ | TFloat fkind -> let* v in remove_special_float expr fkind v
| TPtr _ -> let* v in assume_pointer env.context expr v
| _ -> v
in
@@ -1083,7 +1084,7 @@ module Make
let open Evaluated.Operators in
let typ_pointed, array_size =
match Cil.unrollType typ with
- | TArray (t, size, _) -> t, size
+ | { tnode = TArray (t, size) } -> t, size
| t -> Self.fatal ~current:true "Got type '%a'" Printer.pp_typ t
in
let eval = eval_offset env ~reduce_valid_index typ_pointed remaining in
diff --git a/src/plugins/eva/gui/register_gui.ml b/src/plugins/eva/gui/register_gui.ml
index e354b406fc1..a079ebbdf59 100644
--- a/src/plugins/eva/gui/register_gui.ml
+++ b/src/plugins/eva/gui/register_gui.ml
@@ -295,13 +295,8 @@ module Select (Eval: Eval) = struct
let selection = ev.Eval.expr_to_gui_selection v in
Eval.display_data_by_callstack loc selection data
- let is_scalar typ =
- match Cil.unrollType typ with
- | TInt _ | TEnum _ | TPtr _ | TFloat _ -> true
- | _ -> false
-
let select_lv main_ui loc lv =
- if is_scalar (Cil.typeOfLval lv)
+ if Cil.isScalarType (Cil.typeOfLval lv)
then select_loc main_ui Eval.lval_ev loc lv
else select_loc main_ui Eval.lval_as_offsm_ev loc lv
let select_null main_ui loc =
diff --git a/src/plugins/eva/legacy/eval_op.ml b/src/plugins/eva/legacy/eval_op.ml
index ba9a0150b35..43f30ed3b56 100644
--- a/src/plugins/eva/legacy/eval_op.ml
+++ b/src/plugins/eva/legacy/eval_op.ml
@@ -66,9 +66,9 @@ let backward_comp_float_left fkind positive comp l r =
let backward_comp_left_from_type = function
| Ctype typ -> begin
- match Cil.unrollType typ with
+ match Cil.unrollTypeNode typ with
| TInt _ | TEnum _ | TPtr _ -> backward_comp_int_left
- | TFloat (fk, _) -> backward_comp_float_left (Fval.kind fk)
+ | TFloat fk -> backward_comp_float_left (Fval.kind fk)
| _ -> (fun _ _ v _ -> v) (* should never occur anyway *)
end
| Linteger -> backward_comp_int_left
diff --git a/src/plugins/eva/legacy/eval_terms.ml b/src/plugins/eva/legacy/eval_terms.ml
index a2ca78a5b40..20701ba5b49 100644
--- a/src/plugins/eva/legacy/eval_terms.ml
+++ b/src/plugins/eva/legacy/eval_terms.ml
@@ -486,7 +486,7 @@ let rec isLogicNonCompositeType t =
let rec infer_type = function
| Ctype t ->
- (match t with
+ (match t.tnode with
| TInt _ -> Cil_const.intType
| TFloat _ -> Cil_const.doubleType
| _ -> t)
@@ -503,17 +503,17 @@ let rec infer_type = function
differences in integer and floating-point sizes, that are meaningless
in the logic *)
let same_etype t1 t2 =
- match Cil.unrollType t1, Cil.unrollType t2 with
+ match Cil.unrollTypeNode t1, Cil.unrollTypeNode t2 with
| (TInt _ | TEnum _), (TInt _ | TEnum _) -> true
| TFloat _, TFloat _ -> true
- | TPtr (p1, _), TPtr (p2, _) -> Cil_datatype.Typ.equal p1 p2
+ | TPtr p1, TPtr p2 -> Cil_datatype.Typ.equal p1 p2
| _, _ -> Cil_datatype.Typ.equal t1 t2
(* Returns the kind of floating-point represented by a logic type, or None. *)
let logic_type_fkind = function
| Ctype typ -> begin
- match Cil.unrollType typ with
- | TFloat (fkind, _) -> Some fkind
+ match Cil.unrollTypeNode typ with
+ | TFloat fkind -> Some fkind
| _ -> None
end
| _ -> None
@@ -563,8 +563,9 @@ let is_noop_cast ~src_typ ~dst_typ =
in [trm], do nothing. Otherwise, raise [exn]. Adapted from [pass_cast] *)
let pass_logic_cast exn typ trm =
match Logic_utils.unroll_type typ, Logic_utils.unroll_type trm.term_type with
- | Linteger, Ctype (TInt _ | TEnum _) -> () (* Always inclusion *)
- | Ctype (TInt _ | TEnum _ as typ), Ctype (TInt _ | TEnum _ as typeoftrm) ->
+ | Linteger, Ctype { tnode = (TInt _ | TEnum _) } -> () (* Always inclusion *)
+ | Ctype ({ tnode = (TInt _ | TEnum _) } as typ),
+ Ctype ({ tnode = (TInt _ | TEnum _) } as typeoftrm) ->
let sztyp = Bit_utils.sizeof typ in
let szexpr = Bit_utils.sizeof typeoftrm in
let styp, sexpr =
@@ -579,8 +580,8 @@ let pass_logic_cast exn typ trm =
then ()
else raise exn
- | Lreal, Ctype (TFloat _) -> () (* Always inclusion *)
- | Ctype (TFloat (f1,_)), Ctype (TFloat (f2, _)) ->
+ | Lreal, Ctype { tnode = (TFloat _) } -> () (* Always inclusion *)
+ | Ctype { tnode = (TFloat f1) }, Ctype { tnode = (TFloat f2) } ->
if Cil.frank f1 < Cil.frank f2
then raise exn
@@ -765,7 +766,7 @@ let cast_to_bool r =
and contains_non_zero = V.contains_non_zero r.eover in
let eover = V.interp_boolean ~contains_zero ~contains_non_zero in
{ eover; eunder = under_from_over eover; empty = r.empty;
- ldeps = r.ldeps; etype = TInt (IBool, []) }
+ ldeps = r.ldeps; etype = Cil_const.boolType }
(* Note: "charlen" stands for either strlen or wcslen *)
@@ -809,7 +810,7 @@ let eval_logic_charchr builtin env s c ldeps_s ldeps_c =
let eunder = under_from_over eover in
(* the C strchr function has type char*, but the logic strchr predicate has
type 𔹠*)
- let etype = TInt (IBool, []) in
+ let etype = Cil_const.boolType in
let ldeps = join_logic_deps ldeps_s ldeps_c in
{ etype; ldeps; eover; empty = false; eunder }
@@ -957,9 +958,9 @@ let eval_dangling state r =
exception Reduce_to_bottom
let int_or_float_op typ int_op float_op =
- match typ with
+ match typ.tnode with
| TInt _ | TPtr _ | TEnum _ -> int_op
- | TFloat (_fkind, _) -> float_op
+ | TFloat _fk -> float_op
| _ -> ast_error (Format.asprintf
"binop on incorrect type %a" Printer.pp_typ typ)
@@ -1006,7 +1007,7 @@ let rec eval_term ~alarm_mode env t =
| TAddrOf tlval ->
let r = eval_tlval ~alarm_mode env tlval in
- { etype = TPtr (r.etype, []);
+ { etype = Cil_const.mk_tptr r.etype;
ldeps = r.ldeps;
eunder = loc_bits_to_loc_bytes_under r.eunder;
eover = loc_bits_to_loc_bytes r.eover;
@@ -1014,7 +1015,7 @@ let rec eval_term ~alarm_mode env t =
| TStartOf tlval ->
let r = eval_tlval ~alarm_mode env tlval in
- { etype = TPtr (Cil.typeOf_array_elem r.etype, []);
+ { etype = Cil_const.mk_tptr (Cil.typeOf_array_elem r.etype);
ldeps = r.ldeps;
eunder = loc_bits_to_loc_bytes_under r.eunder;
eover = loc_bits_to_loc_bytes r.eover;
@@ -1662,8 +1663,8 @@ and eval_tlhost ~alarm_mode env lv =
| None -> no_result ())
| TMem t ->
let r = eval_term ~alarm_mode env t in
- let tres = match Cil.unrollType r.etype with
- | TPtr (t, _) -> t
+ let tres = match Cil.unrollTypeNode r.etype with
+ | TPtr t -> t
| _ -> ast_error "*p where p is not a pointer"
in
{ etype = tres;
@@ -1681,8 +1682,8 @@ and eval_toffset ~alarm_mode env typ toffset =
eover = Ival.zero;
empty = false; }
| TIndex (idx, remaining) ->
- let typ_e, size = match Cil.unrollType typ with
- | TArray (t, size, _) -> t, size
+ let typ_e, size = match Cil.unrollTypeNode typ with
+ | TArray (t, size) -> t, size
| _ -> ast_error "index on a non-array"
in
let idx = constraint_trange idx size in
diff --git a/src/plugins/eva/utils/eval_typ.ml b/src/plugins/eva/utils/eval_typ.ml
index 1cc53588178..55502e20513 100644
--- a/src/plugins/eva/utils/eval_typ.ml
+++ b/src/plugins/eva/utils/eval_typ.ml
@@ -30,8 +30,8 @@ let bitfield_size_attributes attrs =
let sizeof_lval_typ typlv =
match Cil.unrollType typlv with
- | TInt (_, attrs) | TEnum (_, attrs) as t ->
- (match Cil.findAttribute Cil.bitfield_attribute_name attrs with
+ | { tnode = (TInt _ | TEnum _); tattr } as t ->
+ (match Cil.findAttribute Cil.bitfield_attribute_name tattr with
| [AInt i] -> Int_Base.Value i
| _ -> Bit_utils.sizeof t)
| t -> Bit_utils.sizeof t
@@ -44,7 +44,7 @@ let offsetmap_matches_type typ_lv o =
try typ_matches (V.project_ival_bottom v)
with V.Not_based_on_null -> true (* Do not mess with pointers *)
in
- match Cil.unrollType typ_lv with
+ match Cil.unrollTypeNode typ_lv with
| TFloat _ -> aux Ival.is_float
| TInt _ | TEnum _ | TPtr _ -> aux Ival.is_int
| _ -> true
@@ -62,22 +62,23 @@ let is_compatible_function ~typ_pointed ~typ_fun =
- enums and integer types with the same signedness and size are equal *)
let weak_compatible t1 t2 =
Cabs2cil.areCompatibleTypes t1 t2 ||
- match Cil.unrollType t1, Cil.unrollType t2 with
- | TVoid _, TVoid _ -> true
+ match Cil.unrollTypeNode t1, Cil.unrollTypeNode t2 with
+ | TVoid, TVoid -> true
| TPtr _, TPtr _ -> true
- | (TInt (ik1, _) | TEnum ({ekind = ik1}, _)),
- (TInt (ik2, _) | TEnum ({ekind = ik2}, _)) ->
+ | (TInt ik1 | TEnum {ekind = ik1}),
+ (TInt ik2 | TEnum {ekind = ik2}) ->
Cil.isSigned ik1 = Cil.isSigned ik2 &&
Cil.bitsSizeOfInt ik1 = Cil.bitsSizeOfInt ik2
- | TFloat (fk1, _), TFloat (fk2, _) -> fk1 = fk2
- | TComp (ci1, _), TComp (ci2, _) ->
+ | TFloat fk1, TFloat fk2 -> fk1 = fk2
+ | TComp ci1, TComp ci2 ->
Cil_datatype.Compinfo.equal ci1 ci2
| _ -> false
in
if Cabs2cil.areCompatibleTypes typ_fun typ_pointed then Compatible
else
- let continue = match Cil.unrollType typ_pointed, Cil.unrollType typ_fun with
- | TFun (ret1, args1, var1, _), TFun (ret2, args2, var2, _) ->
+ let continue =
+ match Cil.unrollTypeNode typ_pointed, Cil.unrollTypeNode typ_fun with
+ | TFun (ret1, args1, var1), TFun (ret2, args2, var2) ->
(* Either both functions are variadic, or none. Otherwise, it
will be too complicated to make the argument match *)
var1 = var2 &&
@@ -104,10 +105,10 @@ let is_compatible_function ~typ_pointed ~typ_fun =
let refine_fun_ptr typ args =
match Cil.unrollType typ, args with
- | TFun (_, Some _, _, _), _ | _, None -> typ
- | TFun (ret, None, var, attrs), Some l ->
+ | { tnode = TFun (_, Some _, _) }, _ | _, None -> typ
+ | { tnode = TFun (ret, None, var); tattr }, Some l ->
let ltyps = List.map (fun arg -> "", arg, []) l in
- TFun (ret, Some ltyps, var, attrs)
+ Cil_const.mk_tfun ~tattr ret (Some ltyps) var
| _ -> assert false
(* Filters the list of kernel function [kfs] to only keep functions compatible
@@ -177,17 +178,17 @@ let pointer_range () =
let classify_as_scalar typ =
match Cil.unrollType typ with
- | TInt (ik, attrs) | TEnum ({ekind=ik}, attrs) ->
- Some (TSInt (ik_attrs_range ik attrs))
- | TPtr _ -> Some (TSPtr (pointer_range ()))
- | TFloat (fk, _) -> Some (TSFloat fk)
+ | { tnode = (TInt ik | TEnum { ekind = ik }); tattr } ->
+ Some (TSInt (ik_attrs_range ik tattr))
+ | { tnode = TPtr _ } -> Some (TSPtr (pointer_range ()))
+ | { tnode = TFloat fk } -> Some (TSFloat fk)
| _ -> None
let integer_range ~ptr typ =
match Cil.unrollType typ with
- | TInt (ik, attrs) | TEnum ({ekind=ik}, attrs) ->
- Some (ik_attrs_range ik attrs)
- | TPtr _ when ptr -> Some (pointer_range ())
+ | { tnode = (TInt ik | TEnum { ekind = ik }); tattr } ->
+ Some (ik_attrs_range ik tattr)
+ | { tnode = TPtr _ } when ptr -> Some (pointer_range ())
| _ -> None
let need_cast t1 t2 =
diff --git a/src/plugins/eva/utils/export.ml b/src/plugins/eva/utils/export.ml
index 4a99475717b..f9d99c706ac 100644
--- a/src/plugins/eva/utils/export.ml
+++ b/src/plugins/eva/utils/export.ml
@@ -136,8 +136,8 @@ let frange ~kind (exp : Exp.exp) = function
let fval typ (exp : Exp.exp) (fval : Fval.t) : pred =
let kind =
- match typ with
- | TFloat(kind,_) -> kind
+ match typ.tnode with
+ | TFloat kind -> kind
| _ -> assert false in
let range,isNaN = Fval.min_and_max fval in
por (fNaN exp isNaN) (frange ~kind exp range)
diff --git a/src/plugins/eva/utils/library_functions.ml b/src/plugins/eva/utils/library_functions.ml
index 39fe40e2c3e..365e2e69187 100644
--- a/src/plugins/eva/utils/library_functions.ml
+++ b/src/plugins/eva/utils/library_functions.ml
@@ -54,19 +54,19 @@ let get_retres_vi = Retres.memo
let returned_value kf =
let return_type = Cil.unrollType (Kernel_function.get_return_type kf) in
- match return_type with
+ match return_type.tnode with
| TComp _ when Cil.is_fully_arithmetic return_type -> Cvalue.V.top_int
| TPtr _ | TComp _ -> Cvalue.V.inject Base.null Ival.zero
| TInt _ | TEnum _ -> Cvalue.V.top_int
- | TFloat (FFloat, _) -> Cvalue.V.top_single_precision_float
- | TFloat (FDouble, _)
- | TFloat (FLongDouble, _) -> Cvalue.V.top_float
- | TBuiltin_va_list _ ->
+ | TFloat FFloat -> Cvalue.V.top_single_precision_float
+ | TFloat FDouble
+ | TFloat FLongDouble -> Cvalue.V.top_float
+ | TBuiltin_va_list ->
Self.error ~current:true ~once:true
"functions returning variadic arguments must be stubbed%t"
Eva_utils.pp_callstack;
Cvalue.V.top_int
- | TVoid _ -> Cvalue.V.top (* this value will never be used *)
+ | TVoid -> Cvalue.V.top (* this value will never be used *)
| TFun _ | TNamed _ | TArray _ -> assert false
diff --git a/src/plugins/eva/utils/unit_tests.ml b/src/plugins/eva/utils/unit_tests.ml
index fd0df1b47ee..a0ba4f10c7c 100644
--- a/src/plugins/eva/utils/unit_tests.ml
+++ b/src/plugins/eva/utils/unit_tests.ml
@@ -119,7 +119,7 @@ module Sign = struct
List.iter (fun x -> List.iter (test x) values) values
let test_typ ikind =
- let typ = TInt (ikind, [])
+ let typ = Cil_const.mk_tint ikind
and values = make_cvalue (test_values ikind) in
let apply f op = f op typ values in
List.iter (apply test_unop) [Neg; BNot; LNot];
diff --git a/src/plugins/eva/utils/widen.ml b/src/plugins/eva/utils/widen.ml
index 47e349f458a..6949114eb45 100644
--- a/src/plugins/eva/utils/widen.ml
+++ b/src/plugins/eva/utils/widen.ml
@@ -227,8 +227,8 @@ class widen_visitor init_widen_hints init_enclosing_loops = object(self)
| NoOffset -> ()
| Field (fi, off) -> aux_offset fi.ftype off
| Index (idx, off) -> begin
- match Cil.unrollType typ with
- | TArray (typ_e, size, _) -> begin
+ match Cil.unrollTypeNode typ with
+ | TArray (typ_e, size) -> begin
aux_offset typ_e off;
try
let size = Cil.lenOfArray64 size in
diff --git a/src/plugins/eva/values/cvalue_backward.ml b/src/plugins/eva/values/cvalue_backward.ml
index 0eb6e04e6d1..5a40e30f6f3 100644
--- a/src/plugins/eva/values/cvalue_backward.ml
+++ b/src/plugins/eva/values/cvalue_backward.ml
@@ -60,11 +60,11 @@ let backward_float_relation fkind ~positive op v1 v2 =
Some (v1', v2')
let backward_relation typ ~positive op =
- match Cil.unrollType typ with
+ match Cil.unrollTypeNode typ with
| TInt _ | TEnum _ | TPtr _ ->
let op = if positive then op else Abstract_interp.Comp.inv op in
backward_int_relation typ op
- | TFloat (fk, _) ->
+ | TFloat fk ->
backward_float_relation (Fval.kind fk) ~positive op
| _ -> assert false (* should never occur anyway *)
@@ -259,12 +259,12 @@ let backward_lor ~v1 ~v2 ~res =
let backward_binop ~typ_res ~res_value ~typ_e1 v1 binop v2 =
let typ = Cil.unrollType typ_res in
- match binop, typ with
+ match binop, typ.tnode with
| Eva_ast.PlusA, TInt _ -> backward_add_int typ ~res_value ~v1 ~v2 true
| MinusA, TInt _ -> backward_add_int typ ~res_value ~v1 ~v2 false
- | PlusA, TFloat (fk, _) -> backward_add_float (Fval.kind fk) ~res_value ~v1 ~v2 `Add
- | MinusA, TFloat (fk, _) -> backward_add_float (Fval.kind fk) ~res_value ~v1 ~v2 `Sub
+ | PlusA, TFloat fk -> backward_add_float (Fval.kind fk) ~res_value ~v1 ~v2 `Add
+ | MinusA, TFloat fk -> backward_add_float (Fval.kind fk) ~res_value ~v1 ~v2 `Sub
| PlusPI, TPtr _ -> backward_add_ptr typ ~res_value ~v1 ~v2 true
| MinusPI, TPtr _ -> backward_add_ptr typ ~res_value ~v1 ~v2 false
@@ -355,8 +355,9 @@ let backward_unop ~typ_arg op ~arg:_ ~res =
with V.Not_based_on_null -> None
(* ikind of an (unrolled) integer type *)
-let ikind = function
- | TInt (ik, _) | TEnum ({ekind = ik}, _) -> ik
+let ikind t =
+ match t.tnode with
+ | TInt ik | TEnum {ekind = ik} -> ik
| TPtr _ -> Machine.uintptr_kind ()
| _ -> assert false
@@ -380,7 +381,7 @@ let downcast_enabled ~ik_src ~ik_dst =
let backward_cast ~src_typ ~dst_typ ~src_val ~dst_val =
(* Kernel.result "%a %a %a %a" Printer.pp_typ src_typ Printer.pp_typ dst_typ
V.pretty src_val V.pretty dst_val; *)
- match dst_typ, src_typ with
+ match dst_typ.tnode, src_typ.tnode with
| (TInt _ | TEnum _ | TPtr _), (TInt _ | TEnum _ | TPtr _) ->
let ik_dst = ikind dst_typ in
let ik_src = ikind src_typ in
@@ -393,7 +394,7 @@ let backward_cast ~src_typ ~dst_typ ~src_val ~dst_val =
Some dst_val
else None
- | TFloat (fk_dst, _), TFloat (fk_src, _) -> begin
+ | TFloat fk_dst, TFloat fk_src -> begin
let f_dst = Fval.kind fk_dst in
let f_src = Fval.kind fk_src in
match V.project_float dst_val with
@@ -414,11 +415,11 @@ let backward_cast ~src_typ ~dst_typ ~src_val ~dst_val =
Some dst_val
end
- | TInt _, TFloat (fkind, _) ->
+ | TInt _, TFloat fkind ->
let single_precision = fkind = FFloat in
V.cast_float_to_int_inverse ~single_precision dst_val
- | TFloat (fkind, _), TInt _ ->
+ | TFloat fkind, TInt _ ->
let single_precision = fkind = FFloat in
V.cast_int_to_float_inverse ~single_precision dst_val
diff --git a/src/plugins/eva/values/cvalue_forward.ml b/src/plugins/eva/values/cvalue_forward.ml
index 44e344b8209..27875c7e2d1 100644
--- a/src/plugins/eva/values/cvalue_forward.ml
+++ b/src/plugins/eva/values/cvalue_forward.ml
@@ -434,7 +434,7 @@ let forward_binop_float fkind ev1 op ev2 =
This is left to the caller *)
let forward_uneg v t =
try
- match Cil.unrollType t with
+ match Cil.unrollTypeNode t with
| TFloat _ ->
let v = V.project_float v in
V.inject_ival (Ival.inject_float (Fval.neg v))
@@ -450,8 +450,8 @@ let forward_unop typ op value =
match op with
| Eva_ast.Neg -> forward_uneg value typ
| BNot -> begin
- match Cil.unrollType typ with
- | TInt (ik, _) | TEnum ({ekind=ik}, _) ->
+ match Cil.unrollTypeNode typ with
+ | TInt ik | TEnum {ekind=ik} ->
let size = Cil.bitsSizeOfInt ik in
let signed = Cil.isSigned ik in
V.bitwise_not ~signed ~size value
diff --git a/src/plugins/eva/values/main_values.ml b/src/plugins/eva/values/main_values.ml
index 7a28c57b5d2..8255334d6f2 100644
--- a/src/plugins/eva/values/main_values.ml
+++ b/src/plugins/eva/values/main_values.ml
@@ -65,10 +65,10 @@ module CVal = struct
let forward_binop _context typ binop v1 v2 =
let value =
- match typ with
- | Cil_types.TFloat (fkind, _) ->
+ match typ.Cil_types.tnode with
+ | TFloat fkind ->
Cvalue_forward.forward_binop_float (Fval.kind fkind) v1 binop v2
- | TInt _ | TPtr _ | _ as typ ->
+ | TInt _ | TPtr _ | _ ->
Cvalue_forward.forward_binop_int ~typ v1 binop v2
in
if Cvalue.V.is_bottom value
diff --git a/src/plugins/eva/values/sign_value.ml b/src/plugins/eva/values/sign_value.ml
index 6c57062e951..5cffa507eec 100644
--- a/src/plugins/eva/values/sign_value.ml
+++ b/src/plugins/eva/values/sign_value.ml
@@ -137,8 +137,8 @@ let assume_comparable _ v1 v2 = `Unknown (v1, v2)
let neg_unop v = { v with neg = v.pos; pos = v.neg }
let bitwise_not typ v =
- match Cil.unrollType typ with
- | TInt (ikind, _) | TEnum ({ekind=ikind}, _) ->
+ match Cil.unrollTypeNode typ with
+ | TInt ikind | TEnum {ekind=ikind} ->
if Cil.isSigned ikind
then { pos = v.neg; neg = v.pos || v.zero; zero = v.neg }
else { pos = v.pos || v.zero; neg = false; zero = v.pos }
diff --git a/src/plugins/gui/design.ml b/src/plugins/gui/design.ml
index bdee5edfaf9..bbd914487d6 100644
--- a/src/plugins/gui/design.ml
+++ b/src/plugins/gui/design.ml
@@ -572,7 +572,7 @@ let to_do_on_select
| Some i ->
begin match e.enode with
| Const (CEnum {eihost}) ->
- let typ_enum = TEnum (eihost, []) in
+ let typ_enum = Cil_const.mk_tenum eihost in
main_ui#pretty_information
"This is a C enumeration constant, \
defined in %a with a value of %a.@."
@@ -1769,15 +1769,15 @@ class main_window () : main_window_extension_points =
let pp_def_loc pp typ =
try
let opt_tag_name =
- match typ with
- | TNamed (ti, _) -> Some (Logic_typing.Typedef, ti.torig_name)
- | TComp (ci, _) ->
+ match typ.tnode with
+ | TNamed ti -> Some (Logic_typing.Typedef, ti.torig_name)
+ | TComp ci ->
let tag = if ci.cstruct then Logic_typing.Struct
else Logic_typing.Union
in
let name = if ci.corig_name <> "" then ci.corig_name else ci.cname in
Some (tag, name)
- | TEnum (ei, _) ->
+ | TEnum ei ->
let name = if ei.eorig_name <> "" then ei.eorig_name else ei.ename in
Some (Logic_typing.Enum, name)
| _ -> None
@@ -1818,7 +1818,7 @@ class main_window () : main_window_extension_points =
try
(* Retrieve a potential typ from the selection *)
let typ = Gui_printers.typ_of_link s in
- match typ with
+ match typ.tnode with
| TComp _ | TEnum _ | TPtr _ | TArray _ | TNamed _ ->
let base_type = Gui_printers.get_type_specifier typ in
let sizeof_str =
diff --git a/src/plugins/gui/gui_printers.ml b/src/plugins/gui/gui_printers.ml
index e755f0f0b68..e06a0be1e0f 100644
--- a/src/plugins/gui/gui_printers.ml
+++ b/src/plugins/gui/gui_printers.ml
@@ -70,7 +70,7 @@ module ResolveLoc =
(adding it to the maps if needed).
Only typedefs, composite types and enumerations are linked. *)
let tid_of_typ typ =
- match typ with
+ match typ.tnode with
| TNamed _ | TComp _ | TEnum _ ->
(try
Some (ResolveTypId.find typ)
@@ -96,8 +96,8 @@ let lid_of_loc loc =
(* Returns the base type for a pointer/array, otherwise [t] itself.
E.g. for [t = int***], returns [int]. *)
let rec get_type_specifier (t:typ) =
- match t with
- | TPtr (bt, _) | TArray (bt, _, _) -> get_type_specifier bt
+ match t.tnode with
+ | TPtr bt | TArray (bt, _) -> get_type_specifier bt
| _ -> t
let pp_tcomp_unfolded fmt comp attrs =
@@ -118,20 +118,20 @@ let pp_enum_unfolded fmt enum attrs =
(hence we cannot say that this function is the method [typ] itself),
and we cannot add new public methods in extensible printers. *)
let pp_typ_unfolded fmt (t : typ) =
- match t with
- | TNamed (ty, attrs) ->
+ match t.tnode with
+ | TNamed ti ->
begin
(* unfolds the typedef, and one step further if it is a TComp/TEnum *)
- match ty.ttype with
- | TComp (comp, cattrs) ->
- pp_tcomp_unfolded fmt comp (Cil.addAttributes attrs cattrs)
- | TEnum (enum, eattrs) ->
- pp_enum_unfolded fmt enum (Cil.addAttributes attrs eattrs)
+ match ti.ttype.tnode with
+ | TComp ci ->
+ pp_tcomp_unfolded fmt ci (Cil.addAttributes t.tattr ti.ttype.tattr)
+ | TEnum ei ->
+ pp_enum_unfolded fmt ei (Cil.addAttributes t.tattr ti.ttype.tattr)
| _ ->
- Printer.pp_typ fmt (Cil.typeAddAttributes attrs ty.ttype)
+ Printer.pp_typ fmt (Cil.typeAddAttributes t.tattr ti.ttype)
end
- | TComp (comp, attrs) -> pp_tcomp_unfolded fmt comp attrs
- | TEnum (enum, attrs) -> pp_enum_unfolded fmt enum attrs
+ | TComp ci -> pp_tcomp_unfolded fmt ci t.tattr
+ | TEnum ei -> pp_enum_unfolded fmt ei t.tattr
| _ -> Printer.pp_typ fmt t
let pp_typ fmt typ =
diff --git a/src/plugins/instantiate/basic_blocks.ml b/src/plugins/instantiate/basic_blocks.ml
index b0aff13021a..981053791a6 100644
--- a/src/plugins/instantiate/basic_blocks.ml
+++ b/src/plugins/instantiate/basic_blocks.ml
@@ -22,10 +22,8 @@
open Cil
open Cil_types
-open Cil_const
open Logic_const
-let ptr_of t = TPtr(t, [])
let const_of t = Cil.typeAddAttributes [Attr("const", [])] t
let size_t () =
@@ -50,36 +48,37 @@ let call_function lval vi args =
let args = List.map2 gen_arg args typs in
Call(lval, (Cil.evar vi), args, loc)
-let rec string_of_typ_aux = function
- | TVoid(_) -> "void"
- | TInt(IBool, _) -> "bool"
- | TInt(IChar, _) -> "char"
- | TInt(ISChar, _) -> "schar"
- | TInt(IUChar, _) -> "uchar"
- | TInt(IInt, _) -> "int"
- | TInt(IUInt, _) -> "uint"
- | TInt(IShort, _) -> "short"
- | TInt(IUShort, _) -> "ushort"
- | TInt(ILong, _) -> "long"
- | TInt(IULong, _) -> "ulong"
- | TInt(ILongLong, _) -> "llong"
- | TInt(IULongLong, _) -> "ullong"
- | TFloat(FFloat, _) -> "float"
- | TFloat(FDouble, _) -> "double"
- | TFloat(FLongDouble, _) -> "ldouble"
- | TPtr(t, _) -> "ptr_" ^ string_of_typ t
- | TEnum (ei, _) -> "e_" ^ ei.ename
- | TComp (ci, _) when ci.cstruct -> "st_" ^ ci.cname
- | TComp (ci, _) -> "un_" ^ ci.cname
- | TArray (t, Some e, _) ->
+let rec string_of_typ_aux t =
+ match t.tnode with
+ | TVoid -> "void"
+ | TInt IBool -> "bool"
+ | TInt IChar -> "char"
+ | TInt ISChar -> "schar"
+ | TInt IUChar -> "uchar"
+ | TInt IInt -> "int"
+ | TInt IUInt -> "uint"
+ | TInt IShort -> "short"
+ | TInt IUShort -> "ushort"
+ | TInt ILong -> "long"
+ | TInt IULong -> "ulong"
+ | TInt ILongLong -> "llong"
+ | TInt IULongLong -> "ullong"
+ | TFloat FFloat -> "float"
+ | TFloat FDouble -> "double"
+ | TFloat FLongDouble -> "ldouble"
+ | TPtr t -> "ptr_" ^ string_of_typ t
+ | TEnum ei -> "e_" ^ ei.ename
+ | TComp ci when ci.cstruct -> "st_" ^ ci.cname
+ | TComp ci -> "un_" ^ ci.cname
+ | TArray (t, Some e) ->
"arr" ^ (string_of_exp e) ^ "_" ^ string_of_typ t
- | t ->
+ | _ ->
Options.fatal "unsupported type %a" Cil_printer.pp_typ t
and string_of_typ t = string_of_typ_aux (Cil.unrollType t)
and string_of_exp e = Format.asprintf "%a" Cil_printer.pp_exp e
let size_var ?(name_ext="") t value = {
- l_var_info = make_logic_var_local ("__fc_" ^ name_ext ^ "len") t;
+ l_var_info = Cil_const.make_logic_var_local ("__fc_" ^ name_ext ^ "len") t;
l_type = Some t;
l_tparams = [];
l_labels = [];
@@ -114,7 +113,7 @@ let tdivide ?loc t1 t2 =
let ttype_of_pointed t =
match Logic_utils.unroll_type t with
- | Ctype(TPtr(t, _)) | Ctype(TArray(t, _, _)) -> Ctype t
+ | Ctype { tnode = TPtr t | TArray (t, _) } -> Ctype t
| _ -> Options.fatal "ttype_of_pointed on a non pointer type"
let tbuffer_range ?loc ptr len =
@@ -130,7 +129,7 @@ let rec tunref_range ?loc ptr len =
term (TLval tlval) typ
and tunref_range_unfold ?loc lval typ =
match typ with
- | Ctype(TArray(typ, Some e, _)) ->
+ | Ctype { tnode = TArray (typ, Some e) } ->
let len = Logic_utils.expr_to_term ~coerce:true e in
let last = tminus ?loc len (tinteger ?loc 1) in
let range = trange ?loc (Some (tinteger ?loc 0), Some last) in
@@ -144,18 +143,18 @@ let taccess ?loc ptr offset =
| _ -> Options.fatal "unexpected non-lvalue on call to taccess"
in
match Logic_utils.unroll_type ptr.term_type with
- | Ctype(TPtr(_)) ->
+ | Ctype { tnode = TPtr _ } ->
let address = tplus ?loc ptr offset in
let lval = TLval(TMem(address), TNoOffset) in
term ?loc lval (ttype_of_pointed ptr.term_type)
- | Ctype(TArray(_)) ->
+ | Ctype { tnode = TArray _ } ->
let lval = get_lval ptr.term_node in
let lval = addTermOffsetLval (TIndex(offset, TNoOffset)) lval in
term ?loc (TLval lval) (ttype_of_pointed ptr.term_type)
| _ -> Options.fatal "taccess on a non pointer type"
let sizeofpointed = function
- | Ctype(TPtr(t, _)) | Ctype(TArray(t, _, _)) -> Cil.bytesSizeOf t
+ | Ctype { tnode = (TPtr t | TArray (t, _)) } -> Cil.bytesSizeOf t
| _ -> Options.fatal "size_of_pointed on a non pointer type"
let sizeof = function
@@ -208,7 +207,7 @@ let rec punfold_all_elems_eq ?loc t1 t2 len =
assert(Cil_datatype.Logic_type.equal t1.term_type t2.term_type) ;
pall_elems_eq ?loc 0 t1 t2 len
and pall_elems_eq ?loc depth t1 t2 len =
- let ind = make_logic_var_quant ("j" ^ (string_of_int depth)) Linteger in
+ let ind = Cil_const.make_logic_var_quant ("j" ^ (string_of_int depth)) Linteger in
let tind = tvar ind in
let bounds = pbounds_incl_excl ?loc (tinteger 0) tind len in
let t1_acc = taccess ?loc t1 tind in
@@ -217,7 +216,7 @@ and pall_elems_eq ?loc depth t1 t2 len =
pforall ?loc ([ind], (pimplies ?loc (bounds, eq)))
and peq_unfold ?loc depth t1 t2 =
match Logic_utils.unroll_type t1.term_type with
- | Ctype(TArray(_, Some len, _)) ->
+ | Ctype { tnode = TArray (_, Some len) } ->
let len = Logic_utils.expr_to_term ~coerce:true len in
pall_elems_eq ?loc depth t1 t2 len
| _ -> prel ?loc (Req, t1, t2)
@@ -225,7 +224,7 @@ and peq_unfold ?loc depth t1 t2 =
let rec punfold_all_elems_pred ?loc t1 len pred =
pall_elems_pred ?loc 0 t1 len pred
and pall_elems_pred ?loc depth t1 len pred =
- let ind = make_logic_var_quant ("j" ^ (string_of_int depth)) Linteger in
+ let ind = Cil_const.make_logic_var_quant ("j" ^ (string_of_int depth)) Linteger in
let tind = tvar ind in
let bounds = pbounds_incl_excl ?loc (tinteger 0) tind len in
let t1_acc = taccess ?loc t1 tind in
@@ -233,7 +232,7 @@ and pall_elems_pred ?loc depth t1 len pred =
pforall ?loc ([ind], (pimplies ?loc (bounds, eq)))
and punfold_pred ?loc ?(dyn_len = None) depth t1 pred =
match Logic_utils.unroll_type t1.term_type with
- | Ctype(TArray(_, opt_len, _)) ->
+ | Ctype { tnode = TArray (_, opt_len) } ->
let len =
match opt_len, dyn_len with
| Some len, None -> Logic_utils.expr_to_term ~coerce:true len
@@ -242,7 +241,7 @@ and punfold_pred ?loc ?(dyn_len = None) depth t1 pred =
Options.fatal "Unfolding array: cannot find a length"
in
pall_elems_pred ?loc (depth+1) t1 len pred
- | Ctype(TComp(ci, _)) ->
+ | Ctype { tnode = TComp ci } ->
pall_fields_pred ?loc depth t1 ci pred
| _ -> pred ?loc t1
and pall_fields_pred ?loc ?(flex_mem_len=None) depth t1 ci pred =
@@ -262,7 +261,7 @@ and pall_fields_pred ?loc ?(flex_mem_len=None) depth t1 ci pred =
let punfold_flexible_struct_pred ?loc the_struct bytes_len pred =
let struct_len = tinteger ?loc (sizeof the_struct.term_type) in
let ci = match the_struct.term_type with
- | Ctype(TComp(ci, _) as t) when Cil.has_flexible_array_member t -> ci
+ | Ctype ({ tnode = TComp ci } as t) when Cil.has_flexible_array_member t -> ci
| _ -> Options.fatal "Unfolding flexible on a non flexible structure"
in
let flex_type = Ctype (Extlib.last (Option.get ci.cfields)).ftype in
diff --git a/src/plugins/instantiate/basic_blocks.mli b/src/plugins/instantiate/basic_blocks.mli
index bf81280015d..92b9b06f02e 100644
--- a/src/plugins/instantiate/basic_blocks.mli
+++ b/src/plugins/instantiate/basic_blocks.mli
@@ -42,9 +42,6 @@ val ttype_of_pointed: logic_type -> logic_type
(** {2 C} *)
-(** For a type [T], returns [T*] *)
-val ptr_of: typ -> typ
-
(** For a type [T], returns [T const] *)
val const_of: typ -> typ
diff --git a/src/plugins/instantiate/stdlib/basic_alloc.ml b/src/plugins/instantiate/stdlib/basic_alloc.ml
index 529fd4736a9..176ff0baaf3 100644
--- a/src/plugins/instantiate/stdlib/basic_alloc.ml
+++ b/src/plugins/instantiate/stdlib/basic_alloc.ml
@@ -28,10 +28,10 @@ open Extlib
let unexpected = Options.fatal "Stdlib.Basic_alloc: unexpected: %s"
let valid_size ?loc typ size =
- let p = match typ with
- | TComp (ci, _) when Cil.has_flexible_array_member typ ->
- let elem = match (last (Option.value ~default:[] ci.cfields)).ftype with
- | TArray(t, _, _) -> tinteger ?loc (Cil.bytesSizeOf t)
+ let p = match typ.tnode with
+ | TComp ci when Cil.has_flexible_array_member typ ->
+ let elem = match (last (Option.value ~default:[] ci.cfields)).ftype.tnode with
+ | TArray (t, _) -> tinteger ?loc (Cil.bytesSizeOf t)
| _ -> unexpected "non array last field on flexible structure"
in
let base = tinteger ?loc (Cil.bytesSizeOf typ) in
diff --git a/src/plugins/instantiate/stdlib/calloc.ml b/src/plugins/instantiate/stdlib/calloc.ml
index e313365065f..5184762db4e 100644
--- a/src/plugins/instantiate/stdlib/calloc.ml
+++ b/src/plugins/instantiate/stdlib/calloc.ml
@@ -32,14 +32,14 @@ let unexpected = Options.fatal "Stdlib.Calloc: unexpected: %s"
let pset_len_to_zero ?loc alloc_type num size =
let eq_simpl_value ?loc t =
let value = match Logic_utils.unroll_type t.term_type with
- | Ctype(TPtr(_)) -> term Tnull t.term_type
- | Ctype(TFloat(_)) -> treal ?loc 0.
- | Ctype(TInt(_) | TEnum (_)) -> tinteger ?loc 0
+ | Ctype { tnode = TPtr _ } -> term Tnull t.term_type
+ | Ctype { tnode = TFloat _ } -> treal ?loc 0.
+ | Ctype { tnode = (TInt _ | TEnum _) } -> tinteger ?loc 0
| _ -> unexpected "non atomic type during equality generation"
in
prel ?loc (Req, t, value)
in
- let ptr_type = ptr_of alloc_type in
+ let ptr_type = Cil_const.mk_tptr alloc_type in
let result = tresult ?loc ptr_type in
let p = if Cil.has_flexible_array_member alloc_type then
let access = Cil.mkTermMem ~addr:result ~off:TNoOffset in
@@ -62,7 +62,7 @@ let generate_requires ?loc alloc_type num size =
[ valid_size ?loc alloc_type size ] @ (Option.to_list only_one)
let pinitialized_len ?loc alloc_type num size =
- let result = tresult ?loc (ptr_of alloc_type) in
+ let result = tresult ?loc (Cil_const.mk_tptr alloc_type) in
let initialized ?loc t =
let t = match t.term_node, Logic_utils.unroll_type t.term_type with
| TLval (lv), (Ctype _ as t) ->
@@ -82,12 +82,12 @@ let pinitialized_len ?loc alloc_type num size =
new_predicate { p with pred_name = [ "initialization" ] }
let generate_global_assigns loc alloc_type num size =
- let assigns_result = assigns_result ~loc (ptr_of alloc_type) [ num ; size ] in
+ let assigns_result = assigns_result ~loc (Cil_const.mk_tptr alloc_type) [ num ; size ] in
let assigns_heap = assigns_heap [ num ; size ] in
Writes [ assigns_result ; assigns_heap ]
let make_behavior_allocation loc alloc_type num size =
- let ptr_type = ptr_of alloc_type in
+ let ptr_type = Cil_const.mk_tptr alloc_type in
let len = term ~loc (TBinOp(Mult, num, size)) Linteger in
let assumes = [ is_allocable ~loc len ] in
let assigns = generate_global_assigns loc alloc_type num size in
@@ -101,7 +101,7 @@ let make_behavior_allocation loc alloc_type num size =
let make_behavior_no_allocation loc alloc_type num size =
let len = term ~loc (TBinOp(Mult, num, size)) Linteger in
- let ptr_type = ptr_of alloc_type in
+ let ptr_type = Cil_const.mk_tptr alloc_type in
let assumes = [ isnt_allocable ~loc len ] in
let assigns = Writes [assigns_result ~loc ptr_type []] in
let ensures = [ Normal, null_result ~loc ptr_type ] in
@@ -117,7 +117,7 @@ let generate_spec alloc_type loc { svar = vi } =
let size = tlogic_coerce ~loc (cvar_to_tvar csize) Linteger in
let requires = generate_requires ~loc alloc_type num size in
let assigns = generate_global_assigns loc alloc_type num size in
- let alloc = allocates_result ~loc (ptr_of alloc_type) in
+ let alloc = allocates_result ~loc (Cil_const.mk_tptr alloc_type) in
make_funspec [
make_behavior ~requires ~assigns ~alloc () ;
make_behavior_allocation loc alloc_type num size ;
@@ -130,7 +130,7 @@ let generate_prototype alloc_type =
("num", size_t (), []) ;
("size", size_t (), [])
] in
- name, (TFun((ptr_of alloc_type), Some params, false, []))
+ name, Cil_const.(mk_tfun (mk_tptr alloc_type) (Some params) false)
let well_typed_call ret _fct args =
match ret, args with
diff --git a/src/plugins/instantiate/stdlib/free.ml b/src/plugins/instantiate/stdlib/free.ml
index 82a11656347..41fc657fb58 100644
--- a/src/plugins/instantiate/stdlib/free.ml
+++ b/src/plugins/instantiate/stdlib/free.ml
@@ -79,9 +79,9 @@ let generate_spec _typ loc { svar = vi } =
let generate_prototype alloc_t =
let name = function_name ^ "_" ^ (string_of_typ alloc_t) in
let params = [
- ("ptr", (ptr_of alloc_t), [])
+ ("ptr", (Cil_const.mk_tptr alloc_t), [])
] in
- name, (TFun(Cil_const.voidType, Some params, false, []))
+ name, Cil_const.(mk_tfun voidType (Some params) false)
let well_typed_call _ret _fct args =
match args with
diff --git a/src/plugins/instantiate/stdlib/malloc.ml b/src/plugins/instantiate/stdlib/malloc.ml
index 672aeaae094..8a7ee1599e4 100644
--- a/src/plugins/instantiate/stdlib/malloc.ml
+++ b/src/plugins/instantiate/stdlib/malloc.ml
@@ -55,12 +55,12 @@ let generate_spec alloc_typ loc { svar = vi } =
in
let size = tlogic_coerce ~loc (cvar_to_tvar csize) Linteger in
let requires = [ valid_size ~loc alloc_typ size ] in
- let assigns = generate_global_assigns loc (ptr_of alloc_typ) size in
- let alloc = allocates_result ~loc (ptr_of alloc_typ) in
+ let assigns = generate_global_assigns loc (Cil_const.mk_tptr alloc_typ) size in
+ let alloc = allocates_result ~loc (Cil_const.mk_tptr alloc_typ) in
make_funspec [
make_behavior ~requires ~assigns ~alloc () ;
- make_behavior_allocation loc (ptr_of alloc_typ) size ;
- make_behavior_no_allocation loc (ptr_of alloc_typ) size
+ make_behavior_allocation loc (Cil_const.mk_tptr alloc_typ) size ;
+ make_behavior_no_allocation loc (Cil_const.mk_tptr alloc_typ) size
] ()
let generate_prototype alloc_t =
@@ -68,7 +68,7 @@ let generate_prototype alloc_t =
let params = [
("size", size_t (), [])
] in
- name, (TFun((ptr_of alloc_t), Some params, false, []))
+ name, Cil_const.(mk_tfun (mk_tptr alloc_t) (Some params) false)
let well_typed_call ret _fct args =
match ret, args with
diff --git a/src/plugins/instantiate/string/mem_utils.ml b/src/plugins/instantiate/string/mem_utils.ml
index a62799670f0..43c58ca04dc 100644
--- a/src/plugins/instantiate/string/mem_utils.ml
+++ b/src/plugins/instantiate/string/mem_utils.ml
@@ -114,14 +114,14 @@ module Make (F: Function) =
struct
let generate_function_type t =
let to_type = function
- | CPtr -> ptr_of (const_of t)
- | Ptr -> ptr_of t
+ | CPtr -> Cil_const.mk_tptr (const_of t)
+ | Ptr -> Cil_const.mk_tptr t
| Data t -> t
in
let ret, ps = F.prototype () in
let ret = to_type ret in
let ps = List.map (fun (name, kind, _) -> name, (to_type kind), []) ps in
- TFun(ret, Some ps, false, [])
+ Cil_const.mk_tfun ret (Some ps) false
let generate_prototype t =
let ftype = generate_function_type t in
diff --git a/src/plugins/instantiate/string/memset.ml b/src/plugins/instantiate/string/memset.ml
index 59794ff614f..edd9b881c36 100644
--- a/src/plugins/instantiate/string/memset.ml
+++ b/src/plugins/instantiate/string/memset.ml
@@ -42,16 +42,16 @@ module With_collection = struct
end
let rec any_char_composed_type t =
- match t with
- | t when Cil.isAnyCharType t -> true
- | TArray(t, _, _) -> any_char_composed_type t
+ match t.tnode with
+ | _ when Cil.isAnyCharType t -> true
+ | TArray (t, _) -> any_char_composed_type t
| _ -> false
let rec base_char_type t =
assert (any_char_composed_type t) ;
- match t with
- | t when Cil.isAnyCharType t -> t
- | TArray(t, _, _) -> base_char_type t
+ match t.tnode with
+ | _ when Cil.isAnyCharType t -> t
+ | TArray (t, _) -> base_char_type t
| _ -> assert false
@@ -66,9 +66,9 @@ let pset_len_bytes_to_value ?loc ptr value bytes_len =
let pset_len_bytes_to_zero ?loc ptr bytes_len =
let eq_value ?loc t =
let value = match Logic_utils.unroll_type t.term_type with
- | Ctype(TPtr(_)) -> term Tnull t.term_type
- | Ctype(TFloat(_)) -> treal ?loc 0.
- | Ctype(TInt(_) | TEnum (_)) -> tinteger ?loc 0
+ | Ctype { tnode = TPtr _ } -> term Tnull t.term_type
+ | Ctype { tnode = TFloat _ } -> treal ?loc 0.
+ | Ctype { tnode = (TInt _ | TEnum _) } -> tinteger ?loc 0
| _ -> unexpected "non atomic type during equality generation"
in
prel ?loc (Req, t, value)
@@ -85,11 +85,11 @@ let pset_len_bytes_all_bits_to_one ?loc ptr bytes_len =
let find_nan_for_type t = List.find (of_type t) nans in
let all_bits_to_one ?loc t =
match Logic_utils.unroll_type t.term_type with
- | Ctype(TFloat(_)) ->
+ | Ctype { tnode = TFloat _ } ->
papp ?loc ((find_nan_for_type t.term_type), [], [t])
- | Ctype(TPtr(_)) ->
+ | Ctype { tnode = TPtr _ } ->
pnot ?loc (pvalid_read ?loc (here_label, t))
- | Ctype((TInt(kind, _) | TEnum({ ekind = kind }, _)) as typ) ->
+ | Ctype ({ tnode = (TInt kind | TEnum { ekind = kind }) } as typ) ->
let is_signed = Cil.isSigned kind in
let bits = Cil.bitsSizeOfInt kind in
let value =
@@ -117,7 +117,7 @@ let generate_requires loc ptr value len =
with pred_name = ["aligned_end"] } ]
| Some value ->
let low, up = match Logic_utils.unroll_type value.term_type with
- | Ctype(TInt((IChar|ISChar|IUChar) as kind, _)) ->
+ | Ctype { tnode = TInt ((IChar|ISChar|IUChar) as kind) } ->
let bits = bitsSizeOfInt kind in
let plus_one = Integer.add (Integer.of_int 1) in
let low, up = if (isSigned kind) then
@@ -185,12 +185,12 @@ let memset_value e =
| _ -> None
let rec contains_union_type t =
- match Cil.unrollType t with
- | TComp({ cstruct = false }, _) ->
+ match Cil.unrollTypeNode t with
+ | TComp { cstruct = false } ->
true
- | TComp({ cfields = Some fields }, _) ->
+ | TComp { cfields = Some fields } ->
List.exists contains_union_type (List.map (fun f -> f.ftype) fields)
- | TArray(t, _, _) ->
+ | TArray (t, _) ->
contains_union_type t
| _ -> false
@@ -219,18 +219,18 @@ let key_from_call _ret _fct = function
let char_prototype t =
assert (any_char_composed_type t) ;
let params = [
- ("ptr", ptr_of t, []) ;
+ ("ptr", Cil_const.mk_tptr t, []) ;
("value", base_char_type t, []) ;
("len", size_t(), [])
] in
- TFun (ptr_of t, Some params, false, [])
+ Cil_const.(mk_tfun (mk_tptr t) (Some params) false)
let non_char_prototype t =
let params = [
- ("ptr", (ptr_of t), []) ;
+ ("ptr", Cil_const.mk_tptr t, []) ;
("len", size_t(), [])
] in
- TFun ((ptr_of t), Some params, false, [])
+ Cil_const.(mk_tfun (mk_tptr t) (Some params) false)
let generate_prototype = function
| t, _ when any_char_composed_type t ->
diff --git a/src/plugins/instantiate/tests/api/external_instantiator_registration.ml b/src/plugins/instantiate/tests/api/external_instantiator_registration.ml
index 4d7caf14294..41474dd6370 100644
--- a/src/plugins/instantiate/tests/api/external_instantiator_registration.ml
+++ b/src/plugins/instantiate/tests/api/external_instantiator_registration.ml
@@ -18,15 +18,15 @@ let retype_args _ = function
let generate_function_type t =
let params = [
- ("x", Cil_types.TPtr(t, []), [])
+ ("x", Cil_const.mk_tptr t, [])
] in
- Cil_types.TFun(Cil_const.voidType, Some params, false, [])
+ Cil_const.(mk_tfun voidType (Some params) false)
let generate_prototype t =
let fun_type = generate_function_type t in
- let name = function_name ^ "_" ^ match t with
- | Cil_types.TInt(_) -> "int"
- | Cil_types.TFloat(_) -> "float"
+ let name = function_name ^ "_" ^ match t.Cil_types.tnode with
+ | TInt(_) -> "int"
+ | TFloat(_) -> "float"
| _ -> assert false (* nothing else in our test *)
in
name, fun_type
diff --git a/src/plugins/instantiate/tests/plugin/needs_global.ml b/src/plugins/instantiate/tests/plugin/needs_global.ml
index 616517ccb7d..3a9c0d5965f 100644
--- a/src/plugins/instantiate/tests/plugin/needs_global.ml
+++ b/src/plugins/instantiate/tests/plugin/needs_global.ml
@@ -13,13 +13,13 @@ let retype_args _ = function
| _ -> assert false
let generate_function_type t =
- let params = [("x", Cil_types.TPtr(t, []), [])] in
- Cil_types.TFun(Cil_const.voidType, Some params, false, [])
+ let params = [("x", Cil_const.mk_tptr t, [])] in
+ Cil_const.(mk_tfun voidType (Some params) false)
let generate_prototype function_name t =
let fun_type = generate_function_type t in
- let name = function_name ^ "_" ^ match t with
- | Cil_types.TInt(_) -> "int"
+ let name = function_name ^ "_" ^ match t.Cil_types.tnode with
+ | TInt(_) -> "int"
| _ -> assert false (* nothing else in our test *)
in
name, fun_type
diff --git a/src/plugins/obfuscator/obfuscate.ml b/src/plugins/obfuscator/obfuscate.ml
index b859d2af9a5..c42c870b3c3 100644
--- a/src/plugins/obfuscator/obfuscate.ml
+++ b/src/plugins/obfuscator/obfuscate.ml
@@ -36,8 +36,9 @@ class visitor = object
val logic_vars_visited = Logic_var.Hashtbl.create 7
val id_pred_visited = Identified_predicate.Hashtbl.create 7
- method! vtype = function
- | TFun(t, args, variadic, attrs) ->
+ method! vtype t =
+ match t.tnode with
+ | TFun(rt, args, variadic) ->
let args' =
match args with
| None -> None
@@ -47,7 +48,7 @@ class visitor = object
(fun (s,t,a) ->
(Dictionary.fresh Obfuscator_kind.Formal_in_type s, t, a)) l)
in
- Cil.ChangeDoChildrenPost(TFun(t,args',variadic,attrs), Fun.id)
+ Cil.ChangeDoChildrenPost(Cil_const.mk_tfun ~tattr:t.tattr rt args' variadic, Fun.id)
| _ -> Cil.DoChildren
method! vglob_aux = function
diff --git a/src/plugins/pdg/build.ml b/src/plugins/pdg/build.ml
index c3e3432a82c..75fa3a428c4 100644
--- a/src/plugins/pdg/build.ml
+++ b/src/plugins/pdg/build.ml
@@ -56,8 +56,8 @@ let pretty_node ?(key=false) fmt n =
let is_variadic kf =
let varf = Kernel_function.get_vi kf in
- match varf.vtype with
- | TFun (_, _, is_variadic, _) -> is_variadic
+ match varf.vtype.tnode with
+ | TFun (_, _, is_variadic) -> is_variadic
| _ -> Pdg_parameters.fatal
"The variable of a kernel_function has to be a function !"
diff --git a/src/plugins/reduc/collect.ml b/src/plugins/reduc/collect.ml
index 96cb9328bce..7f1f5ebadba 100644
--- a/src/plugins/reduc/collect.ml
+++ b/src/plugins/reduc/collect.ml
@@ -78,16 +78,16 @@ class stmts_vis
end
let rec collect_off typ =
- match typ with
+ match typ.tnode with
| TInt _ | TFloat _ -> [ NoOffset ]
- | TComp ({cfields = Some flds}, _) ->
+ | TComp {cfields = Some flds} ->
List.fold_left collect_fields [] flds
- | TArray (arrtyp, e_opt, _) ->
+ | TArray (arrtyp, e_opt) ->
debug "Array of length %a" (Pretty_utils.pp_opt Printer.pp_exp) e_opt;
begin try collect_array arrtyp [] (Cil.lenOfArray64 e_opt)
with Cil.LenOfArray _ -> [] end
- | TVoid _ | TFun _ | TPtr _ | TEnum _ | TNamed _ | TBuiltin_va_list _
- | TComp ({cfields = None}, _)-> []
+ | TVoid | TFun _ | TPtr _ | TEnum _ | TNamed _ | TBuiltin_va_list
+ | TComp {cfields = None} -> []
and collect_fields acc fld =
let offs = collect_off fld.ftype in
diff --git a/src/plugins/region/annot.ml b/src/plugins/region/annot.ml
index f882605cef3..bdbe33ee2f0 100644
--- a/src/plugins/region/annot.ml
+++ b/src/plugins/region/annot.ml
@@ -153,7 +153,7 @@ let rec parse_lpath (env:env) (e: lexpr) =
error env ~loc "Pointer-type expected for operator '*'"
| PLunop( Uamp , p ) ->
let lv = parse_lpath env p in
- let typ = TPtr( lv.typ , [] ) in
+ let typ = Cil_const.mk_tptr lv.typ in
{ loc ; step = AddrOf lv ; typ }
| PLbinop( p , Badd , rg ) ->
parse_lrange env rg ;
@@ -163,7 +163,7 @@ let rec parse_lpath (env:env) (e: lexpr) =
else
if Cil.isArrayType typ then
let te = Cil.typeOf_array_elem typ in
- { loc ; step = Shift lv ; typ = TPtr(te,[]) }
+ { loc ; step = Shift lv ; typ = Cil_const.mk_tptr te }
else
error env ~loc "Pointer-type expected for operator '+'"
| PLdot( p , f ) ->
diff --git a/src/plugins/region/fields.ml b/src/plugins/region/fields.ml
index 534f77821cb..10ef406262b 100644
--- a/src/plugins/region/fields.ml
+++ b/src/plugins/region/fields.ml
@@ -38,8 +38,8 @@ let compare (a : field) (b : field) =
if cmp <> 0 then cmp else
let cmp = a.length - b.length in
if cmp <> 0 then cmp else
- let sa = Cil.bitsSizeOf (TComp(a.data.fcomp,[])) in
- let sb = Cil.bitsSizeOf (TComp(b.data.fcomp,[])) in
+ let sa = Cil.bitsSizeOf (Cil_const.mk_tcomp a.data.fcomp) in
+ let sb = Cil.bitsSizeOf (Cil_const.mk_tcomp b.data.fcomp) in
sb - sa
let find_all (fields: domain) (rg : _ range) =
diff --git a/src/plugins/region/memory.ml b/src/plugins/region/memory.ml
index 0c6e4489e06..05ebda80818 100644
--- a/src/plugins/region/memory.ml
+++ b/src/plugins/region/memory.ml
@@ -374,7 +374,7 @@ let merge_copy (m: map) ~(l: node) ~(r: node) : unit =
let add_field (m:map) (r:node) (fd:fieldinfo) : node =
let ci = fd.fcomp in
if not ci.cstruct then r else
- let size = Cil.bitsSizeOf (TComp(ci,[])) in
+ let size = Cil.bitsSizeOf (Cil_const.mk_tcomp ci) in
let offset, length = Cil.fieldBitsOffset fd in
if offset = 0 && size = length then r else
let data = new_chunk m ~parent:r () in
diff --git a/src/plugins/region/services.ml b/src/plugins/region/services.ml
index 713b45a5bac..015323635f5 100644
--- a/src/plugins/region/services.ml
+++ b/src/plugins/region/services.ml
@@ -119,17 +119,17 @@ struct
| FDouble | FLongDouble -> 'd'
let typ_to_char (ty: Cil_types.typ) =
- match ty with
- | TVoid _ -> 'b'
+ match ty.tnode with
+ | TVoid -> 'b'
| TPtr _ -> 'p'
- | TInt(ik,_) -> ikind_to_char ik
- | TFloat(fk,_) -> fkind_to_char fk
- | TComp({ cstruct }, _) -> if cstruct then 'S' else 'U'
+ | TInt ik -> ikind_to_char ik
+ | TFloat fk -> fkind_to_char fk
+ | TComp { cstruct } -> if cstruct then 'S' else 'U'
| TArray _ -> 'A'
| TNamed _ -> 'T'
| TEnum _ -> 'E'
| TFun _ -> 'F'
- | TBuiltin_va_list _ -> 'x'
+ | TBuiltin_va_list -> 'x'
let typs_to_char (typs : Cil_types.typ list) =
match typs with
diff --git a/src/plugins/rte/rte.ml b/src/plugins/rte/rte.ml
index 157db28623c..572cff58e02 100644
--- a/src/plugins/rte/rte.ml
+++ b/src/plugins/rte/rte.ml
@@ -83,8 +83,8 @@ let lval_assertion ~read_only ~remove_trivial ~on_alarm lv =
(* Mark that we went through a struct field, then recurse *)
check_array_access default off fi.ftype true
| Index (e, off) ->
- match Cil.unrollType typ with
- | TArray (bt, Some size, _) ->
+ match Cil.unrollTypeNode typ with
+ | TArray (bt, Some size) ->
if Kernel.SafeArrays.get () || not in_struct then begin
(* Generate an assertion for this access, then go deeper in
case other accesses exist *)
@@ -95,7 +95,7 @@ let lval_assertion ~read_only ~remove_trivial ~on_alarm lv =
[-unsafe-arrays]. Honor the option and generate only
the default [\valid] assertion *)
check_array_access true off bt in_struct
- | TArray (bt, None, _) -> check_array_access true off bt in_struct
+ | TArray (bt, None) -> check_array_access true off bt in_struct
| _ -> assert false
in
match lv with
@@ -372,8 +372,8 @@ let downcast_assertion ~remove_trivial ~on_alarm (dst_type, exp) =
(* assertion for casting a floating-point value to an integer *)
let float_to_int_assertion ~remove_trivial ~on_alarm (ty, exp) =
let e_typ = Cil.unrollType (Cil.typeOf exp) in
- match e_typ, ty with
- | TFloat _, TInt (ikind,_) ->
+ match e_typ.tnode, ty.tnode with
+ | TFloat _, TInt ikind ->
let szTo = Cil.bitsSizeOfBitfield ty in
let min_ty, max_ty =
if Cil.isSigned ikind then
diff --git a/src/plugins/rte/visit.ml b/src/plugins/rte/visit.ml
index b0739c2a8e8..d260e9f5205 100644
--- a/src/plugins/rte/visit.ml
+++ b/src/plugins/rte/visit.ml
@@ -216,8 +216,8 @@ class annot_visitor kf flags on_alarm = object (self)
let generate () =
match exp.enode with
| BinOp((Div | Mod), lexp, rexp, ty) ->
- (match Cil.unrollType ty with
- | TInt(kind,_) ->
+ (match Cil.unrollTypeNode ty with
+ | TInt kind ->
(* add assertion "divisor not zero" *)
if self#do_div_mod () then
self#generate_assertion Rte.divmod_assertion rexp;
@@ -225,13 +225,13 @@ class annot_visitor kf flags on_alarm = object (self)
(* treat the special case of signed division/modulo overflow *)
let exp = { exp with enode = BinOp (Div, lexp, rexp, ty) } in
self#generate_assertion Rte.signed_div_assertion (exp, lexp, rexp)
- | TFloat(fkind,_) when self#do_finite_float () ->
+ | TFloat fkind when self#do_finite_float () ->
self#generate_assertion Rte.finite_float_assertion (fkind,exp);
| _ -> ())
| BinOp((Shiftlt | Shiftrt) as op, lexp, rexp,ttype ) ->
- (match Cil.unrollType ttype with
- | TInt(kind,_) ->
+ (match Cil.unrollTypeNode ttype with
+ | TInt kind ->
(* 0 <= rexp <= width *)
if self#do_shift () then begin
let typ = Cil.unrollType (Cil.typeOf exp) in
@@ -255,18 +255,18 @@ class annot_visitor kf flags on_alarm = object (self)
| BinOp((PlusA |MinusA | Mult) as op, lexp, rexp, ttype) ->
(* may be skipped if the enclosing expression is a downcast to a signed
type *)
- (match Cil.unrollType ttype with
- | TInt(kind,_) when Cil.isSigned kind ->
+ (match Cil.unrollTypeNode ttype with
+ | TInt kind when Cil.isSigned kind ->
if self#do_signed_overflow () && not (self#must_skip exp) then
self#generate_assertion
(Rte.mult_sub_add_assertion ~signed:true)
(exp, op, lexp, rexp)
- | TInt(kind,_) when not (Cil.isSigned kind) ->
+ | TInt kind when not (Cil.isSigned kind) ->
if self#do_unsigned_overflow () then
self#generate_assertion
(Rte.mult_sub_add_assertion ~signed:false)
(exp, op, lexp, rexp)
- | TFloat(fkind,_) when self#do_finite_float () ->
+ | TFloat fkind when self#do_finite_float () ->
self#generate_assertion Rte.finite_float_assertion (fkind,exp)
| _ -> ())
@@ -278,19 +278,19 @@ class annot_visitor kf flags on_alarm = object (self)
"subtracting the promoted value from the largest value
of the promoted type and adding one",
the result is always representable: so no overflow *)
- (match Cil.unrollType ty with
- | TInt(kind,_) when Cil.isSigned kind ->
+ (match Cil.unrollTypeNode ty with
+ | TInt kind when Cil.isSigned kind ->
if self#do_signed_overflow () then
self#generate_assertion Rte.uminus_assertion exp;
- | TFloat(fkind,_) when self#do_finite_float () ->
+ | TFloat fkind when self#do_finite_float () ->
self#generate_assertion Rte.finite_float_assertion (fkind,exp)
| _ -> ())
| Lval lval ->
- (match Cil.(unrollType (typeOfLval lval)) with
+ (match Cil.(unrollTypeNode (typeOfLval lval)) with
| TPtr _ when self#do_pointer_value () ->
self#generate_assertion Rte.pointer_value exp
- | TInt (IBool,_) when self#do_bool_value () ->
+ | TInt IBool when self#do_bool_value () ->
self#generate_assertion Rte.bool_value lval
| _ -> ());
(* left values are checked for valid access *)
@@ -310,14 +310,14 @@ class annot_visitor kf flags on_alarm = object (self)
Rte.lval_initialized_assertion lval
end ;
| CastE (ty, e) ->
- (match Cil.unrollType ty, Cil.unrollType (Cil.typeOf e) with
+ (match Cil.unrollTypeNode ty, Cil.(unrollTypeNode (typeOf e)) with
(* to , from *)
| TInt _, TPtr _ when self#do_pointer_downcast () ->
self#generate_assertion Rte.downcast_assertion (ty, e)
| TPtr _, TInt _ when self#do_pointer_value () ->
self#generate_assertion Rte.pointer_value exp
- | TInt(kind,_), TInt (_, _) ->
+ | TInt kind, TInt _ ->
let signed = Cil.isSigned kind in
if signed && self#do_signed_downcast ()
|| not signed && self#do_unsigned_downcast ()
@@ -329,7 +329,7 @@ class annot_visitor kf flags on_alarm = object (self)
if self#do_float_to_int () then
self#generate_assertion Rte.float_to_int_assertion (ty, e)
- | TFloat (to_fkind,_), TFloat (from_fkind,_) when
+ | TFloat to_fkind, TFloat from_fkind when
self#do_finite_float () && Cil.frank to_fkind < Cil.frank from_fkind ->
self#generate_assertion Rte.finite_float_assertion (to_fkind,exp)
| _ -> ());
diff --git a/src/plugins/server/kernel_ast.ml b/src/plugins/server/kernel_ast.ml
index 9374f9b6805..a26ad3bff8a 100644
--- a/src/plugins/server/kernel_ast.ml
+++ b/src/plugins/server/kernel_ast.ml
@@ -475,11 +475,11 @@ struct
let descr_localizable fmt = function
| PGlobal (GType(ti,_)) ->
- PrinterTag.pp_typ fmt (TNamed(ti,[]))
+ PrinterTag.pp_typ fmt (Cil_const.mk_tnamed ti)
| PGlobal (GCompTag(ci,_) | GCompTagDecl(ci,_)) ->
- PrinterTag.pp_typ fmt (TComp(ci,[]))
+ PrinterTag.pp_typ fmt (Cil_const.mk_tcomp ci)
| PGlobal (GEnumTag(ei,_) | GEnumTagDecl(ei,_)) ->
- PrinterTag.pp_typ fmt (TEnum(ei,[]))
+ PrinterTag.pp_typ fmt (Cil_const.mk_tenum ei)
| g -> pp_localizable fmt g
let model = States.model ()
@@ -917,7 +917,7 @@ let () = Information.register
~title:"Type Definition"
begin fun fmt loc ->
match loc with
- | PType (TNamed _ as ty)
+ | PType ({ tnode = TNamed _ } as ty)
| PGlobal (GType({ ttype = ty },_)) ->
begin
let tdef = Cil.unrollType ty in
@@ -940,8 +940,8 @@ let () = Information.register
| PType typ -> typ
| PVDecl(_,_,vi) -> vi.vtype
| PGlobal (GType(ti,_)) -> ti.ttype
- | PGlobal (GCompTagDecl(ci,_) | GCompTag(ci,_)) -> TComp(ci,[])
- | PGlobal (GEnumTagDecl(ei,_) | GEnumTag(ei,_)) -> TEnum(ei,[])
+ | PGlobal (GCompTagDecl(ci,_) | GCompTag(ci,_)) -> Cil_const.mk_tcomp ci
+ | PGlobal (GEnumTagDecl(ei,_) | GEnumTag(ei,_)) -> Cil_const.mk_tenum ei
| _ -> raise Not_found
in
let bits =
diff --git a/src/plugins/slicing/gui/register_gui.ml b/src/plugins/slicing/gui/register_gui.ml
index 3836fc2ea6c..4f04ccbc54b 100644
--- a/src/plugins/slicing/gui/register_gui.ml
+++ b/src/plugins/slicing/gui/register_gui.ml
@@ -228,8 +228,8 @@ let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
(Extlib.opt_filter
(fun kf ->
let is_not_void_kf x =
- match x.Cil_types.vtype with
- | Cil_types.TFun (Cil_types.TVoid (_),_,_,_) -> false
+ match x.Cil_types.vtype.tnode with
+ | TFun ({ tnode = TVoid },_,_) -> false
| _ -> true
in is_not_void_kf (Kernel_function.get_vi kf))
kf_opt)
diff --git a/src/plugins/slicing/slicingMacros.ml b/src/plugins/slicing/slicingMacros.ml
index fb9ae80dbfa..85610c5c23b 100644
--- a/src/plugins/slicing/slicingMacros.ml
+++ b/src/plugins/slicing/slicingMacros.ml
@@ -184,8 +184,8 @@ let get_called_kf call_stmt = match call_stmt.skind with
let is_variadic kf =
let varf = Kernel_function.get_vi kf in
- match varf.vtype with
- | TFun (_, _, is_variadic, _) -> is_variadic
+ match varf.vtype.tnode with
+ | TFun (_, _, is_variadic) -> is_variadic
| _ -> assert false
(** get the [fct_info] of the called function, if we know it *)
diff --git a/src/plugins/sparecode/globs.ml b/src/plugins/sparecode/globs.ml
index 75532cb5cc0..54c073df550 100644
--- a/src/plugins/sparecode/globs.ml
+++ b/src/plugins/sparecode/globs.ml
@@ -44,8 +44,8 @@ class collect_visitor = object (self)
inherit Visitor.frama_c_inplace
- method! vtype t = match t with
- | TNamed(ti,_) ->
+ method! vtype t = match t.tnode with
+ | TNamed ti ->
(* we use the type name because direct typeinfo comparison
* doesn't wok. Anyway, CIL renames types if several type have the same
* name... *)
@@ -56,13 +56,13 @@ class collect_visitor = object (self)
ignore (visitCilType (self:>Cil.cilVisitor) ti.ttype);
DoChildren
end
- | TEnum(ei,_) ->
+ | TEnum ei ->
if Hashtbl.mem used_enuminfo ei.ename then SkipChildren
else begin
debug "add used enum %s@." ei.ename;
Hashtbl.add used_enuminfo ei.ename (); DoChildren
end
- | TComp(ci,_) ->
+ | TComp ci ->
if Hashtbl.mem used_compinfo ci.cname then SkipChildren
else begin
debug "add used comp %s@." ci.cname;
diff --git a/src/plugins/variadic/classify.ml b/src/plugins/variadic/classify.ml
index 2b446c01ed2..5fe48496b13 100644
--- a/src/plugins/variadic/classify.ml
+++ b/src/plugins/variadic/classify.ml
@@ -65,9 +65,9 @@ let mk_aggregator env fun_name a_pos pname a_type =
(* Get the aggregate type of elements *)
let _,ptyp,_ = List.nth params a_pos in
- let a_param = pname, match ptyp with
- | TArray (typ,_,_)
- | TPtr (typ, _) -> typ
+ let a_param = pname, match ptyp.tnode with
+ | TArray (typ, _)
+ | TPtr typ -> typ
| _ ->
Self.warning ~current:true ~wkey:wkey_libc
"The parameter %d of standard function %s should be \
@@ -169,8 +169,8 @@ let classify_std env vi = match vi.vname with
| _ -> Unknown
let is_variadic_function vi =
- match Cil.unrollType vi.vtype with
- | TFun (_, _, b, _) -> b
+ match Cil.unrollTypeNode vi.vtype with
+ | TFun (_, _, b) -> b
| _ -> false
let classify env vi =
diff --git a/src/plugins/variadic/environment.ml b/src/plugins/variadic/environment.ml
index 2b845df242d..37ad5aa1404 100644
--- a/src/plugins/variadic/environment.ml
+++ b/src/plugins/variadic/environment.ml
@@ -82,13 +82,13 @@ let find_type (env : t) (namespace : Logic_typing.type_namespace)
(tname : string) : typ =
match namespace with
| Logic_typing.Typedef ->
- TNamed (find_typedef env tname, [])
+ Cil_const.mk_tnamed (find_typedef env tname)
| Logic_typing.Struct ->
- TComp (find_struct env tname, [])
+ Cil_const.mk_tcomp (find_struct env tname)
| Logic_typing.Union ->
- TComp (find_union env tname, [])
+ Cil_const.mk_tcomp (find_union env tname)
| Logic_typing.Enum ->
- TEnum (find_enum env tname, [])
+ Cil_const.mk_tenum (find_enum env tname)
let mem_global (env : t) (vname : string) : bool =
Table.mem env.globals vname
diff --git a/src/plugins/variadic/extends.ml b/src/plugins/variadic/extends.ml
index 33b2e8b2062..bb52dce9cb8 100644
--- a/src/plugins/variadic/extends.ml
+++ b/src/plugins/variadic/extends.ml
@@ -24,13 +24,13 @@ open Cil_types
module Typ = struct
let params typ =
- match Cil.unrollType typ with
- | TFun (_,args,_,_) -> Cil.argsToList args
+ match Cil.unrollTypeNode typ with
+ | TFun (_, args, _) -> Cil.argsToList args
| _ -> invalid_arg "params"
let ghost_partitioned_params typ =
- match Cil.unrollType typ with
- | TFun (_,args,_,_) -> Cil.argsToPairOfLists args
+ match Cil.unrollTypeNode typ with
+ | TFun (_, args, _) -> Cil.argsToPairOfLists args
| _ -> invalid_arg "params"
let params_types typ =
diff --git a/src/plugins/variadic/format_typer.ml b/src/plugins/variadic/format_typer.ml
index dedfa270948..2b49623b5aa 100644
--- a/src/plugins/variadic/format_typer.ml
+++ b/src/plugins/variadic/format_typer.ml
@@ -21,7 +21,6 @@
(**************************************************************************)
open Format_types
-open Cil_types
exception Type_not_found of string
exception Invalid_specifier
@@ -40,8 +39,7 @@ let get_typedef ?(find_typedef = Globals.Types.find_type) s =
with Not_found ->
raise (Type_not_found s)
-let ptr typ = TPtr (typ, [])
-
+let ptr = Cil_const.mk_tptr
let type_f_specifier ?find_typedef spec =
match spec.f_conversion_specifier, spec.f_length_modifier with
diff --git a/src/plugins/variadic/generic.ml b/src/plugins/variadic/generic.ml
index 592cdcff055..69267cfe9d9 100644
--- a/src/plugins/variadic/generic.ml
+++ b/src/plugins/variadic/generic.ml
@@ -29,8 +29,8 @@ module Build = Cil_builder.Pure
(* Types of variadic parameter and argument *)
-let vpar_typ attr =
- TPtr (TPtr (TVoid [], [Attr ("const", [])]), attr)
+let vpar_typ tattr =
+ Cil_const.(mk_tptr ~tattr (mk_tptr ~tattr:[Attr ("const", [])] voidType))
let vpar_name = "__va_params"
let vpar =
(vpar_name, vpar_typ [], [])
@@ -38,8 +38,9 @@ let vpar =
(* Translation of variadic types (not deeply) *)
-let translate_type = function
- | TFun (ret_typ, args, is_variadic, attributes) ->
+let translate_type t =
+ match t.tnode with
+ | TFun (ret_typ, args, is_variadic) ->
let new_args =
if is_variadic
then
@@ -47,11 +48,9 @@ let translate_type = function
Some (ng_args @ [vpar] @ g_args)
else args
in
- TFun (ret_typ, new_args, false, attributes)
-
- | TBuiltin_va_list attr -> vpar_typ attr
-
- | typ -> typ
+ Cil_const.mk_tfun ~tattr:t.tattr ret_typ new_args false
+ | TBuiltin_va_list -> vpar_typ t.tattr
+ | _ -> t
(* Adding the vpar parameter to variadic functions *)
diff --git a/src/plugins/variadic/standard.ml b/src/plugins/variadic/standard.ml
index cf5c7f43bc8..ede962c78c9 100644
--- a/src/plugins/variadic/standard.ml
+++ b/src/plugins/variadic/standard.ml
@@ -71,8 +71,8 @@ let extended_integer_typenames =
"int_fast64_t"; "uint_fast64_t"]
let is_extended_integer_type t =
- match t with
- | TNamed (ti, _) -> List.mem ti.tname extended_integer_typenames
+ match t.tnode with
+ | TNamed ti -> List.mem ti.tname extended_integer_typenames
| _ -> false
let integral_rep ikind =
@@ -89,12 +89,14 @@ type castability = Strict (* strictly allowed by the C standard *)
| Never (* never allowed *)
let can_cast given expected =
- match expose given, expose expected with
- | t1, t2 when Cil_datatype.Typ.equal t1 t2 -> Strict
- | (TInt (i1,a1) | TEnum({ekind=i1},a1)),
- (TInt (i2,a2) | TEnum({ekind=i2},a2)) ->
+ let t1 = expose given
+ and t2 = expose expected in
+ match t1.tnode, t2.tnode with
+ | _, _ when Cil_datatype.Typ.equal t1 t2 -> Strict
+ | (TInt i1 | TEnum {ekind=i1}),
+ (TInt i2 | TEnum {ekind=i2}) ->
if integral_rep i1 <> integral_rep i2 ||
- not (Cil_datatype.Attributes.equal a1 a2) then
+ not (Cil_datatype.Attributes.equal t1.tattr t2.tattr) then
Never
else if is_extended_integer_type given then
Tolerated
@@ -106,17 +108,17 @@ let can_cast given expected =
| _, _ -> Never
let does_fit exp typ =
- match Cil.constFoldToInt exp, Cil.unrollType typ with
- | Some i, (TInt (ekind,_) | TEnum({ekind},_)) ->
+ match Cil.constFoldToInt exp, Cil.unrollTypeNode typ with
+ | Some i, (TInt ekind | TEnum {ekind}) ->
Cil.fitsInInt ekind i
| _ -> false
(* Variant of [pp_typ] which details the underlying type for enums *)
let pretty_typ fmt t =
- match Cil.unrollType t with
- | TEnum (ei, _) ->
+ match Cil.unrollTypeNode t with
+ | TEnum ei ->
Format.fprintf fmt "%a (%a)" Printer.pp_typ t
- Printer.pp_typ (TInt (ei.ekind, []))
+ Printer.pp_typ (Cil_const.mk_tint ei.ekind)
| _ -> Printer.pp_typ fmt t
(* cast the i-th argument exp to paramtyp *)
@@ -309,10 +311,10 @@ let aggregator_call ~builder aggregator vf args =
(* ************************************************************************ *)
let rec check_arg_matching expected given =
- match Cil.unrollType given, Cil.unrollType expected with
+ match Cil.unrollTypeNode given, Cil.unrollTypeNode expected with
| (TInt _ | TEnum _), (TInt _ | TEnum _) -> true
| TPtr _, _ when Cil.isVoidPtrType expected -> true
- | TPtr (t1, _), TPtr (t2, _) -> check_arg_matching t1 t2
+ | TPtr t1, TPtr t2 -> check_arg_matching t1 t2
| _, _ -> not (Cil.need_cast given expected)
@@ -419,9 +421,9 @@ let find_field env structname fieldname =
raise Not_found
let find_predicate_by_width typ narrow_name wide_name =
- match Cil.unrollTypeDeep typ with
- | TPtr (TInt(IChar, _), _) -> find_predicate narrow_name
- | TPtr (t, _) when
+ match Cil.(unrollTypeDeep typ).tnode with
+ | TPtr { tnode = TInt IChar } -> find_predicate narrow_name
+ | TPtr t when
(* drop attributes to remove 'const' qualifiers and fc_stdlib attributes *)
Cil_datatype.Typ.equal
(Cil.typeDeepDropAllAttributes (Cil.unrollTypeDeep t))
@@ -640,17 +642,17 @@ let format_of_fkind k = function
| FLongDouble -> Some `L, `f
let rec format_of_type vf k t =
- match t with
- | TInt (ikind,_) | TEnum ({ekind = ikind},_) -> format_of_ikind ikind
- | TFloat (fkind,_) -> format_of_fkind k fkind
- | TPtr(_,_) ->
+ match t.tnode with
+ | TInt ikind | TEnum {ekind = ikind} -> format_of_ikind ikind
+ | TFloat fkind -> format_of_fkind k fkind
+ | TPtr _ ->
(* technically, we might still want to write/read the actual pointer,
but this is not the most likely possibility. *)
if Cil.isCharPtrType t then
None, `s
else
None, `p
- | TNamed ({tname;ttype},_) ->
+ | TNamed {tname; ttype} ->
(match tname with
| "size_t" -> Some `z, `u
| "ptrdiff_t" -> Some `t, `d
@@ -665,13 +667,13 @@ let rec format_of_type vf k t =
the format string itself, but this can't really be checked
here.
*)
- | TVoid _ -> raise (Translate_call_exn vf.vf_decl)
+ | TVoid -> raise (Translate_call_exn vf.vf_decl)
(* these cases should not happen anyway *)
| TComp _
| TFun _
| TArray _
- | TBuiltin_va_list _ -> raise (Translate_call_exn vf.vf_decl)
+ | TBuiltin_va_list -> raise (Translate_call_exn vf.vf_decl)
let infer_format_from_args vf format_fun args =
let args = List.drop (format_fun.f_format_pos + 1) args in
diff --git a/src/plugins/wp/CodeSemantics.ml b/src/plugins/wp/CodeSemantics.ml
index 7425baceb10..4c2ef890df6 100644
--- a/src/plugins/wp/CodeSemantics.ml
+++ b/src/plugins/wp/CodeSemantics.ml
@@ -33,15 +33,16 @@ open Sigma
open Lang
module WpLog = Wp_parameters
-let constfold_ctyp = function
- | TArray (_,Some {enode = (Const CInt64 _) },_) as ct -> ct
- | TArray (ty,Some len,attr) as ct -> begin
+let constfold_ctyp t =
+ match t.tnode with
+ | TArray (_,Some {enode = (Const CInt64 _) }) -> t
+ | TArray (ty,Some len) -> begin
match Cil.constFold true len with
| {enode = (Const CInt64 _) } as len ->
- TArray(ty,Some len,attr)
- | _ -> ct
+ Cil_const.mk_tarray ~tattr:t.tattr ty (Some len)
+ | _ -> t
end
- | ct -> ct
+ | _ -> t
let constfold_coffset = function
| Index({enode=Const (CInt64 _)}, _) as off -> off
@@ -194,8 +195,8 @@ struct
let t2 = Cil.typeOf e2 in
if Cil.isPointerType t1 && Cil.isPointerType t2 then
Cvalues.is_true (lop (loc_of_exp env e1) (loc_of_exp env e2))
- else match Cil.unrollType t1 with
- | TFloat(f,_) ->
+ else match Cil.unrollTypeNode t1 with
+ | TFloat f ->
let p = fop (Ctypes.c_float f)
(val_of_exp env e1) (val_of_exp env e2) in
F.e_if (F.e_prop p) F.e_one F.e_zero
@@ -492,11 +493,11 @@ struct
| CompoundInit ( ct , initl ) ->
let ct = constfold_ctyp ct in
let acc = (* updated acc with default init of structure *)
- match ct with
- | TComp ( { cfields = None },_) ->
+ match ct.tnode with
+ | TComp { cfields = None } ->
Wp_parameters.fatal
"Initializer for incomplete type %a" Cil_printer.pp_typ ct
- | TComp ( { cstruct ; cfields = Some fields },_)
+ | TComp { cstruct ; cfields = Some fields }
when cstruct && (* not for union... *)
(List.length initl) < (List.length fields) ->
(* default init for unintialized field of a struct *)
@@ -518,8 +519,8 @@ struct
| _ -> acc
in
- match ct with
- | TArray (ty,len,_) ->
+ match ct.tnode with
+ | TArray (ty, len) ->
let delayed =
match len with (* number of required elements *)
| Some {enode = (Const CInt64 (size,_,_))} ->
diff --git a/src/plugins/wp/Layout.ml b/src/plugins/wp/Layout.ml
index 14007c92901..08200dd47b7 100644
--- a/src/plugins/wp/Layout.ml
+++ b/src/plugins/wp/Layout.ml
@@ -67,8 +67,8 @@ struct
let field fd = Field fd
let index ty =
- match Cil.unrollType ty with
- | TArray(te,n,_) ->
+ match Cil.unrollTypeNode ty with
+ | TArray (te, n) ->
begin
match Option.bind n Ctypes.get_int with
| None -> failwith "Wp.Layout: unkown array size"
@@ -96,7 +96,7 @@ struct
let typ_of_comp cache comp =
try H.find cache comp with Not_found ->
- let typ = TComp(comp,[]) in
+ let typ = Cil_const.mk_tcomp comp in
H.add cache comp typ ; typ
let field_offset _cache fd =
@@ -471,16 +471,16 @@ struct
pp fmt layout
let deref ~pointed (_,typ) =
- match Cil.unrollType typ with
- | TInt(ti,_) | TEnum({ ekind = ti },_) -> Chunk (Int (Ctypes.c_int ti))
- | TFloat(tf,_) -> Chunk (Float (Ctypes.c_float tf))
+ match Cil.unrollTypeNode typ with
+ | TInt ti | TEnum { ekind = ti } -> Chunk (Int (Ctypes.c_int ti))
+ | TFloat tf -> Chunk (Float (Ctypes.c_float tf))
| TPtr _ | TFun _ -> Chunk(Pointer(Lazy.force pointed))
- | TVoid _ | TNamed _ | TComp _ | TArray _ | TBuiltin_va_list _ -> Empty
+ | TVoid | TNamed _ | TComp _ | TArray _ | TBuiltin_va_list -> Empty
let rec get_dim s rds typ =
if s = Cil.bitsSizeOf typ then Some (List.rev rds) else
- match Cil.unrollType typ with
- | TArray( te , Some e , _ ) ->
+ match Cil.unrollTypeNode typ with
+ | TArray( te , Some e ) ->
begin match Ctypes.get_int e with
| None -> None
| Some n -> get_dim s (if n = 1 then rds else n::rds) te
diff --git a/src/plugins/wp/LogicSemantics.ml b/src/plugins/wp/LogicSemantics.ml
index b51c72c389c..0496a6436a0 100644
--- a/src/plugins/wp/LogicSemantics.ml
+++ b/src/plugins/wp/LogicSemantics.ml
@@ -358,8 +358,8 @@ struct
let float_of_logic_type lt =
match Logic_utils.unroll_type lt with
| Ctype ty ->
- (match Cil.unrollType ty with
- | TFloat(f,_) -> Some (Ctypes.c_float f)
+ (match Cil.unrollTypeNode ty with
+ | TFloat f -> Some (Ctypes.c_float f)
| _ -> None)
| _ -> None
diff --git a/src/plugins/wp/MemBytes.ml b/src/plugins/wp/MemBytes.ml
index 2dc4d78d107..dbafcf1432d 100644
--- a/src/plugins/wp/MemBytes.ml
+++ b/src/plugins/wp/MemBytes.ml
@@ -268,7 +268,7 @@ module RegisterShift = WpContext.Static
end)
let field_offset ci field =
- let comp = Cil_types.TComp(ci, []) in
+ let comp = Cil_const.mk_tcomp ci in
let field = Cil_types.Field(field, NoOffset) in
let bits_offset, bits_size = Cil.bitsOffset comp field in
if 0 <> bits_offset mod 8 || 0 <> bits_size mod 8 then
diff --git a/src/plugins/wp/MemTyped.ml b/src/plugins/wp/MemTyped.ml
index bd5012d9745..d44f27b0c96 100644
--- a/src/plugins/wp/MemTyped.ml
+++ b/src/plugins/wp/MemTyped.ml
@@ -674,7 +674,7 @@ struct
type atom = P of typ | I of c_int | F of c_float
let pp_atom fmt = function
- | P ty -> Printer.pp_typ fmt (TPtr(ty,[]))
+ | P ty -> Printer.pp_typ fmt (Cil_const.mk_tptr ty)
| I i -> Ctypes.pp_int fmt i
| F f -> Ctypes.pp_float fmt f
diff --git a/src/plugins/wp/MemVar.ml b/src/plugins/wp/MemVar.ml
index ac5e5a73fd0..700340628f7 100644
--- a/src/plugins/wp/MemVar.ml
+++ b/src/plugins/wp/MemVar.ml
@@ -327,7 +327,7 @@ struct
match m with
| CVAL | HEAP -> x.vtype
| CTXT _ | CREF -> Cil.typeOf_pointed x.vtype
- | CARR _ -> Ast_info.array_type (Cil.typeOf_pointed x.vtype)
+ | CARR _ -> Cil_const.mk_tarray (Cil.typeOf_pointed x.vtype) None
let vobject m x = Ctypes.object_of (vtype m x)
@@ -936,18 +936,18 @@ struct
(* -------------------------------------------------------------------------- *)
let rec forall_pointers phi v t =
- match Cil.unrollType t with
- | TInt _ | TFloat _ | TVoid _ | TEnum _ | TNamed _ | TBuiltin_va_list _
+ match Cil.unrollTypeNode t with
+ | TInt _ | TFloat _ | TVoid | TEnum _ | TNamed _ | TBuiltin_va_list
-> F.p_true
| TPtr _ | TFun _ -> phi v
- | TComp({ cfields = None },_) ->
+ | TComp { cfields = None } ->
F.p_true
- | TComp({ cfields = Some fields },_) ->
+ | TComp { cfields = Some fields } ->
F.p_all
(fun fd ->
forall_pointers phi (e_getfield v (cfield fd)) fd.ftype)
fields
- | TArray(elt,_,_) ->
+ | TArray (elt, _) ->
let k = Lang.freshvar Qed.Logic.Int in
F.p_forall [k] (forall_pointers phi (e_get v (e_var k)) elt)
diff --git a/src/plugins/wp/MemoryContext.ml b/src/plugins/wp/MemoryContext.ml
index d1cb4eb58da..b0910d07888 100644
--- a/src/plugins/wp/MemoryContext.ml
+++ b/src/plugins/wp/MemoryContext.ml
@@ -111,7 +111,7 @@ let set x p w =
open Logic_const
let rec ptr_of = function
- | Ctype t -> Ctype (TPtr(t, []))
+ | Ctype t -> Ctype (Cil_const.mk_tptr t)
| t when Logic_typing.is_set_type t ->
let t = Logic_typing.type_of_set_elem t in
Logic_const.make_set_type (ptr_of t)
@@ -143,9 +143,9 @@ let rec addr_of_lval ?loc term =
let type_of_zone = function
| Ptr vi -> vi.vtype
- | Var vi -> TPtr(vi.vtype, [])
+ | Var vi -> Cil_const.mk_tptr vi.vtype
| Arr vi when Cil.isPointerType vi.vtype -> vi.vtype
- | Arr vi -> TPtr(Cil.typeOf_array_elem vi.vtype, [])
+ | Arr vi -> Cil_const.mk_tptr (Cil.typeOf_array_elem vi.vtype)
let zone_to_term ?(to_char=false) loc zone =
let typ = Ctype (type_of_zone zone) in
@@ -155,7 +155,7 @@ let zone_to_term ?(to_char=false) loc zone =
else
let pointed =
match typ with
- | (Ctype (TPtr (t, []))) -> t
+ | (Ctype ({ tnode = TPtr t })) -> t
| _ -> assert false (* typ has been generated by type_of_zone *)
in
let len = Logic_utils.expr_to_term (Cil.sizeOf ~loc pointed) in
diff --git a/src/plugins/wp/Why3Import.ml b/src/plugins/wp/Why3Import.ml
index b6362e509d6..366346589ef 100644
--- a/src/plugins/wp/Why3Import.ml
+++ b/src/plugins/wp/Why3Import.ml
@@ -210,7 +210,7 @@ and lv_of_ty env menv (tvars:tvars) (index) (ty:W.Ty.ty) : C.logic_var =
and lt_of_ty_opt (lt_opt) =
match lt_opt with
- | None -> C.Ctype (C.TVoid []) (* Same as logic_typing *)
+ | None -> C.Ctype Cil_const.voidType (* Same as logic_typing *)
| Some tr -> tr
let li_of_ls env menv (ls : W.Term.lsymbol) : C.logic_info =
diff --git a/src/plugins/wp/ctypes.ml b/src/plugins/wp/ctypes.ml
index 79bf4715fde..8275326feae 100644
--- a/src/plugins/wp/ctypes.ml
+++ b/src/plugins/wp/ctypes.ml
@@ -264,11 +264,12 @@ let get_int64 e =
| _ -> None
let dimension t =
- let rec flat k d = function
- | TNamed (r,_) -> flat k d r.ttype
- | TArray(ty,Some e,_) ->
+ let rec flat k d t =
+ match t.tnode with
+ | TNamed r -> flat k d r.ttype
+ | TArray (ty, Some e) ->
flat (succ k) (Int64.mul d (constant e)) ty
- | te -> k , d , te
+ | _ -> k , d , t
in flat 1 Int64.one t
(* -------------------------------------------------------------------------- *)
@@ -280,14 +281,14 @@ let is_pointer = function
| C_int _ | C_float _ | C_array _ | C_comp _ -> false
let rec object_of typ =
- match typ with
- | TInt(i,_) -> C_int (c_int i)
- | TFloat(f,_) -> C_float (c_float f)
- | TPtr(typ,_) -> C_pointer (if Cil.isVoidType typ then Cil_const.charType else typ)
+ match typ.tnode with
+ | TInt i -> C_int (c_int i)
+ | TFloat f -> C_float (c_float f)
+ | TPtr typ -> C_pointer (if Cil.isVoidType typ then Cil_const.charType else typ)
| TFun _ -> C_pointer Cil_const.voidType
- | TEnum ({ekind=i},_) -> C_int (c_int i)
- | TComp (comp,_) -> C_comp comp
- | TArray (typ_elt,e_opt,_) ->
+ | TEnum {ekind=i} -> C_int (c_int i)
+ | TComp comp -> C_comp comp
+ | TArray (typ_elt,e_opt) ->
begin
match array_size e_opt with
| None ->
@@ -307,13 +308,13 @@ let rec object_of typ =
}
}
end
- | TBuiltin_va_list _ ->
+ | TBuiltin_va_list ->
WpLog.warning ~current:true ~once:true "variadyc type (considered as void*)" ;
- C_pointer (TVoid [])
- | TVoid _ ->
+ C_pointer (Cil_const.voidType)
+ | TVoid ->
WpLog.warning ~current:true "void object" ;
C_int (c_int IInt)
- | TNamed (r,_) -> object_of r.ttype
+ | TNamed r -> object_of r.ttype
(* ------------------------------------------------------------------------ *)
(* --- Comparable --- *)
@@ -405,13 +406,14 @@ let to_fkind flt =
List.find (fun fk -> c_float fk = flt) fkinds
let object_to = function
- | C_int i -> TInt(to_ikind i,[])
- | C_float f -> TFloat(to_fkind f,[])
- | C_pointer typ -> TPtr(typ,[])
- | C_comp comp -> TComp(comp,[])
- | C_array { arr_element = elt ; arr_flat = None } -> TArray(elt,None,[])
+ | C_int i -> Cil_const.mk_tint (to_ikind i)
+ | C_float f -> Cil_const.mk_tfloat (to_fkind f)
+ | C_pointer typ -> Cil_const.mk_tptr typ
+ | C_comp comp -> Cil_const.mk_tcomp comp
+ | C_array { arr_element = elt ; arr_flat = None } -> Cil_const.mk_tarray elt None
| C_array { arr_element = elt ; arr_flat = Some { arr_size = size } } ->
- TArray(elt,Some (Cil.integer ~loc:Location.unknown size),[])
+ let size = Some (Cil.integer ~loc:Location.unknown size) in
+ Cil_const.mk_tarray elt size
(* -------------------------------------------------------------------------- *)
(* --- Accessor Utilities --- *)
@@ -499,16 +501,14 @@ let sizeof_defined = function
| C_array { arr_flat = None } -> false
| _ -> true
-let typ_comp cinfo = TComp(cinfo,[])
-
-let bits_sizeof_comp cinfo = Cil.bitsSizeOf (typ_comp cinfo)
+let bits_sizeof_comp cinfo = Cil.bitsSizeOf (Cil_const.mk_tcomp cinfo)
let bits_sizeof_array ainfo =
match ainfo.arr_flat with
| Some a ->
let csize = Cil.kinteger64
~loc:Cil_builtins.builtinLoc (Z.of_int64 a.arr_cell_nbr) in
- let ctype = TArray(a.arr_cell,Some csize,[]) in
+ let ctype = Cil_const.mk_tarray a.arr_cell (Some csize) in
Cil.bitsSizeOf ctype
| None ->
if WpLog.ExternArrays.get () then
@@ -576,8 +576,9 @@ let rec basename = function
| None -> te ^ "_array"
| Some f -> te ^ "_" ^ string_of_int f.arr_size
-let is_atomic = function
- | TVoid _ | TInt _ | TFloat _ | TNamed _ -> true
+let is_atomic t =
+ match t.tnode with
+ | TVoid | TInt _ | TFloat _ | TNamed _ -> true
| _ -> false
let rec pretty fmt = function
diff --git a/tests/cil/Change_formals.ml b/tests/cil/Change_formals.ml
index 4fd188fb453..a424bd02ca2 100644
--- a/tests/cil/Change_formals.ml
+++ b/tests/cil/Change_formals.ml
@@ -33,12 +33,12 @@ class transform prj = object(_self)
begin match l with
| (GFunDecl (_fspec, vi, _loc) as g) :: [] ->
if not (Cil_builtins.Frama_c_builtins.mem vi.vname) then
- begin match vi.vtype with
- | TFun(typ, args, varity, attr) ->
+ begin match vi.vtype.tnode with
+ | TFun(typ, args, varity) ->
let vtype = Cil.argsToList args in
- let new_fun_typ = TFun(
- typ, Some (vtype @ [ "ok", Cil_const.intType, [] ]),
- varity, attr)
+ let args =Some (vtype @ [ "ok", Cil_const.intType, [] ]) in
+ let new_fun_typ =
+ Cil_const.mk_tfun ~tattr:vi.vtype.tattr typ args varity
in
Cil.update_var_type vi new_fun_typ;
Project.on
diff --git a/tests/libc/check_libc_anonymous_tags.ml b/tests/libc/check_libc_anonymous_tags.ml
index 8e59f646a94..a2bff2a9a94 100644
--- a/tests/libc/check_libc_anonymous_tags.ml
+++ b/tests/libc/check_libc_anonymous_tags.ml
@@ -33,12 +33,12 @@ class tags_visitor = object
method! vtype typ =
begin
- match typ with
- | TEnum (ei, _) when ei.eorig_name = "" && !in_stdlib ->
+ match typ.tnode with
+ | TEnum ei when ei.eorig_name = "" && !in_stdlib ->
Kernel.warning ~current:true ~once:true
"anonymous enum in Frama-C stdlib";
()
- | TComp (ci, _) when ci.corig_name = "" && !in_stdlib ->
+ | TComp ci when ci.corig_name = "" && !in_stdlib ->
Kernel.warning ~current:true ~once:true
"anonymous %s in Frama-C stdlib"
(if ci.cstruct then "struct" else "union")
diff --git a/tests/misc/exception.ml b/tests/misc/exception.ml
index 4c9ed2c6c31..6420d48b977 100644
--- a/tests/misc/exception.ml
+++ b/tests/misc/exception.ml
@@ -30,12 +30,12 @@ let add_throw_test f exn_type test init =
let add_my_exn my_exn f =
let c = Cil.evar (List.hd f.sformals) in
- let exn_type = TComp(my_exn,[]) in
+ let exn_type = Cil_const.mk_tcomp my_exn in
let loc = Cil_datatype.Location.unknown in
let my_field = List.hd (Option.get my_exn.cfields) in
let kind =
- match my_field.ftype with
- | TInt(ik,_) -> ik
+ match my_field.ftype.tnode with
+ | TInt ik -> ik
| _ -> Kernel.fatal "Unexpected struct for the test"
in
let init =
@@ -65,8 +65,8 @@ let add_int_ptr_exn glob f =
add_throw_test f Cil_const.intPtrType test init
let add_catch my_exn my_exn2 f =
- let exn_type = TComp(my_exn, []) in
- let exn_type2 = TComp(my_exn2, []) in
+ let exn_type = Cil_const.mk_tcomp my_exn in
+ let exn_type2 = Cil_const.mk_tcomp my_exn2 in
let exn_field = List.hd (Option.get my_exn.cfields) in
let exn_field_offset = Field(exn_field,NoOffset) in
let exn2_field = List.hd (Option.get my_exn2.cfields) in
diff --git a/tests/spec/model.ml b/tests/spec/model.ml
index 7ece88634f0..3332bb44985 100644
--- a/tests/spec/model.ml
+++ b/tests/spec/model.ml
@@ -36,7 +36,7 @@ let remove_model annot = Annotations.remove_global e annot
let main () =
let t = find () in
- let typ = TNamed(t,[]) in
+ let typ = Cil_const.mk_tnamed t in
print_models typ;
let m = add_model typ in
Format.printf "After adding field@.";
diff --git a/tests/syntax/ghost_cv_var_decl.ml b/tests/syntax/ghost_cv_var_decl.ml
index d9c6c4dfae3..7ab82f4ebd9 100644
--- a/tests/syntax/ghost_cv_var_decl.ml
+++ b/tests/syntax/ghost_cv_var_decl.ml
@@ -5,7 +5,7 @@ let rec ghost_status fmt lval =
let ghost = Cil.isGhostType t in
Format.fprintf fmt "%s" (if ghost then "ghost" else "normal") ;
- match t with
+ match t.tnode with
| TPtr(_) ->
Format.fprintf fmt " -> %a" pointed_ghost_status lval
| TArray(_) ->
@@ -23,8 +23,8 @@ and in_array_ghost_status fmt lval =
let lval = Cil.addOffsetLval (Index((Cil.zero ~loc), NoOffset)) lval in
Format.fprintf fmt "%a" ghost_status lval
and comp_ghost_status fmt lval =
- match Cil.typeOfLval lval with
- | TComp({ cfields }, _) ->
+ match (Cil.typeOfLval lval).tnode with
+ | TComp { cfields } ->
Format.fprintf fmt "{ " ;
List.iter (field_ghost_status fmt lval) (Option.value ~default:[] cfields) ;
Format.fprintf fmt " }"
diff --git a/tests/syntax/transient_block.ml b/tests/syntax/transient_block.ml
index 6cde00d6b77..722d5d1aa63 100644
--- a/tests/syntax/transient_block.ml
+++ b/tests/syntax/transient_block.ml
@@ -11,7 +11,7 @@ class vis prj = object(self)
if create then begin
let f = Visitor_behavior.Get.fundec
self#behavior (Option.get self#current_func) in
- let y = Cil.makeLocalVar f ~scope:b "y" (TInt(IInt,[])) in
+ let y = Cil.makeLocalVar f ~scope:b "y" Cil_const.intType in
my_var <- Some y;
let loc = Cil_datatype.Location.unknown in
let s2 =
--
GitLab