@ -134,7 +134,11 @@ let eval location exp0 astate =
| Const ( Cint i ) ->
| Const ( Cint i ) ->
(* TODO: make identical const the same address *)
(* TODO: make identical const the same address *)
let addr = AbstractValue . mk_fresh () in
let addr = AbstractValue . mk_fresh () in
let astate = Memory . add_attribute addr ( Arithmetic ( Arithmetic . equal_to i ) ) astate in
let astate =
Memory . add_attribute addr
( Arithmetic ( Arithmetic . equal_to i , Immediate { location ; history = [] } ) )
astate
in
Ok ( astate , ( addr , [] ) )
Ok ( astate , ( addr , [] ) )
| Const _ | Sizeof _ | UnOp _ | BinOp _ | Exn _ ->
| Const _ | Sizeof _ | UnOp _ | BinOp _ | Exn _ ->
Ok ( astate , ( AbstractValue . mk_fresh () , (* TODO history *) [] ) )
Ok ( astate , ( AbstractValue . mk_fresh () , (* TODO history *) [] ) )
@ -145,7 +149,12 @@ let eval location exp0 astate =
let eval_arith location exp astate =
let eval_arith location exp astate =
match ( exp : Exp . t ) with
match ( exp : Exp . t ) with
| Const ( Cint i ) ->
| Const ( Cint i ) ->
Ok ( astate , None , Some ( Arithmetic . equal_to i ) )
Ok
( astate
, None
, Some
( Arithmetic . equal_to i
, Trace . Immediate { location ; history = [ ValueHistory . Assignment location ] } ) )
| exp -> (
| exp -> (
eval location exp astate
eval location exp astate
> > | fun ( astate , ( addr , _ ) ) ->
> > | fun ( astate , ( addr , _ ) ) ->
@ -156,36 +165,51 @@ let eval_arith location exp astate =
( astate , Some addr , None ) )
( astate , Some addr , None ) )
let record_abduced addr _opt arith_opt astate =
let record_abduced ~ is_then_branch if_kind location addr _opt orig_arith_hist _opt arith_opt astate =
match Option . both addr_opt arith_opt with
match Option . both addr_opt arith_opt with
| None ->
| None ->
astate
astate
| Some ( addr , arith ) ->
| Some ( addr , arith ) ->
let attribute = Attribute . Arithmetic arith in
let event = ValueHistory . Conditional { is_then_branch ; if_kind ; location } in
let trace =
match orig_arith_hist_opt with
| None ->
Trace . Immediate { location ; history = [ event ] }
| Some ( _ , trace ) ->
Trace . add_event event trace
in
let attribute = Attribute . Arithmetic ( arith , trace ) in
Memory . abduce_attribute addr attribute astate | > Memory . add_attribute addr attribute
Memory . abduce_attribute addr attribute astate | > Memory . add_attribute addr attribute
let rec eval_cond ~ negated location exp astate =
let prune ~ is_then_branch if_kind location ~ condition astate =
match ( exp : Exp . t ) with
let rec prune_aux ~ negated exp astate =
| BinOp ( bop , e1 , e2 ) -> (
match ( exp : Exp . t ) with
eval_arith location e1 astate
| BinOp ( bop , e1 , e2 ) -> (
> > = fun ( astate , addr1 , eval1 ) ->
eval_arith location e1 astate
eval_arith location e2 astate
> > = fun ( astate , addr1 , eval1 ) ->
> > | fun ( astate , addr2 , eval2 ) ->
eval_arith location e2 astate
match Arithmetic . abduce_binop_is_true ~ negated bop eval1 eval2 with
> > | fun ( astate , addr2 , eval2 ) ->
| Unsatisfiable ->
match
( astate , false )
Arithmetic . abduce_binop_is_true ~ negated bop ( Option . map ~ f : fst eval1 )
| Satisfiable ( abduced1 , abduced2 ) ->
( Option . map ~ f : fst eval2 )
let astate = record_abduced addr1 abduced1 astate | > record_abduced addr2 abduced2 in
with
( astate , true ) )
| Unsatisfiable ->
| UnOp ( LNot , exp' , _ ) ->
( astate , false )
eval_cond ~ negated : ( not negated ) location exp' astate
| Satisfiable ( abduced1 , abduced2 ) ->
| exp ->
let astate =
let zero = Exp . Const ( Cint IntLit . zero ) in
record_abduced ~ is_then_branch if_kind location addr1 eval1 abduced1 astate
eval_cond ~ negated location ( Exp . BinOp ( Ne , exp , zero ) ) astate
| > record_abduced ~ is_then_branch if_kind location addr2 eval2 abduced2
in
( astate , true ) )
let assert_is_true location ~ condition astate = eval_cond ~ negated : false location condition astate
| UnOp ( LNot , exp' , _ ) ->
prune_aux ~ negated : ( not negated ) exp' astate
| exp ->
let zero = Exp . Const ( Cint IntLit . zero ) in
prune_aux ~ negated ( Exp . BinOp ( Ne , exp , zero ) ) astate
in
prune_aux ~ negated : false condition astate
let eval_deref location exp astate =
let eval_deref location exp astate =
eval location exp astate
eval location exp astate