let rec coerce_floats t =
match !float_model with
| `Real -> terms t
| `Strict | `Full | `Multirounding ->
if isLogicFloatType t.term_type then
List.map
(fun e ->
mkexpr (JCPEcast(e, mktype (JCPTnative Treal))) t.term_loc)
(terms t)
else terms t
and terms t =
CurrentLoc.set t.term_loc;
let enode = match constFoldTermNodeAtTop t.term_node with
| TConst c -> [const ~in_code:false t.term_loc c]
| TDataCons({ctor_type = {lt_name = "boolean"}} as d,_args) ->
[JCPEconst (JCCboolean (d.ctor_name = "\\true"))]
| TDataCons(ctor,args) ->
let args = List.map terms args in
let args =
List.fold_right (product (fun x y -> x::y)) args [[]]
in
List.map (fun x -> JCPEapp(ctor.ctor_name,[],x)) args
| TUpdate _ ->
Extlib.not_yet_implemented "Interp.terms TUpdate"
| TLval lv ->
List.map (fun x -> x#node) (terms_lval t.term_loc lv)
| TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ ->
assert false
| TUnOp(op,t) ->
List.map (fun x -> JCPEunary(unop op,x)) (coerce_floats t)
| TBinOp((Lt | Gt | Le | Ge as op),t1,t2)
when app_term_type isPointerType false t1.term_type ->
let t1 = terms t1 in
let t2 = terms t2 in
let expr x y =
let sube = mkexpr (JCPEbinary(x,`Bsub,y)) t.term_loc in
JCPEbinary(sube,binop op,zero_expr)
in product expr t1 t2
| TBinOp(Shiftrt,t1,t2) ->
begin match possible_value_of_integral_term t2 with
| Some i when i >= 0L && i < 63L ->
let pow = constant_term t2.term_loc (power_of_two i) in
List.map (fun x ->JCPEbinary(x,`Bdiv,term pow)) (terms t1)
| _ ->
let op = match t1.term_type with
| Ctype ty1 ->
if isSignedInteger ty1 then `Barith_shift_right
else `Blogical_shift_right
| Linteger -> `Barith_shift_right
| _ -> assert false
in
product (fun x y -> JCPEbinary(x,op,y)) (terms t1) (terms t2)
end
| TBinOp(Shiftlt as op,t1,t2) ->
begin match possible_value_of_integral_term t2 with
| Some i when i >= 0L && i < 63L ->
let pow = constant_term t2.term_loc (power_of_two i) in
List.map (fun x -> JCPEbinary(x,`Bmul,term pow)) (terms t1)
| _ ->
product (fun x y -> JCPEbinary(x,binop op,y))
(terms t1) (terms t2)
end
| TBinOp((Lt | Gt | Le | Ge) as op,t1,t2) ->
product (fun x y -> JCPEbinary(x,binop op,y)) (terms t1) (terms t2)
| TBinOp(op,t1,t2) ->
product
(fun x y -> JCPEbinary(x,binop op,y))
(coerce_floats t1)
(coerce_floats t2)
| TCastE(ty,t)
when isIntegralType ty && isLogicArithmeticType t.term_type ->
if Jessie_options.IntModel.get_val () = Jessie_options.IMexact then
List.map (fun x -> x#node) (terms t)
else
List.map (fun x -> JCPEcast(x,ctype ty)) (terms t)
| TCastE(ty,t)
when isFloatingType ty && isLogicArithmeticType t.term_type ->
List.map (fun x -> JCPEcast(x,ctype ty)) (terms t)
| TCastE(ty,t)
when isIntegralType ty && app_term_type isPointerType false t.term_type ->
unsupported "Casting from type %a to type %a not allowed"
!Ast_printer.d_logic_type t.term_type !Ast_printer.d_type ty
| TCastE(ptrty,_t1) when isPointerType ptrty ->
let t = stripTermCasts t in
begin match t.term_node with
| Tnull ->
[JCPEconst JCCnull]
| TConst c
when is_integral_const c && value_of_integral_const c = Int64.zero ->
[JCPEconst JCCnull]
| _ ->
unsupported "Casting from type %a to type %a not allowed in logic"
!Ast_printer.d_logic_type t.term_type !Ast_printer.d_type ptrty
end
| TCastE(ty,t) ->
notimplemented "Casting from type %a to type %a not allowed"
!Ast_printer.d_logic_type t.term_type !Ast_printer.d_type ty
| TAddrOf _tlv -> assert false
| TStartOf tlv ->
List.map (fun x -> x#node) (terms_lval t.term_loc tlv)
| Tapp(linfo,labels,tlist) ->
let name = translated_name linfo in
let args =
List.map2
(fun lv t ->
let t' = terms t in
if isLogicFloatType t.term_type && isLogicRealType lv.lv_type
then
List.map
(fun t' ->
mkexpr (JCPEcast(t', mktype (JCPTnative Treal))) t.term_loc)
t'
else t')
linfo.l_profile
tlist
in
let all_args = List.fold_right (product (fun x y -> x::y)) args [[]] in
List.map
(fun x -> JCPEapp(name,logic_labels_assoc labels,x)) all_args
| Tif(t1,t2,t3) ->
let t1 = terms t1 in let t2 = terms t2 in let t3 = terms t3 in
product (fun f x -> f x)
(product (fun x y z -> JCPEif(x,y,z)) t1 t2) t3
| Told t -> List.map (fun x -> JCPEold x) (terms t)
| Tat(t,lab) -> List.map (fun x -> JCPEat(x,logic_label lab)) (terms t)
| Tbase_addr t -> List.map (fun x -> JCPEbase_block x) (terms t)
| Tblock_length _t ->
Extlib.not_yet_implemented "Interp.terms Tblock_length"
| Tnull -> [JCPEconst JCCnull]
| TCoerce(_t,_typ) ->
Extlib.not_yet_implemented "Interp.terms TCoerce"
| TCoerceE(_t1,_t2) ->
Extlib.not_yet_implemented "Interp.terms TCoerceE"
| Tlambda _ ->
unsupported "Jessie plugin does not support lambda abstraction"
| Ttypeof _ | Ttype _ -> assert false
| Trange(low,high) -> [JCPErange(opt_map term low,opt_map term high)]
| Tunion l ->
List.map (fun x -> x#node) (List.flatten (List.map terms l))
| Tcomprehension _ -> assert false
| Tinter _ -> assert false
| Tempty_set -> []
in
List.map (swap mkexpr t.term_loc) enode
and tag t =
let tag_node = match t.term_node with
| Ttypeof t -> JCPTtypeof (term t)
| Ttype ty ->
let id = mkidentifier (get_struct_name (pointed_type ty)) t.term_loc in
JCPTtag id
| _ -> assert false
in
mktag tag_node t.term_loc
and terms_lval pos lv =
match lv with
| lhost, TNoOffset -> [term_lhost pos lhost]
| (TVar _ | TResult _), _off ->
assert false
| TMem t, TField(fi,toff) ->
assert (toff = TNoOffset);
let e = terms t in
if not fi.fcomp.cstruct then
List.map (fun e -> mkexpr (JCPEcast(e,ctype fi.ftype)) pos) e
else
let repfi = Retype.FieldUnion.repr fi in
let e,fi =
if FieldinfoComparable.equal fi repfi then
e,fi
else
let caste =
List.map
(fun e ->
mkexpr (
JCPEcast(e,
ctype (TPtr(TComp(repfi.fcomp,empty_size_cache (),[]),[])))) pos)
e
in
caste,repfi
in
List.map (fun e -> mkexpr (JCPEderef(e,fi.fname)) pos) e
| TMem t, TIndex(it,TField(fi,toff)) ->
assert (toff = TNoOffset);
let e = product
(fun t it -> mkexpr (JCPEbinary(t,`Badd,it)) pos)
(terms t) (terms it)
in
if not fi.fcomp.cstruct then
List.map (fun e -> mkexpr (JCPEcast(e,ctype fi.ftype)) pos) e
else
let repfi = Retype.FieldUnion.repr fi in
let e,fi =
if FieldinfoComparable.equal fi repfi then
e,fi
else
let caste =
List.map
(fun e ->
mkexpr
(JCPEcast(e,ctype
(TPtr(TComp(repfi.fcomp,empty_size_cache (),[]),[])))) pos)
e
in
caste,repfi
in
List.map (fun e -> mkexpr (JCPEderef(e,fi.fname)) pos) e
| TMem _e, TIndex _ ->
assert false
and term t =
match terms t with [ t ] -> t
| _ ->
unsupported "Expecting a single term, not a set:@ %a@."
!Ast_printer.d_term t
and term_lval pos lv =
match terms_lval pos lv with [ lv ] -> lv
| _ ->
unsupported "Expecting a single lval, not a set:@ %a@."
!Ast_printer.d_term_lval lv