let rec annotation is_axiomatic annot pos = match annot with
| Dfun_or_pred info ->
begin try
let params = List.map logic_variable info.l_profile in
let body =
match info.l_body with
| LBreads reads_tsets ->
let reads =
List.flatten
(List.map (fun x -> terms x.it_content) reads_tsets)
in
JCreads reads
| LBpred p -> JCexpr(pred p)
| LBinductive indcases ->
let l = List.map
(fun (id,labs,_poly,p) ->
(new identifier id,logic_labels labs,pred p)) indcases
in
JCinductive l
| LBterm t -> JCexpr(term t)
in
let name = translated_name info in
[JCDlogic(Option_misc.map ltype info.l_type,
name,
logic_labels info.l_labels,
params,body)]
with (Unsupported _ | NotImplemented _) ->
warning "Dropping declaration of predicate %s@." info.l_var_info.lv_name ;
[]
end
| Dlemma(name,is_axiom,labels,_poly,property) ->
begin try
[JCDlemma(name,is_axiom,logic_labels labels,pred property)]
with (Unsupported _ | NotImplemented _) ->
warning "Dropping lemma %s@." name ;
[]
end
| Dinvariant property ->
begin try
let n = translated_name property in
[JCDglobal_inv(n,pred (Logic_utils.get_pred_body property))]
with (Unsupported _ | NotImplemented _) ->
warning "Dropping invariant %s@." property.l_var_info.lv_name ;
[]
end
| Dtype_annot annot ->
begin try
let n = translated_name annot in
[JCDlogic(
None,n, logic_labels annot.l_labels,
List.map logic_variable annot.l_profile,
JCexpr(pred (Logic_utils.get_pred_body annot)))]
with (Unsupported _ | NotImplemented _) ->
warning "Dropping type invariant %s@." annot.l_var_info.lv_name;
[]
end
| Dtype info when info.lt_params=[] ->
let myself = mktype (JCPTidentifier info.lt_name) in
let mydecl = JCDlogic_type info.lt_name in
let axiomatic ctors =
let cons = List.map
(fun x ->
let prms = ref (-1) in
let make_params t =
incr prms;
ltype t, Printf.sprintf "x%d" !prms
in
match x.ctor_params with
[] -> JCDlogic_var(myself,x.ctor_name,None)
| l ->
let params = List.map make_params l in
JCDlogic(Some myself,x.ctor_name,[],params,
JCreads []
))
ctors
in
let tag_fun = JCDlogic (Some (mktype (JCPTnative Tinteger)),
info.lt_name ^ "_tag",[],[myself,"x"],
JCreads[])
in
let tag_axiom cons (i,axioms) =
let prms = ref(-1) in
let param t =
incr prms;
let prms_name = Printf.sprintf "x%d" !prms in
(fun x ->
mkexpr (JCPEquantifier(Forall,ltype t,
[new identifier prms_name], [],x)) pos),
mkexpr (JCPEvar prms_name) pos
in
let (quant,args) =
List.fold_right
(fun arg (quants,args) ->
let quant,arg = param arg in
((fun x -> quant(quants x)), arg::args))
cons.ctor_params ((fun x -> x),[])
in
let expr = match cons.ctor_params with
[] -> JCPEvar cons.ctor_name
| _ -> JCPEapp(cons.ctor_name,[],args)
in
let pred =
quant
(mkexpr
(JCPEbinary
(mkexpr (JCPEapp (info.lt_name ^ "_tag",[],
[mkexpr expr pos])) pos,
`Beq,
mkexpr(JCPEconst(JCCinteger (Int64.to_string i))) pos))
pos)
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
let one_case cons =
let prms = ref(-1) in
let param t =
incr prms;
let prms_name = Printf.sprintf "x%d" !prms in
((fun x ->
mkexpr (JCPEquantifier(Exists,ltype t,
[new identifier prms_name], [],x)) pos),
mkexpr (JCPEvar prms_name) pos)
in let (quant,args) =
List.fold_right
(fun arg (quants,args) ->
let quant,arg = param arg in
((fun x -> quant(quants x)), arg::args))
cons.ctor_params ((fun x -> x),[])
in
quant
(mkexpr
(JCPEbinary(xvar,`Beq,
mkexpr (JCPEapp(cons.ctor_name,[],args)) pos)) pos)
in
match ctors with
[] -> cons
| [x] ->
cons @
[JCDlemma(info.lt_name ^ "_inductive", true, [],
(mkexpr (JCPEquantifier
(Forall,myself,
[new identifier "x"], [],one_case x)) pos))]
| x::l ->
tag_fun :: cons @ axioms @
[JCDlemma(info.lt_name ^ "_inductive", true, [],
mkexpr
(JCPEquantifier(
Forall,myself,
[new identifier "x"], [],
List.fold_right
(fun cons case ->
mkexpr (JCPEbinary(case,`Blor,
one_case cons)) pos)
l (one_case x))) pos)]
in
let axiomatic = match info.lt_ctors with
None -> [mydecl]
| Some ctors -> mydecl::axiomatic ctors
in
if is_axiomatic then axiomatic
else
[JCDaxiomatic (info.lt_name ^ "_axiomatic",
List.map (fun x -> mkdecl x pos) axiomatic)]
| Dtype _info ->
Extlib.not_yet_implemented "Interp.annotation Dtype"
| Daxiomatic(id,l) ->
let l = List.fold_left (fun acc d -> (annotation true d pos)@acc) [] l in
[JCDaxiomatic(id,List.map (fun d -> mkdecl d pos)
(List.rev l))]