diff --git a/Changelog b/Changelog
index 411db5c4cdc871caeb04a2aaa4e7c4f8f44d1754..20f4f6bdef5a3eb46e105237bc74831958f8148e 100644
--- a/Changelog
+++ b/Changelog
@@ -18,6 +18,8 @@
Open Source Release <next-release>
###############################################################################
+o! Kernel [2025-01-31] Use a record to represent `Cil_types.typ` with two
+ fields `tnode` and `tattr` for its `typ_node` and `attributes`.
- Ivette [2025-01-23] New sidebar listing functions and global variables
for each source file.
- Eva [2025-01-23] Rename warning key `invalid-assigns` to
diff --git a/src/kernel_internals/typing/asm_contracts.ml b/src/kernel_internals/typing/asm_contracts.ml
index 004d7625ab6d8ea877817dd7948d582de84e2ef2..25198e9ec44102e2b9a42a10e04a4c8be2c94ab7 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 8ca38fc5074160939c7b5a83a1ec2ce56d50cbc6..5861b4be5f3f3dc1f3c57e7df7e56bec8353dc0a 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 ulongType 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 dd3a5352291b159e4c841d8c655bb7d9af2d1c77..bcb3608ec9585467e862e87bf6ad85264268e081 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 ff70d3ae21cb6de3c019ebc7bcf19ff6647abb8b..8ef7322e05a037950180f51ecbd28cda04ab471b 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 b61c740185a40948648cef82a821b8afdfff8398..c2af9d8bb7875eaa3b2febec3af55d3cbe8e5bf3 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 d9ef2e8af3dbe3d4647d98a37ef8194e996c5508..81edf28f544a4db70e962c1c54957bb2fbd752e7 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 6f805da8dae22ea573d8f57a5f9c0b26090a3741..fcf62faa80b9021074335d1091a3d030a6d1397f 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 7dcb102cb801783c5d6370ed0c8fcce4e0bca1c4..14ec4b538c9e1cc6f88cfe03b2d29a74ec176592 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 4763c4e44e6b3d2cbcf71e38046641edfc7bbf2f..df5860eb8c8777935681ecf56be2000d1a6e9a4a 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 3b32bf604b90295644c44961b0178d731d6a9006..8aa162acb65295c2a00bd8f88d9b4b4a4b7244bb 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 39cce4963fe4229d21b251adff7b2a7dbac170c9..37f7e90159b28f249f1c833273f6b385190d84ae 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 7c1a623c66eacc62673262f2b6c367eaac145f0a..5be034f8c616d934ed3418323a306c4bd6c4890e 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 6c3396d6ea247b2504791e47b8bdebb752a73bde..79afd2818a6f35fdd828d5700c9b3150a01cc7ea 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 609500cda3e05c185cc0b92de0a05827bfb9c0c6..747ad94e0e5897824a20c07ea6a608477d79cc18 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 97e4839294da7867b7ef4f3c8ece5681d107cad3..c3d9fc6ebdc34ce5825a0f1aca61669d3f551dfc 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 c30340bda3795a4bffe6b5790a9f19270e74e178..1d83fc6d07b855ded9d13321853a17591834f725 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 ce32cb9f6b7bd971a5eab607970b3c021b123c70..6864f1e2bdd801ae238d962c6a5f1cec3ce0edd7 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 7981195c73d97c66926034828e477dd2ba70319d..0317e359af2cf0377760219b8f19379a31c42ad5 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 05e6fa76fdf04d4f4be211880c810df7db394566..a18152d84d04c04c6786f1fc71c05ca0f9a793ab 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 2ccc01dc302b3f1e1487b70034dcded5a28587ae..de2064145143274a52bc63ccca85f0db9b2a39bb 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 3864563b64a0bced7192e2c7beb289f911d8b205..8bd08467541c8fa73b09715656631bb79c827c34 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 43115b0c53e02396d7d2eace0a01209c23cf7045..e08be7ca062151f2568e55882d926d334c1eeb79 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 090a31b3d26c0fedde51c777905f7fe2e5ac833b..9c02660d5e21b1c856a709e26592f6a880354899 100644
--- a/src/kernel_services/ast_printing/cil_types_debug.ml
+++ b/src/kernel_services/ast_printing/cil_types_debug.ml
@@ -121,23 +121,31 @@ 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_node fmt node =
+ match node with
+ | TVoid -> Format.fprintf fmt "TVoid"
+ | TInt ikind -> Format.fprintf fmt "TInt(%a)" pp_ikind ikind
+ | TFloat fkind -> Format.fprintf fmt "TFloat(%a)" pp_fkind fkind
+ | TPtr typ -> Format.fprintf fmt "TPtr(%a)" pp_typ typ
+ | TArray (typ,exp_option) ->
+ Format.fprintf fmt "TArray(%a,%a)" pp_typ typ (pp_option pp_exp) exp_option
+ | TFun (typ,string_typ_attributes_tuple_list_option,bool) ->
+ Format.fprintf fmt "TFun(%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
+ | TNamed typeinfo -> Format.fprintf fmt "TNamed(%a)" pp_typeinfo typeinfo
+ | TComp compinfo -> Format.fprintf fmt "TComp(%a)" pp_compinfo compinfo
+ | TEnum enuminfo -> Format.fprintf fmt "TEnum(%a)" pp_enuminfo enuminfo
+ | TBuiltin_va_list -> Format.fprintf fmt "TBuiltin_va_list"
+
+and pp_typ fmt t =
+ Format.fprintf fmt
+ "{\
+ tnode=%a;\
+ tattr=%a;\
+ }"
+ pp_typ_node t.tnode
+ pp_attributes t.tattr
and pp_ikind fmt = function
| IBool -> Format.fprintf fmt "IBool"
diff --git a/src/kernel_services/ast_printing/cil_types_debug.mli b/src/kernel_services/ast_printing/cil_types_debug.mli
index d87fd2b5bf3b2ba4ee967939542f2e20aef6a624..b264ce3b370bd2df7eab1465103c96eb94caa098 100644
--- a/src/kernel_services/ast_printing/cil_types_debug.mli
+++ b/src/kernel_services/ast_printing/cil_types_debug.mli
@@ -71,6 +71,7 @@ val pp_from :
val pp_assigns : Format.formatter -> Cil_types.assigns -> unit
val pp_file : Format.formatter -> Cil_types.file -> unit
val pp_global : Format.formatter -> Cil_types.global -> unit
+val pp_typ_node : Cil_types.typ_node Pretty_utils.formatter
val pp_typ : Cil_types.typ Pretty_utils.formatter
val pp_ikind : Format.formatter -> Cil_types.ikind -> unit
val pp_fkind : Format.formatter -> Cil_types.fkind -> unit
diff --git a/src/kernel_services/ast_printing/printer_tag.ml b/src/kernel_services/ast_printing/printer_tag.ml
index bbc921bf6c4f182f57f26abbc96495519886b4db..5eec71c9923e33342b26297b28b044fd4a25d524 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 abbdd84292d421cfa08be986b197d126054b37cf..a95e0cb6e82c619b5e168bb6dcdf4a055acadfd6 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 2e84fc40db5d693a0333613f32970f72fd47dda4..936c056eb293fc02952a87fa9847a5504005db9d 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 a21e023dc8095ae14faab8ab917593c392827f6c..dd108a214f51bc233353413568ed964cba3577a5 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 b4482d7194f0b394d0ad4f741045da2dabe8dd46..afb9866d1960c716ea147ca1c4905d68906931c9 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 599e2c668e1cd4e3e64e18139a688ea8f690e346..dc33546920994bbc45115aa49b8c4bb9e8c65693 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 d12e5ddc27e37268c58667fb25095345ed2ec9d7..46eb4bc7103cf292cb802801b9ace9e439513ca4 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 019ba5281b355651fc34a1e369254b592f68b9c1..bb1b53f1429375be48604d5f45994119f85de5c4 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 58007d81a2fd8dd05f51ee963f73a24fe4dfb036..5a12d467ca27a51e867187b5b6480627b8685ecf 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 581b4d7c1189d2b6fb32d6a7a3615165d6afa945..30cbd6c15099a9ee5debb9f76ad41b2356a58c37 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 9b64f68a2031fb50b607f42e399b698394b71747..e3923f1ea0e3af068f9471cde004a5561420717f 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 b866e935d554d4d80774f8dc9cb8534fa733fcc4..c663a3524be9a06e90368079348babefd3c96916 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 0a33fbce649c1325fb284db5ff2e7a3499407fb9..8f8ec74a4f9c5c7865f8057adedae0db9d29c4cd 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 d68f15cafd55f41da0eda11c463462dfce068327..eef7a520d524f4f16ea7311949f04df57a6cd103 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 8005b366b9fff307baa68c35b39060284cfdde1d..1a025f318d76082bf5842574cbe034cd69ba93e3 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 2d8abd63a295b3f8db9c2230bdf5c48ec7e05b19..f75aef98facc4fdf163641521c73f6a4279cdc41 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 e5b91cea2bc751d01d55cb691ec6f13eca04d644..f201b14cc3e1730b50be0111e73a55f3ef934ffe 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 edc587dddaf6a765a36607abfca90fb555e65969..100ead5d7f99a78e3df5c8faaa36d7053fe28afe 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 54a546991adf290ff8bcd5a06f016ed5d538b065..64080502f661a7b8c58119e50fd43f6f658f39f2 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 2c4d8a9d1baf84ea9199ebff017a23c32e538595..97378735c23351bfd51470e7c7a63d760b9d6584 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 9e35a352c70e3989ddc33915055fb69e254cf950..12796a955dfb746d05160f1c2187e11a234673e8 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 6db03852872ec28223e70ab2e467ac903d490b18..f4431acdb60ecc7f41bef76eadd573b62f97f759 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 b2c342825aa6b1a3a4a2755e55c7e9f4248c192f..0c55dd68efc748223f985d48a6803a9781b7752e 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 07251dce3ea0406440c73b8958bdb1a8492a5510..f974f092d4163fe215fcbf3b5af8295921a2c7ed 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 0b2adcfabedd70e832e671518f5469cbee3b83a0..931bbfca26129046f8189d7f6172586e088ae7ac 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 91a4471f7a94ddb921ac4855b007f6fd8e57f642..bb2e20c82f3e9f7756330715304a05e7db5a0c16 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 1e8e5b441d4e154f6ab3d243daa76d086ac5d55a..f77d6eb7ef1703965536cde4ed27b414daca1abd 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 8edca172df0e1b219f60badcd7645897cb00d312..322db1406e8847ab12c39e894c5fa416b5412cfe 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 b759aac28e92839bddfb7758708ae6f276712f11..e7da173a1a407d76c9144b2a66807509d731ac71 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 52d63f153eece20497cd34011efdf2e0fa92f728..c9f3d079fecaa70e989acc52f319d5f89a27e3a1 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 14d257e34d2598d969686e0d181f3b6f982f3df5..fe3db88a6e6507783e41df4b74c6f765413078ec 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 7b3787937c8bd5217fd4c48fc05763b48d02a683..0b01e166cd5fd174a582ba077551247afeb8e9bd 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 7f1e8dd6f8e5b27a20fc6ffb2a6e08f2a9740f21..dffe5abcd2644425c7b7cb39106ec4c438c6ae35 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 0b75638b07a92db266a047e07015ce9328f6158a..990f467c1f90ee5a3220e66cf094ef7f48753fce 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 9f9d5db5004deb33eebe9731c7a8a1252e1be82d..c0495e3e33d9e3a469b2159a2dd47f3a56f85791 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 265ef30818f7ed968ece643feb2c46605e7938ff..8d4ede3b2607c18f5745a96581aeb697040695cc 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 1356c74d3abc623346e0945187579462a7e06229..b1b90732c184c731ea3fd45eb6cce999c2f0d943 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 a0dab61aace5c0a474eb4b0ca0e28e4c031ffcda..4d4cffbd85b94127c2603f524bd671ab38284caa 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 7bd76dbce010221a5a09d5099bd04b0524188a07..045f1809d337ae24225724fe9db2a5a87ca7a039 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 f4c94cb75ce9e736a6c41cfa58905afdd4b87748..04c8db3308425f280512d478a3cb7d8f82e508c0 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 ac14016554167b3712755f315fb44440dd587b47..5c275252bcedb192b6a7ad4f8769f0637593427a 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 13ab62cebb02f701cad12156d1b1f979b35fea84..371eab61f4c04c30389e054a7a486304cc6a9398 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 abd64d14c5422642d31f6119183598fc63504a71..39e08f7eb141fd9e8359fe58f08a0d2afdd0313a 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 7acfb5299ddaa1629aba8aa03c8d16eab18185c2..901308d3bf59ca9eb809f92ad290c1599983b228 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 1bc6796a452b9742abbc404759a4a1bded24f31c..a8f0b49948e873a63c52bb09c09e93f1947087e3 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 569ccc20e253a9741549e928f42d5a80fbfeaaa3..27ebb55e598b6f4cd438d438557eda2a6f936d51 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 ff29828ad1a4500e3527f0ce232d0ea24330654a..2c1cab948acf12d8d1dbbcc03d3a6c46da32d497 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 b066e1347a1988cc286922f4c2a147ba56de6f95..ef070f5b744a6e537e3fe3adb731ddc7977c883a 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 1674e8941bf11dcf1d4b41b5ba33594e1fe99145..44e51f9fda67c622c65001fb7cc117c0647f89d5 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 134bd50eee3075668c81c9c03a4ca6670417549f..3c8849e72a984b1cd24744c43f618caf99c77208 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 37f2c3a2477c91ac776af57347af7c83b280d58f..f3bfc216fb391b0f386d6091de88460a4b2bb95e 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 80c008f041307c9fdbf23cc75ca7c0fcd3b99202..f24515c5e8fd7172dcd1bb7b736ccc82e1c39e94 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 83aec8185f76a68874230e92c8cbdd19f9b9b49e..0a526a863a793dcc1df5b9a1cd6a004bf64f377a 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 ad113ab9870f4c473d07355daf09cecf65cb6069..20053ab038cc4806cc9d452d6c192e16aa0ad6c4 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 7b5974c8778d4f37c17f76679a0fe0a3b4da515e..a14775fd2c459e2731aa930105f4dd85dd14d162 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 41ac838c7e3b363c6a03e35d5b78ffa51cc2f035..5bb2c6e93af22d235ebffe8a2012d93027a8720f 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 be834113d079fd2e1072ef33073edf3b67570276..c8824d7ede9dd08e20563c73a0e22bb903e437f9 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 deb6c2b4a9e180923005a69f3263228f881ba2b2..b1419f6673d73a33f8918ee2870564ffd1a124e1 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 0662cbfec4b55cbb3ffa3770598da274a3e9da03..ccef92af88f32b20c5d02d3ff6314a7845780575 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 8ec8dba455741efcceec85330e0f622410bcf327..0d2978f299d4cbe905f84ac953e129eb46eff5c7 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 92ccde4b0c8b2f1f1d6b41c9ebbddd6349391101..368c28eb9dfdf065467f9a74b177e0e2fbbca65e 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 b346feec54ea510979fd5469b3b473ddf594589f..4eb908e4a986b5a892a32ebd5b76fdb8902f9b12 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 7f0dcce69f2fef910506a4f121515b79530c3d81..2ce48afb2dcd2688208de9119f8dff62b7a36ea6 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 0687f585da8fbdfe65660016f75604b80e8193e0..caee80f840ff2f2a6fa287c7066d9768b4a577aa 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 3d51abbdecfe585bc31a3fcdb06fb0115dc13ed8..e8aa12a9d7719ccc23e29912b87898001df46359 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 37469f52eb31c2b763583a1d8a7b796790b062c4..31ee16fefa282b22b2c226ab28c0dae644a47657 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 c661e6c5a7719e90919634cc3fff9cd9f94eef7c..6fd966e40572351f13b8b28416ac841ebc5864d3 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 e354b406fc16386909dc800c7584bf680fe4fdd0..a079ebbdf59e895ea277cb216022c9a874939723 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 ba9a0150b35fac36d7a87e86fbaef98358f1e2f5..43f30ed3b568e9572df493b458d7136a55cb8f17 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 a2ca78a5b407832479f225467b45ade789e294ef..20701ba5b49dd5b4af4bcbe8610657bf3c0cb2b8 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 1cc53588178d9592d24c62a473009653a9c8d9eb..55502e2051375d33cd828385362e6b774329cf3d 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 4a99475717bda12410618b941a6b4419b4b73af5..f9d99c706acd0c471b723aee56abaa97ff535644 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 39fe40e2c3e148419db253bcdd6a2fa301990a7b..365e2e691873476f9199b3f8eec38bfc716159dc 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 fd0df1b47eed8932b46d60755893b8e9ff4a5503..a0ba4f10c7ca008e3408d3f57587e707472ef647 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 47e349f458a104c6f3ad5631a2eb7e1092f4f3f1..6949114eb455d6ebe1bd327fb3af542236fae6e8 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 0eb6e04e6d1a4eaec8bb2513c4cc2f62a0c74562..5a40e30f6f34d914a4d5ba5b158707838377aa5f 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 44e344b820908f215e146305f9b7419fe02d0104..27875c7e2d1d29413d4236c6ca807c6dbb54a1b5 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 7a28c57b5d268fe43f512ea91efebaebda54d825..8255334d6f28f25985a2e877a5e1f49e438fb09f 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 6c57062e951604f9b3a7bebaa83bf1f423c4d34d..5cffa507eecb59cfecc29be032cda86bceb153af 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 bdee5edfaf9fad41bc9a63f0c1b53bcf3522f0e8..bbd914487d6279d637bacbf888dea91e7e86005a 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 e755f0f0b687a8f6e4755c345cdcbe5592919cb9..e06a0be1e0ff522423e64acdcd38f6e0b5ee4e60 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 b0aff13021a595b877e37f1495c7ec403ceff498..981053791a64c7baf05c683628a4cb708a694cf1 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 bf81280015d53ea033327734a392b527c0b6274a..92b9b06f02e256821ec579a22d990b5c64706c38 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 529fd4736a900edff076796f39ef53f4a158705a..176ff0baaf3880912e3c02276db269e9efcd595a 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 e313365065ffd211949cd3d9c5b25bf250fb3e6b..5184762db4e85b4ba9f0428318b0b00254381b97 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 82a11656347fafa2dc9dddffff2e1e4c6c2b0334..41fc657fb582a021e9d4d34345b46573b996b7f6 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 672aeaae09421288c3049e017840d073803d9660..8a7ee1599e49963c02dbe59ad14443a1539cb800 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 a62799670f0ab7ae693ddc69a84116ff26a912c1..43c58ca04dc6d9f3e610cdbe07664957ce5862bf 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 59794ff614fc4fadc84329ae107f92792aa8b7d5..edd9b881c363e3b2458d10e43adeed6625041721 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 4d7caf142942d76167694562ea07fc1039df1946..41474dd6370924cc5d79422c3925fa3e74b1b032 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 616517ccb7d1bff3ea90a55ac1b32352ab034fcc..3a9c0d5965f8e17857cbd82013dcf978032e429b 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 b859d2af9a56dda9d4fe9319e39d3dd5874290f4..c42c870b3c353398cbce4c5e5ad5c4b08787d29c 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 c3e3432a82c917472db924c5682d35922e7f8c7d..75fa3a428c493ccc3259c5087ffe046176fd3560 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 96cb9328bce12dfc285489ce4101872819575429..7f1f5ebadbadca660b159952c48e4b0903030620 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 f882605cef3bb3049af3507703e9a81f487d7406..bdbe33ee2f0280923b4b51a71389e23b7cf87f5d 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 534f77821cb424d9d1124e7896904420ea4c98b4..10ef406262b2cad6dea17fd0317fbbd55447e096 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 0c6e4489e06d317a331956c03936224184d44704..05ebda8081878403552480e4aa38f2dc12a5f1cf 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 713b45a5bac28bd85eeee1c82417c838fd15439a..015323635f50671e6601665fceccefeea2997693 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 157db28623cbda796fa368d17569e625d1324205..572cff58e02ab649adb832615a9a5679f510205a 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 b0739c2a8e89d3227f34ac59ec39797eb2e5bbc5..d260e9f5205c2d8d8fa9bca7c22d7c793e2aed80 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 9374f9b68051fcc905a85d264baf59b9524a301d..a26ad3bff8a19ed1f27ef23cc8ab7e8617332ef5 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 3836fc2ea6c738f26fcda00d61b8a72e31d25282..4f04ccbc54bc2823e6c9e5b3f3f2d457067da524 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 fb9ae80dbfa90b4e1327c0d137a937778acdb406..85610c5c23bea1c5bc498912e8badf22e7c932a7 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 75532cb5cc036f625d9c6266dcf877e7cc4db41f..54c073df550a8885c93ad6a7cecd5e8d9bb853cf 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 2b446c01ed242ae670b2348ccb9361e77d1f99cf..5fe48496b1372102f4571cc47ad6a4d776d4273e 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 2b845df242de9f06f3ebaeb3efc65684db506ed7..37ad5aa1404d5e539e11111bdd66cfffdc284911 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 33b2e8b20627764eb8c673bfa2d2af1f1b3cb9d9..bb52dce9cb8a2912bae3946f6c9053484d8b5c92 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 dedfa27094809c589734f317adeaa5e3373117f8..2b49623b5aa60db8a767828c57f04b546a03a901 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 592cdcff055f1be04cf257b4d6ed8b24732f55fa..69267cfe9d93d678adab1592b62f074151436fd1 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 cf5c7f43bc8b471cbba342d067d40f7513d170b1..ede962c78c94188f8311b86d4e220eb54d28edf5 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 7425baceb102adc967cb876f4412bd4e37d378cb..4c2ef890df65265a17ba247b36fff04aee199571 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 14007c92901a8ab214e48d4d892710dcab4a1d18..08200dd47b7b370498f7a94cd118a3ce0fe15ff4 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 b51c72c389c166a0223d8567697300765053ead9..0496a6436a04c14d101e37663f0531fdfdfb0085 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 2dc4d78d107c837918b7a512094bfcf0eb9eb9aa..dbafcf1432dd76c9e24c257c69d565ea4cf4ff96 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 bd5012d9745f26cd4f1ae3531101385f0fb6a1c6..d44f27b0c964b32a8eb962a8ef5133ed97b8754f 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 ac5e5a73fd0e674fba9d2a298ba6bfe8810d1774..700340628f7687ba29c1c618e8dea763af547db8 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 d1cb4eb58dad99eb08108ff101e45d048ef36855..b0910d07888573c343db91b9998557052bf37e35 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 b6362e509d6cdbe4c2a235f50dfba55747f42085..366346589ef3c41f19dde7217a85292b010a0482 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 79bf4715fdecb6f96fb2b4a91a80c5238496d3d5..8275326feae8d02a0aa4ee698b672d9c0df47ce0 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 4fd188fb4532146efb1cc83e0b0dbdaffbbcba33..a424bd02ca25450ccf4053c43ef6775d0b887dd7 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 8e59f646a944c1c3a4464672beced4ff5349350b..a2bff2a9a94dbe7a6aca40139fe1fce83d675c4d 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 4c9ed2c6c31713e0cfac3ab0090e13c5c5815f94..6420d48b97796c6706e73e1e1c65e3d053b31728 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 7ece88634f085734c53e16ef24f9843a72f2c333..3332bb449850b5c9e9ee90b3a4c5b108d5c5df6f 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 d9c6c4dfae38297193968bee5a669a3139bcb209..7ab82f4ebd989bb827f5823a848ebe0904dc7457 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 6cde00d6b77403522c495807ceff448292603451..722d5d1aa63edbcf5fdf9d5e349ceb0388c549db 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 =