let type_expr env ?tr ?current e =
let loc = Cil_datatype.Location.unknown in
let rec aux env cond e =
match e with
PVar s ->
let var = find_in_env env current s in
env, var, cond
| PPrm(f,x) -> find_prm_in_env env ?tr current f x
| PCst (Logic_ptree.IntConstant s) ->
let e =
match (Cil.parseInt ~loc s).enode with
| Const (CInt64 _ as c) -> TConst c
| Const (CChr _ as c) -> TConst c
| _ -> assert false
in
env, Logic_const.term e Linteger, cond
| PCst (Logic_ptree.FloatConstant str) ->
let e,t =
let hasSuffix str =
let l = String.length str in
fun s ->
let ls = String.length s in
l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
in
let l = String.length str in
let hasSuffix = hasSuffix str in
let baseint, kind =
if hasSuffix "L" or hasSuffix "l" then
String.sub str 0 (l - 1), FLongDouble
else if hasSuffix "F" or hasSuffix "f" then
String.sub str 0 (l - 1), FFloat
else if hasSuffix "D" or hasSuffix "d" then
String.sub str 0 (l - 1), FDouble
else
str, FDouble
in
begin
try
TConst(CReal(float_of_string baseint, kind, Some str)),
Lreal
with Failure _ as e ->
Aorai_option.abort ~current:true
"float_of_string %s (%s)" str (Printexc.to_string e)
end
in env,Logic_const.term e t,cond
| PCst (Logic_ptree.StringConstant s) ->
let t =
Logic_const.term
(TConst(CStr (Logic_typing.unescape s))) (Ctype Cil.charPtrType)
in
env,t,cond
| PCst (Logic_ptree.WStringConstant s) ->
let t =
Logic_const.term
(TConst (CWStr (Logic_typing.wcharlist_of_string s)))
(Ctype (TPtr(Cil.theMachine.wcharType,[])))
in env,t,cond
| PBinop(bop,e1,e2) ->
let op = Logic_typing.type_binop bop in
let env,e1,cond = aux env cond e1 in
let env,e2,cond = aux env cond e2 in
let t1 = e1.term_type in
let t2 = e2.term_type in
let t =
if Logic_typing.is_arithmetic_type t1
&& Logic_typing.is_arithmetic_type t2
then
let t = Logic_typing.arithmetic_conversion t1 t2 in
Logic_const.term
(TBinOp (op,LTyping.mk_cast e1 t,LTyping.mk_cast e2 t))
t
else
(match bop with
| Logic_ptree.Badd
when
Logic_typing.is_integral_type t2
&& Logic_utils.isLogicPointerType t1 ->
Logic_const.term (TBinOp (PlusPI,e1,e2)) t1
| Logic_ptree.Bsub
when
Logic_typing.is_integral_type t2
&& Logic_utils.isLogicPointerType t1 ->
Logic_const.term (TBinOp (MinusPI,e1,e2)) t1
| Logic_ptree.Badd
when
Logic_typing.is_integral_type t1
&& Logic_utils.isLogicPointerType t2 ->
Logic_const.term (TBinOp (PlusPI,e2,e1)) t2
| Logic_ptree.Bsub
when
Logic_typing.is_integral_type t1
&& Logic_utils.isLogicPointerType t2 ->
Logic_const.term (TBinOp (MinusPI,e2,e1)) t2
| Logic_ptree.Bsub
when
Logic_utils.isLogicPointerType t1
&& Logic_utils.isLogicPointerType t2 ->
Logic_const.term
(TBinOp (MinusPP,e1,LTyping.mk_cast e2 t1))
Linteger
| _ ->
Aorai_option.abort
"Invalid operands for binary operator %a: unexpected %a and %a"
!Ast_printer.d_binop op
!Ast_printer.d_term e1
!Ast_printer.d_term e2)
in
env, t, cond
| PUnop(Logic_ptree.Uminus,e) ->
let env,t,cond = aux env cond e in
if Logic_typing.is_arithmetic_type t.term_type then
env,Logic_const.term (TUnOp (Neg,t)) Linteger,cond
else Aorai_option.abort
"Invalid operand for unary -: unexpected %a" !Ast_printer.d_term t
| PUnop(Logic_ptree.Ubw_not,e) ->
let env,t,cond = aux env cond e in
if Logic_typing.is_arithmetic_type t.term_type then
env,Logic_const.term (TUnOp (BNot,t)) Linteger,cond
else Aorai_option.abort
"Invalid operand for bitwise not: unexpected %a" !Ast_printer.d_term t
| PUnop(Logic_ptree.Uamp,e) ->
let env, t, cond = aux env cond e in
let ptr =
try Ctype (TPtr (Logic_utils.logicCType t.term_type,[]))
with Failure _ ->
Aorai_option.abort "Cannot take address: not a C type(%a): %a"
!Ast_printer.d_logic_type t.term_type !Ast_printer.d_term t
in
(match t.term_node with
| TLval v | TStartOf v -> env, Logic_const.taddrof v ptr, cond
| _ ->
Aorai_option.abort "Cannot take address: not an lvalue %a"
!Ast_printer.d_term t
)
| PUnop (Logic_ptree.Ustar,e) ->
let env, t, cond = aux env cond e in
if Logic_utils.isLogicPointerType t.term_type then
env,
Logic_const.term
(TLval (TMem t, TNoOffset))
(Logic_typing.type_of_pointed t.term_type),
cond
else
Aorai_option.abort "Cannot dereference term %a" !Ast_printer.d_term t
| PArrget(e1,e2) ->
let env, t1, cond = aux env cond e1 in
let env, t2, cond = aux env cond e2 in
let t =
if Logic_utils.isLogicPointerType t1.term_type
&& Logic_typing.is_integral_type t2.term_type
then
Logic_const.term
(TBinOp (IndexPI,t1,t2))
(Logic_typing.type_of_pointed t1.term_type)
else if Logic_utils.isLogicPointerType t2.term_type
&& Logic_typing.is_integral_type t1.term_type
then
Logic_const.term
(TBinOp (IndexPI,t2,t1))
(Logic_typing.type_of_pointed t2.term_type)
else if Logic_utils.isLogicArrayType t1.term_type
&& Logic_typing.is_integral_type t2.term_type
then
(match t1.term_node with
| TStartOf lv | TLval lv ->
Logic_const.term
(TLval
(Logic_typing.add_offset_lval (TIndex (t2, TNoOffset)) lv))
(Logic_typing.type_of_array_elem t1.term_type)
| _ ->
Aorai_option.fatal
"Unsupported operation: %a[%a]"
!Ast_printer.d_term t1 !Ast_printer.d_term t2)
else if Logic_utils.isLogicArrayType t2.term_type
&& Logic_typing.is_integral_type t1.term_type
then
(match t2.term_node with
| TStartOf lv | TLval lv ->
Logic_const.term
(TLval
(Logic_typing.add_offset_lval (TIndex (t1, TNoOffset)) lv))
(Logic_typing.type_of_array_elem t2.term_type)
| _ ->
Aorai_option.fatal
"Unsupported operation: %a[%a]"
!Ast_printer.d_term t1 !Ast_printer.d_term t2)
else
Aorai_option.abort
"Subscripted value is neither array nor pointer: %a[%a]"
!Ast_printer.d_term t1 !Ast_printer.d_term t2
in
env, t, cond
| PField(e,s) ->
let env, t, cond = aux env cond e in
(match t.term_node with
| TLval lv ->
let off, ty = LTyping.type_of_field loc s t.term_type in
let lv = Logic_typing.add_offset_lval off lv in
env, Logic_const.term (TLval lv) ty, cond
| _ ->
Aorai_option.fatal
"Unsupported operation: %a.%s" !Ast_printer.d_term t s)
| PArrow(e,s) ->
let env, t, cond = aux env cond e in
if Logic_utils.isLogicPointerType t.term_type then begin
let off, ty =
LTyping.type_of_field loc s
(Logic_typing.type_of_pointed t.term_type)
in
let lv = Logic_typing.add_offset_lval off (TMem t,TNoOffset) in
env, Logic_const.term (TLval lv) ty, cond
end else
Aorai_option.abort "base term is not a pointer in %a -> %s"
!Ast_printer.d_term t s
in
aux env TTrue e