rpms/why
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
why/why-frama-c.patch

757 lines
31 KiB
Diff
Raw Blame History

--- frama-c-plugin/common.ml.orig 2018-06-28 16:43:25.000000000 -0600
+++ frama-c-plugin/common.ml 2019-06-03 09:39:40.876316289 -0600
@@ -56,8 +56,9 @@ let fatal fmt = Jessie_options.fatal ~cu
let unsupported fmt =
Jessie_options.with_failure
- (fun evt ->
- raise (Unsupported evt.Log.evt_message)
+ (function
+ | (Some evt) -> raise (Unsupported evt.Log.evt_message)
+ | None -> raise (Unsupported "No message")
) ~current:true fmt
let warning fmt = Jessie_options.warning ~current:true fmt
--- frama-c-plugin/common.mli.orig 2018-06-28 16:43:25.000000000 -0600
+++ frama-c-plugin/common.mli 2019-06-03 09:38:56.727035437 -0600
@@ -102,7 +102,7 @@ val term_of_var : Cil_types.varinfo -> C
val mkterm :
Cil_types.term_node ->
Cil_types.logic_type ->
- Lexing.position * Lexing.position -> Cil_types.term
+ Filepath.position * Filepath.position -> Cil_types.term
val mkInfo : Cil_types.exp -> Cil_types.exp
--- frama-c-plugin/interp.ml.orig 2018-06-28 16:43:25.000000000 -0600
+++ frama-c-plugin/interp.ml 2019-06-03 11:55:36.722081449 -0600
@@ -702,14 +702,14 @@ let rec coerce_floats t =
if isLogicFloatType t.term_type then
List.map
(fun e ->
- mkexpr (JCPEcast(e, mktype (JCPTnative Treal))) t.term_loc)
+ mkexpr (JCPEcast(e, mktype (JCPTnative Treal))) (Location.to_lexing_loc 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 -> [logic_const t.term_loc c]
+ | TConst c -> [logic_const (Location.to_lexing_loc t.term_loc) c]
| TDataCons({ctor_type = {lt_name = name} } as d,_args)
when name = Utf8_logic.boolean ->
@@ -727,7 +727,7 @@ and terms t =
| Toffset _ -> Common.unsupported "logic offset"
| TLval lv ->
- List.map (fun x -> x#node) (terms_lval t.term_loc lv)
+ List.map (fun x -> x#node) (terms_lval (Location.to_lexing_loc t.term_loc) lv)
| TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ ->
assert false (* Should be removed by constant folding *)
@@ -741,7 +741,7 @@ and terms t =
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
+ let sube = mkexpr (JCPEbinary(x,`Bsub,y)) (Location.to_lexing_loc t.term_loc) in
JCPEbinary(sube,binop op,zero_expr)
in product expr t1 t2
@@ -867,7 +867,7 @@ and terms t =
| TAddrOf _tlv -> assert false (* Should have been rewritten *)
| TStartOf tlv ->
- List.map (fun x -> x#node) (terms_lval t.term_loc tlv)
+ List.map (fun x -> x#node) (terms_lval (Location.to_lexing_loc t.term_loc) tlv)
| Tapp(linfo,labels,tlist) ->
begin
@@ -887,7 +887,7 @@ and terms t =
then
List.map
(fun t' ->
- mkexpr (JCPEcast(t', mktype (JCPTnative Treal))) t.term_loc)
+ mkexpr (JCPEcast(t', mktype (JCPTnative Treal))) (Location.to_lexing_loc t.term_loc))
t'
else t')
prof
@@ -950,17 +950,17 @@ and terms t =
| TLogic_coerce(_,t) -> List.map (fun x -> x#node) (terms t)
in
- List.map (swap mkexpr t.term_loc) enode
+ List.map (swap mkexpr (Location.to_lexing_loc 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
+ let id = mkidentifier (get_struct_name (pointed_type ty)) (Location.to_lexing_loc t.term_loc) in
JCPTtag id
| _ -> assert false (* Not a tag *)
in
- mktag tag_node t.term_loc
+ mktag tag_node (Location.to_lexing_loc t.term_loc)
and terms_lval pos lv =
match lv with
@@ -1042,6 +1042,7 @@ and term t =
*)
and pred p =
CurrentLoc.set p.pred_loc;
+ let ploc = Location.to_lexing_loc p.pred_loc in
let enode = match p.pred_content with
| Pfalse -> JCPEconst(JCCboolean false)
@@ -1060,7 +1061,7 @@ and pred p =
let t' = term t in
if isLogicFloatType t.term_type && isLogicRealType lv.lv_type
then
- mkexpr (JCPEcast(t', mktype (JCPTnative Treal))) t.term_loc
+ mkexpr (JCPEcast(t', mktype (JCPTnative Treal))) (Location.to_lexing_loc t.term_loc)
else t')
pinfo.l_profile
tl
@@ -1072,7 +1073,7 @@ and pred p =
| Prel((Rlt | Rgt | Rle | Rge as rel),t1,t2)
when app_term_type isPointerType false t1.term_type ->
(* Pointer comparison is translated as subtraction *)
- let sube = mkexpr (JCPEbinary(term t1,`Bsub,term t2)) p.pred_loc in
+ let sube = mkexpr (JCPEbinary(term t1,`Bsub,term t2)) ploc in
JCPEbinary(sube,relation rel,zero_expr)
(* | Prel((Req | Rneq as rel),t1,t2) *)
@@ -1087,14 +1088,14 @@ and pred p =
JCPEeqtype(tag t1,tag t2)
| Prel(Rneq,t1,t2) when isTypeTagType t1.term_type ->
- let eq = mkexpr (JCPEeqtype(tag t1,tag t2)) p.pred_loc in
+ let eq = mkexpr (JCPEeqtype(tag t1,tag t2)) ploc in
JCPEunary(`Unot,eq)
| Prel(rel,t1,t2) ->
let res =
- product (fun t1 t2 -> mkexpr (JCPEbinary(t1,relation rel,t2)) p.pred_loc)
+ product (fun t1 t2 -> mkexpr (JCPEbinary(t1,relation rel,t2)) ploc)
(coerce_floats t1) (coerce_floats t2)
- in (mkconjunct res p.pred_loc)#node
+ in (mkconjunct res ploc)#node
| Pand(p1,p2) ->
JCPEbinary(pred p1,`Bland,pred p2)
@@ -1170,21 +1171,21 @@ and pred p =
| None,None -> true_expr
| Some t2,None ->
let e2 = term t2 in
- let eoffmin = mkexpr (JCPEoffset(Offset_min,e1)) p.pred_loc in
- mkexpr (JCPEbinary(eoffmin,`Ble,e2)) p.pred_loc
+ let eoffmin = mkexpr (JCPEoffset(Offset_min,e1)) ploc in
+ mkexpr (JCPEbinary(eoffmin,`Ble,e2)) ploc
| None, Some t3 ->
let e3 = term t3 in
- let eoffmax = mkexpr (JCPEoffset(Offset_max,e1)) p.pred_loc in
- mkexpr (JCPEbinary(eoffmax,`Bge,e3)) p.pred_loc
+ let eoffmax = mkexpr (JCPEoffset(Offset_max,e1)) ploc in
+ mkexpr (JCPEbinary(eoffmax,`Bge,e3)) ploc
| Some t2,Some t3 ->
let e2 = term t2 in
let e3 = term t3 in
- let eoffmin = mkexpr (JCPEoffset(Offset_min,e1)) p.pred_loc in
- let emin = mkexpr (JCPEbinary(eoffmin,`Ble,e2)) p.pred_loc in
- let eoffmax = mkexpr (JCPEoffset(Offset_max,e1)) p.pred_loc in
- let emax = mkexpr (JCPEbinary(eoffmax,`Bge,e3)) p.pred_loc in
- mkconjunct [emin; emax] p.pred_loc
- in (mkconjunct (List.map mk_one_pred e1) p.pred_loc)#node
+ let eoffmin = mkexpr (JCPEoffset(Offset_min,e1)) ploc in
+ let emin = mkexpr (JCPEbinary(eoffmin,`Ble,e2)) ploc in
+ let eoffmax = mkexpr (JCPEoffset(Offset_max,e1)) ploc in
+ let emax = mkexpr (JCPEbinary(eoffmax,`Bge,e3)) ploc in
+ mkconjunct [emin; emax] ploc
+ in (mkconjunct (List.map mk_one_pred e1) ploc)#node
| Pvalid(_lab,{ term_node = TBinOp(PlusPI,t1,t2)}) ->
let e1 = terms t1 in
@@ -1193,23 +1194,23 @@ and pred p =
(List.flatten
(List.map
(fun e1 ->
- let eoffmin = mkexpr (JCPEoffset(Offset_min,e1)) p.pred_loc in
- let emin = mkexpr (JCPEbinary(eoffmin,`Ble,e2)) p.pred_loc in
- let eoffmax = mkexpr (JCPEoffset(Offset_max,e1)) p.pred_loc in
- let emax = mkexpr (JCPEbinary(eoffmax,`Bge,e2)) p.pred_loc in
+ let eoffmin = mkexpr (JCPEoffset(Offset_min,e1)) ploc in
+ let emin = mkexpr (JCPEbinary(eoffmin,`Ble,e2)) ploc in
+ let eoffmax = mkexpr (JCPEoffset(Offset_max,e1)) ploc in
+ let emax = mkexpr (JCPEbinary(eoffmax,`Bge,e2)) ploc in
[emin; emax])
- e1)) p.pred_loc)#node
+ e1)) ploc)#node
| Pvalid (_lab,t) ->
let elist =
List.flatten (List.map (fun e ->
- let eoffmin = mkexpr (JCPEoffset(Offset_min,e)) p.pred_loc in
- let emin = mkexpr (JCPEbinary(eoffmin,`Ble,zero_expr)) p.pred_loc in
- let eoffmax = mkexpr (JCPEoffset(Offset_max,e)) p.pred_loc in
- let emax = mkexpr (JCPEbinary(eoffmax,`Bge,zero_expr)) p.pred_loc in
+ let eoffmin = mkexpr (JCPEoffset(Offset_min,e)) ploc in
+ let emin = mkexpr (JCPEbinary(eoffmin,`Ble,zero_expr)) ploc in
+ let eoffmax = mkexpr (JCPEoffset(Offset_max,e)) ploc in
+ let emax = mkexpr (JCPEbinary(eoffmax,`Bge,zero_expr)) ploc in
[emin; emax]
) (terms t))
in
- (mkconjunct elist p.pred_loc)#node
+ (mkconjunct elist ploc)#node
| Pvalid_read _ -> Common.unsupported "\\valid_read operator"
@@ -1236,7 +1237,7 @@ and pred p =
| Pvalid_function _ -> Common.unsupported "\\valid_function"
in
- mkexpr enode p.pred_loc
+ mkexpr enode ploc
(* Keep names associated to predicate *)
let named_pred p =
@@ -1492,14 +1493,15 @@ let set_curFundec, get_curFundec =
let rec expr e =
+ let eloc = Location.to_lexing_loc e.eloc in
let enode =
let e = stripInfo e in
match e.enode with
| Info _ -> assert false
- | Const c -> const e.eloc c
+ | Const c -> const eloc c
- | Lval lv -> (lval e.eloc lv)#node
+ | Lval lv -> (lval eloc lv)#node
| SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ ->
assert false (* Should be removed by constant folding *)
@@ -1509,7 +1511,7 @@ let rec expr e =
| UnOp(op,e,_ty) ->
let e =
- locate (mkexpr (JCPEunary(unop op,expr e)) e.eloc)
+ locate (mkexpr (JCPEunary(unop op,expr e)) eloc)
in
e#node
@@ -1518,24 +1520,24 @@ let rec expr e =
| BinOp(op,e1,e2,_ty) ->
let e =
- locate (mkexpr (JCPEbinary(expr e1,binop op,expr e2)) e.eloc)
+ locate (mkexpr (JCPEbinary(expr e1,binop op,expr e2)) eloc)
in
e#node
| CastE(ty,e')
when isIntegralType ty && isFloatingType (typeOf e') ->
let e1 =
- locate (mkexpr (JCPEcast(expr e',mktype (JCPTnative Treal))) e.eloc)
+ locate (mkexpr (JCPEcast(expr e',mktype (JCPTnative Treal))) eloc)
in
let e =
- locate (mkexpr (JCPEapp("\\truncate_real_to_int",[],[e1])) e.eloc)
+ locate (mkexpr (JCPEapp("\\truncate_real_to_int",[],[e1])) eloc)
in e#node
| CastE(ty,e') when isIntegralType ty && isArithmeticType (typeOf e') ->
(integral_expr e)#node
| CastE(ty,e') when isFloatingType ty && isArithmeticType (typeOf e') ->
- let e = locate (mkexpr (JCPEcast(expr e',ctype ty)) e.eloc) in
+ let e = locate (mkexpr (JCPEcast(expr e',ctype ty)) eloc) in
e#node
| CastE(ty,e') when isIntegralType ty && isPointerType (typeOf e') ->
@@ -1572,7 +1574,7 @@ let rec expr e =
(* else *)
(* bitwise cast *)
let enode = JCPEcast(expr e,ctype ptrty) in
- let e = locate (mkexpr enode e.eloc) in
+ let e = locate (mkexpr enode eloc) in
e#node
(* let _,ptr_to_ptr = type_conversion ptrty ety in *)
(* JCPEapp(ptr_to_ptr,[],[expr e]) *)
@@ -1600,9 +1602,9 @@ let rec expr e =
| AddrOf _lv -> assert false (* Should have been rewritten *)
- | StartOf lv -> (lval e.eloc lv)#node
+ | StartOf lv -> (lval eloc lv)#node
in
- mkexpr enode e.eloc
+ mkexpr enode eloc
(* Function called when expecting a boolean in Jessie, i.e. when translating
a test or a sub-expression of an "or" or "and".
@@ -1614,6 +1616,7 @@ and boolean_expr e =
else assert false
in
+ let eloc = Location.to_lexing_loc e.eloc in
let enode = match (stripInfo e).enode with
| Info _ -> assert false
@@ -1633,43 +1636,44 @@ and boolean_expr e =
JCPEbinary(expr e1,binop op,expr e2)
else
(* Pointer comparison is translated as subtraction *)
- let sube = mkexpr (JCPEbinary(expr e1,`Bsub,expr e2)) e.eloc in
+ let sube = mkexpr (JCPEbinary(expr e1,`Bsub,expr e2)) eloc in
JCPEbinary(sube,binop op,zero_expr)
| _ -> boolean_node_from_expr (typeOf e) (expr e)
in
- mkexpr enode e.eloc
+ mkexpr enode eloc
(* Function called instead of plain [expr] when the evaluation result should
* fit in a C integral type.
*)
and integral_expr e =
+ let eloc = (Location.to_lexing_loc e.eloc) in
let rec int_expr e =
let node_from_boolean_expr e = JCPEif(e,one_expr,zero_expr) in
let enode = match e.enode with
| UnOp(LNot,e',_ty) ->
- let e = mkexpr (JCPEunary(unop LNot,boolean_expr e')) e.eloc in
+ let e = mkexpr (JCPEunary(unop LNot,boolean_expr e')) eloc in
node_from_boolean_expr e
| UnOp(op,e',_ty) ->
let e =
- locate (mkexpr (JCPEunary(unop op,expr e')) e.eloc)
+ locate (mkexpr (JCPEunary(unop op,expr e')) eloc)
in
e#node
| BinOp((LAnd | LOr) as op,e1,e2,_ty) ->
let e =
- mkexpr (JCPEbinary(boolean_expr e1,binop op,boolean_expr e2)) e.eloc
+ mkexpr (JCPEbinary(boolean_expr e1,binop op,boolean_expr e2)) eloc
in
node_from_boolean_expr e
| BinOp((Lt | Gt | Le | Ge as op),e1,e2,_ty)
when isPointerType (typeOf e1) ->
(* Pointer comparison is translated as subtraction *)
- let sube = mkexpr (JCPEbinary(expr e1,`Bsub,expr e2)) e.eloc in
- let e = mkexpr (JCPEbinary(sube,binop op,zero_expr)) e.eloc in
+ let sube = mkexpr (JCPEbinary(expr e1,`Bsub,expr e2)) eloc in
+ let e = mkexpr (JCPEbinary(sube,binop op,zero_expr)) eloc in
node_from_boolean_expr e
(* | BinOp((Eq | Ne as op),e1,e2,_ty) *)
@@ -1681,11 +1685,11 @@ and integral_expr e =
(* node_from_boolean_expr e *)
| BinOp((Eq | Ne) as op,e1,e2,_ty) ->
- let e = mkexpr (JCPEbinary(expr e1,binop op,expr e2)) e.eloc in
+ let e = mkexpr (JCPEbinary(expr e1,binop op,expr e2)) eloc in
node_from_boolean_expr e
| BinOp((Lt | Gt | Le | Ge) as op,e1,e2,_ty) ->
- let e = mkexpr (JCPEbinary(expr e1,binop op,expr e2)) e.eloc in
+ let e = mkexpr (JCPEbinary(expr e1,binop op,expr e2)) eloc in
node_from_boolean_expr e
| BinOp(Shiftrt,e1,e2,_ty) ->
@@ -1694,13 +1698,13 @@ and integral_expr e =
Integer.lt i (Integer.of_int 63) ->
(* Right shift by constant is division by constant *)
let pow = constant_expr (Integer.two_power i) in
- locate (mkexpr (JCPEbinary(expr e1,`Bdiv,expr pow)) e.eloc)
+ locate (mkexpr (JCPEbinary(expr e1,`Bdiv,expr pow)) eloc)
| _ ->
let op =
if isSignedInteger (typeOf e1) then `Barith_shift_right
else `Blogical_shift_right
in
- locate (mkexpr (JCPEbinary(expr e1,op,expr e2)) e.eloc)
+ locate (mkexpr (JCPEbinary(expr e1,op,expr e2)) eloc)
in
e#node
@@ -1710,36 +1714,36 @@ and integral_expr e =
Integer.lt i (Integer.of_int 63) ->
(* Left shift by constant is multiplication by constant *)
let pow = constant_expr (Integer.two_power i) in
- locate (mkexpr (JCPEbinary(expr e1,`Bmul,expr pow)) e.eloc)
+ locate (mkexpr (JCPEbinary(expr e1,`Bmul,expr pow)) eloc)
| _ ->
- locate (mkexpr (JCPEbinary(expr e1,binop op,expr e2)) e.eloc)
+ locate (mkexpr (JCPEbinary(expr e1,binop op,expr e2)) eloc)
in
e#node
| BinOp(op,e1,e2,_ty) ->
let e =
- locate (mkexpr (JCPEbinary(expr e1,binop op,expr e2)) e.eloc)
+ locate (mkexpr (JCPEbinary(expr e1,binop op,expr e2)) eloc)
in
e#node
| CastE(ty,e1) when isFloatingType (typeOf e1) ->
- let e1' = locate (mkexpr (JCPEcast(expr e1,ltype Linteger)) e.eloc) in
+ let e1' = locate (mkexpr (JCPEcast(expr e1,ltype Linteger)) eloc) in
if !int_model = IMexact then
e1'#node
else
- let e2' = locate (mkexpr (JCPEcast(e1',ctype ty)) e.eloc) in
+ let e2' = locate (mkexpr (JCPEcast(e1',ctype ty)) eloc) in
e2'#node
| CastE(ty,e1) when isIntegralType (typeOf e1) ->
if !int_model = IMexact then
(int_expr e1)#node
else
- let e = locate (mkexpr (JCPEcast(int_expr e1,ctype ty)) e.eloc) in
+ let e = locate (mkexpr (JCPEcast(int_expr e1,ctype ty)) eloc) in
e#node
| _ -> (expr e)#node
in
- mkexpr enode e.eloc
+ mkexpr enode eloc
in
match e.enode with
@@ -1814,8 +1818,9 @@ let keep_only_declared_nb_of_arguments v
let instruction = function
| Set(lv,e,pos) ->
- let enode = JCPEassign(lval pos lv,expr e) in
- (locate (mkexpr enode pos))#node
+ let lpos = Location.to_lexing_loc pos in
+ let enode = JCPEassign(lval lpos lv,expr e) in
+ (locate (mkexpr enode lpos))#node
| Call(None,{enode = Lval(Var v,NoOffset)},eargs,pos) ->
if is_assert_function v then
@@ -1834,9 +1839,10 @@ let instruction = function
v
(List.map expr eargs))
in
- (locate (mkexpr enode pos))#node
+ (locate (mkexpr enode (Location.to_lexing_loc pos)))#node
| Call(Some lv,{enode = Lval(Var v,NoOffset)},eargs,pos) ->
+ let lpos = Location.to_lexing_loc pos in
let enode =
if is_malloc_function v || is_realloc_function v then
let lvtyp = pointed_type (typeOfLval lv) in
@@ -1867,7 +1873,7 @@ let instruction = function
let siznode =
JCPEconst(JCCinteger(Integer.to_string allocsiz))
in
- lvtyp, mkexpr siznode pos
+ lvtyp, mkexpr siznode lpos
| BinOp(Mult,({enode = Const c} as arg),nelem,_ty)
when is_integral_const c -> aux arg nelem
| BinOp(Mult,nelem,({enode = Const c} as arg),_ty)
@@ -1928,24 +1934,24 @@ let instruction = function
(List.map expr eargs))
in
let lvty = typeOfLval lv in
- let call = locate (mkexpr enode pos) in
+ let call = locate (mkexpr enode lpos) in
let enode =
if Typ.equal lvty (getReturnType v.vtype)
|| is_malloc_function v
|| is_realloc_function v
|| is_calloc_function v
then
- JCPEassign(lval pos lv,call)
+ JCPEassign(lval lpos lv,call)
else
let tmpv = makeTempVar (get_curFundec()) (getReturnType v.vtype) in
let tmplv = Var tmpv, NoOffset in
let cast =
new_exp ~loc:pos (CastE(lvty,new_exp ~loc:pos (Lval tmplv)))
in
- let tmpassign = JCPEassign(lval pos lv,expr cast) in
- JCPElet(None,tmpv.vname,Some call,locate (mkexpr tmpassign pos))
+ let tmpassign = JCPEassign(lval lpos lv,expr cast) in
+ JCPElet(None,tmpv.vname,Some call,locate (mkexpr tmpassign lpos))
in
- (locate (mkexpr enode pos))#node
+ (locate (mkexpr enode lpos))#node
| Call _ -> Common.unsupported ~current:true "function pointers"
@@ -1976,9 +1982,10 @@ let rec statement s =
in
*)
+ let lpos = Location.to_lexing_loc pos in
let assert_before, contract =
Annotations.fold_code_annot
- (fun _ ca acc -> code_annot pos acc ca) s ([],None)
+ (fun _ ca acc -> code_annot lpos acc ca) s ([],None)
in
let snode = match s.skind with
| Instr i -> instruction i
@@ -1986,7 +1993,7 @@ let rec statement s =
| Return(Some e,_) -> JCPEreturn(expr e)
| Return(None,_pos) ->
- JCPEreturn(mkexpr (JCPEconst JCCvoid) pos)
+ JCPEreturn(mkexpr (JCPEconst JCCvoid) lpos)
| Goto(sref,_pos) ->
(* Pick the first non-case label in the list of labels associated to
@@ -2050,7 +2057,7 @@ let rec statement s =
| case_stmt :: _ as slist ->
let switch_labels = List.filter is_case_label case_stmt.labels in
let labs = List.map switch_label switch_labels in
- let slist = mkexpr (JCPEblock(statement_list slist)) pos in
+ let slist = mkexpr (JCPEblock(statement_list slist)) (Location.to_lexing_loc pos) in
labs, slist
in
let case_list = List.map case (case_blocks bl.bstmts slist) in
@@ -2098,7 +2105,7 @@ let rec statement s =
let inv =
match invs with
| [] -> None
- | _ -> Some (mkconjunct invs pos)
+ | _ -> Some (mkconjunct invs lpos)
in
let ass = assigns ass in
(beh_names,inv,ass))
@@ -2119,7 +2126,7 @@ let rec statement s =
in
(* Prefix statement by all non-case labels *)
let labels = filter_out is_case_label s.labels in
- let s = mkexpr snode pos in
+ let s = mkexpr snode lpos in
let s =
match contract with
| None -> s
@@ -2145,13 +2152,13 @@ let rec statement s =
in
mkexpr
(JCPEcontract(requires, decreases, behaviors, s))
- pos
+ lpos
in
let s = match assert_before @ [s] with
| [s] -> s
- | slist -> mkexpr (JCPEblock slist) pos
+ | slist -> mkexpr (JCPEblock slist) lpos
in
- List.fold_left (fun s lab -> mkexpr (JCPElabel(label lab,s)) pos) s labels
+ List.fold_left (fun s lab -> mkexpr (JCPElabel(label lab,s)) lpos) s labels
and statement_list slist = List.rev (List.rev_map statement slist)
@@ -2228,7 +2235,7 @@ let rec annotation is_axiomatic annot =
if _attr <> [] then warning "ignoring attributes of axiom %s" name;
ignore
(reg_position ~id:name
- ~name:("Lemma " ^ name) pos);
+ ~name:("Lemma " ^ name) (Location.to_lexing_loc pos));
begin try
[JCDlemma(name,is_axiom,[],logic_labels labels,pred property)]
with (Unsupported _ | Log.FeatureRequest _)
@@ -2263,6 +2270,7 @@ let rec annotation is_axiomatic annot =
| Dtype (info,pos) when info.lt_params=[] ->
CurrentLoc.set pos;
+ let lpos = Location.to_lexing_loc pos in
let myself = mktype (JCPTidentifier (info.lt_name,[])) in
let mydecl = JCDlogic_type (info.lt_name,[]) in
let axiomatic ctors =
@@ -2295,8 +2303,8 @@ let rec annotation is_axiomatic annot =
(* TODO: give unique name *)
(fun x ->
mkexpr (JCPEquantifier(Forall,ltype t,
- [new identifier prms_name], [],x)) pos),
- mkexpr (JCPEvar prms_name) pos
+ [new identifier prms_name], [],x)) lpos),
+ mkexpr (JCPEvar prms_name) lpos
in
let (quant,args) =
List.fold_right
@@ -2314,17 +2322,17 @@ let rec annotation is_axiomatic annot =
(mkexpr
(JCPEbinary
(mkexpr (JCPEapp (info.lt_name ^ "_tag",[],
- [mkexpr expr pos])) pos,
+ [mkexpr expr lpos])) lpos,
`Beq,
- mkexpr(JCPEconst(JCCinteger (Int64.to_string i))) pos))
- pos)
+ mkexpr(JCPEconst(JCCinteger (Int64.to_string i))) lpos))
+ lpos)
in
(i+one,
JCDlemma(cons.ctor_name ^ "_tag_val",true,[],[], pred)
::axioms)
in
let (_,axioms) = List.fold_right tag_axiom ctors (zero,[]) in
- let xvar = mkexpr (JCPEvar "x") pos in (* TODO: give unique name *)
+ let xvar = mkexpr (JCPEvar "x") lpos in (* TODO: give unique name *)
let one_case cons =
let prms = ref(-1) in
let param t =
@@ -2333,8 +2341,8 @@ let rec annotation is_axiomatic annot =
(* TODO: give unique name *)
((fun x ->
mkexpr (JCPEquantifier(Exists,ltype t,
- [new identifier prms_name], [],x)) pos),
- mkexpr (JCPEvar prms_name) pos)
+ [new identifier prms_name], [],x)) lpos),
+ mkexpr (JCPEvar prms_name) lpos)
in let (quant,args) =
List.fold_right
(fun arg (quants,args) ->
@@ -2345,7 +2353,7 @@ let rec annotation is_axiomatic annot =
quant
(mkexpr
(JCPEbinary(xvar,`Beq,
- mkexpr (JCPEapp(cons.ctor_name,[],args)) pos)) pos)
+ mkexpr (JCPEapp(cons.ctor_name,[],args)) lpos)) lpos)
in
match ctors with
[] -> cons
@@ -2354,7 +2362,7 @@ let rec annotation is_axiomatic annot =
[JCDlemma(info.lt_name ^ "_inductive", true, [], [],
(mkexpr (JCPEquantifier
(Forall,myself,
- [new identifier "x"], [],one_case x)) pos))]
+ [new identifier "x"], [],one_case x)) lpos))]
| x::l ->
tag_fun :: cons @ axioms @
[JCDlemma(info.lt_name ^ "_inductive", true, [], [],
@@ -2365,8 +2373,8 @@ let rec annotation is_axiomatic annot =
List.fold_right
(fun cons case ->
mkexpr (JCPEbinary(case,`Blor,
- one_case cons)) pos)
- l (one_case x))) pos)]
+ one_case cons)) lpos)
+ l (one_case x))) lpos)]
in
(*NB: axioms stating that two values beginning with different
symbols are different are not generated. *)
@@ -2380,7 +2388,7 @@ let rec annotation is_axiomatic annot =
| _ when is_axiomatic -> axiomatic
| _ ->
[JCDaxiomatic (info.lt_name ^ "_axiomatic",
- List.map (fun x -> mkdecl x pos) axiomatic)])
+ List.map (fun x -> mkdecl x lpos) axiomatic)])
| Dtype _ -> unsupported "type definitions"
| Dvolatile _ -> Common.unsupported "volatile variables"
@@ -2395,8 +2403,9 @@ let rec annotation is_axiomatic annot =
Format.eprintf "Translating axiomatic %s into jessie code@." id;
*)
let l = List.fold_left (fun acc d -> (annotation true d)@acc) [] l in
- [JCDaxiomatic(id,List.map (fun d -> mkdecl d pos)
+ [JCDaxiomatic(id,List.map (fun d -> mkdecl d (Location.to_lexing_loc pos))
(List.rev l))]
+ | Dextended _ -> unsupported "extended global annotation"
let default_field_modifiers = (false,false)
@@ -2457,7 +2466,7 @@ let global vardefs g =
ignore(Typ.Hashtbl.find Norm.generated_union_types ty);
[JCDtag(compinfo.cname,[],None,fields,[])]
with Not_found ->
- let id = mkidentifier compinfo.cname pos in
+ let id = mkidentifier compinfo.cname (Location.to_lexing_loc pos) in
[
JCDtag(compinfo.cname,[],None,fields,[]);
JCDvariant_type(compinfo.cname,[id])
@@ -2466,9 +2475,10 @@ let global vardefs g =
| GCompTag(compinfo,pos) -> (* union type *)
assert (not compinfo.cstruct);
+ let lpos = Location.to_lexing_loc pos in
let field fi =
let ty = pointed_type fi.ftype in
- mkidentifier (get_struct_name ty) pos
+ mkidentifier (get_struct_name ty) lpos
in
(* match pointed_type fi.ftype with *)
(* | TComp(compinfo,_) -> *)
@@ -2483,7 +2493,7 @@ let global vardefs g =
(* | _ -> *)
(* assert false *)
(* in *)
- let union_id = mkidentifier compinfo.cname pos in
+ let union_id = mkidentifier compinfo.cname lpos in
let union_size = match compinfo.cfields with
| [] -> 0
| fi::_ ->
@@ -2558,7 +2568,7 @@ let global vardefs g =
| TFun(rt,_,_,_) -> rt
| _ -> assert false
in
- let id = mkidentifier v.vname pos in
+ let id = mkidentifier v.vname (Location.to_lexing_loc pos) in
let kf = Globals.Functions.get v in
Jessie_options.debug
"Getting spec of %s" (Kernel_function.get_name kf);
@@ -2587,22 +2597,23 @@ let global vardefs g =
if f.svar.vname = name_of_assert
|| f.svar.vname = name_of_free then []
else
+ let lpos = Location.to_lexing_loc pos in
let rty = match unrollType f.svar.vtype with
| TFun(ty,_,_,_) -> ty
| _ -> assert false
in
let formal v = true, ctype v.vtype, v.vname in
let formals = List.map formal f.sformals in
- let id = mkidentifier f.svar.vname f.svar.vdecl in
+ let id = mkidentifier f.svar.vname (Location.to_lexing_loc f.svar.vdecl) in
let funspec =
Annotations.funspec (Globals.Functions.get f.svar)
in
begin try
let local v =
- mkexpr (JCPEdecl(ctype v.vtype,v.vname,None)) v.vdecl
+ mkexpr (JCPEdecl(ctype v.vtype,v.vname,None)) (Location.to_lexing_loc v.vdecl)
in
let locals = List.rev (List.rev_map local f.slocals) in
- let body = mkexpr (JCPEblock(statement_list f.sbody.bstmts)) pos in
+ let body = mkexpr (JCPEblock(statement_list f.sbody.bstmts)) lpos in
let s,cba,dba = spec f.svar.vname funspec in
let body =
List.fold_left
@@ -2630,10 +2641,10 @@ let global vardefs g =
:: acc)
body dba
in
- let body = mkexpr (JCPEblock body) pos in
+ let body = mkexpr (JCPEblock body) lpos in
ignore
(reg_position ~id:f.svar.vname
- ~name:("Function " ^ f.svar.vname) f.svar.vdecl);
+ ~name:("Function " ^ f.svar.vname) (Location.to_lexing_loc f.svar.vdecl));
[JCDfun(ctype rty,id,formals,s,Some body)]
with (Unsupported _ | Log.FeatureRequest _)
when drop_on_unsupported_feature ->
@@ -2652,7 +2663,7 @@ let global vardefs g =
| GAnnot(la,_) -> annotation false la
in
- List.map (fun dnode -> mkdecl dnode pos) dnodes
+ List.map (fun dnode -> mkdecl dnode (Location.to_lexing_loc pos)) dnodes
let integral_type name ty bitsize =
let min = min_value_of_integral_type ~bitsize ty in
Reference in a new issue View git blame Copy permalink