(*
- * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
+ * Copyright 2012, INRIA
+ * Julia Lawall, Gilles Muller
+ * Copyright 2010-2011, INRIA, University of Copenhagen
+ * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
+ * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
* This file is part of Coccinelle.
*
before this phase. Furthermore add_dot_binding relies on the offset to
remain the same between matching an iso and instantiating it with bindings. *)
+(* Consider whether ... in iso should match <... ...> in smpl? *)
+
(* --------------------------------------------------------------------- *)
(* match a SmPL expression against a SmPL abstract syntax tree,
either - or + *)
let strip_info =
let mcode (term,_,_,_,_,_) =
(term,Ast0.NONE,Ast0.default_info(),Ast0.PLUS Ast.ONE,
- ref Ast0.NoMetaPos,-1) in
+ ref [],-1) in
let donothing r k e =
let x = k e in
{(Ast0.wrap (Ast0.unwrap x)) with
| ContextRequired of Ast0.anything
| NonMatch
| Braces of Ast0.statement
+ | Nest of Ast0.statement
| Position of Ast.meta_name
| TypeMatch of reason list
Printf.printf "braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
Unparse_ast0.statement "" s;
Format.print_newline()
+ | Nest(s) ->
+ Printf.printf "iso with nest doesn't match whencode (TODO):\n";
+ Unparse_ast0.statement "" s;
+ Format.print_newline()
| Position(rule,name) ->
Printf.printf "position variable %s.%s conflicts with an isomorphism\n"
- rule name;
- | TypeMatch reason_list ->
+ rule name
+ | TypeMatch reason_list ->
List.iter (function r -> interpret_reason name line r printer)
reason_list
| _ -> failwith "not possible"
| _ -> false)
| Ast0.MINUS(mc) ->
(match !mc with
- (* do better for the common case of replacing a stmt by another one *)
- ([[Ast.StatementTag(s)]],_) ->
+ (* do better for the common case of replacing a stmt by another one *)
+ (Ast.REPLACEMENT([[Ast.StatementTag(s)]],_),_) ->
(match Ast.unwrap s with
Ast.IfThen(_,_,_) -> false (* potentially dangerous *)
| _ -> true)
| _ -> return false in
loop (la,lb)
+let all_caps = Str.regexp "^[A-Z_][A-Z_0-9]*$"
+
let match_maker checks_needed context_required whencode_allowed =
- let check_mcode pmc cmc binding =
+ let check_mcode pmc (*pattern*) cmc (*code*) binding =
if checks_needed
then
match Ast0.get_pos cmc with
- (Ast0.MetaPos (name,_,_)) as x ->
- (match Ast0.get_pos pmc with
- Ast0.MetaPos (name1,_,_) ->
- add_binding name1 (Ast0.MetaPosTag x) binding
- | Ast0.NoMetaPos ->
- let (rule,name) = Ast0.unwrap_mcode name in
- Fail (Position(rule,name)))
- | Ast0.NoMetaPos -> OK binding
+ [] -> OK binding (* no hidden vars in smpl code, so nothing to do *)
+ | ((a::_) as hidden_code) ->
+ let hidden_pattern =
+ List.filter (function Ast0.HiddenVarTag _ -> true | _ -> false)
+ (Ast0.get_pos pmc) in
+ (match hidden_pattern with
+ [Ast0.HiddenVarTag([Ast0.MetaPosTag(Ast0.MetaPos (name1,_,_))])] ->
+ add_binding name1 (Ast0.HiddenVarTag(hidden_code)) binding
+ | [] -> Fail(Position(Ast0.unwrap_mcode(Ast0.meta_pos_name a)))
+ | _ -> failwith "badly compiled iso - multiple hidden variable")
else OK binding in
let match_dots matcher is_list_matcher do_list_match d1 d2 =
(Ast.NOTHING,_,_) -> Ast0.PureContext
| _ -> Ast0.Context)
| Ast0.MINUS(mc) ->
- (match !mc with ([],_) -> Ast0.Pure | _ -> Ast0.Impure)
+ (match !mc with
+ (Ast.NOREPLACEMENT,_) -> Ast0.Pure
+ | _ -> Ast0.Impure)
| _ -> Ast0.Impure in
let donothing r k e =
bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e) in
let ident r k i =
bind (bind (pure_mcodekind (Ast0.get_mcodekind i)) (k i))
(match Ast0.unwrap i with
- Ast0.MetaId(name,_,pure) | Ast0.MetaFunc(name,_,pure)
+ Ast0.MetaId(name,_,_,pure) | Ast0.MetaFunc(name,_,pure)
| Ast0.MetaLocalFunc(name,_,pure) -> pure
| _ -> Ast0.Impure) in
let init r k t =
bind (bind (pure_mcodekind (Ast0.get_mcodekind t)) (k t))
(match Ast0.unwrap t with
- Ast0.MetaInit(name,pure) -> pure
+ Ast0.MetaInit(name,pure) | Ast0.MetaInitList(name,_,pure) -> pure
| _ -> Ast0.Impure) in
let param r k p =
Ast0.MetaParam(name,pure) | Ast0.MetaParamList(name,_,pure) -> pure
| _ -> Ast0.Impure) in
+ let decl r k d =
+ bind (bind (pure_mcodekind (Ast0.get_mcodekind d)) (k d))
+ (match Ast0.unwrap d with
+ Ast0.MetaDecl(name,pure) | Ast0.MetaField(name,pure)
+ | Ast0.MetaFieldList(name,_,pure) ->
+ pure
+ | _ -> Ast0.Impure) in
+
let stmt r k s =
bind (bind (pure_mcodekind (Ast0.get_mcodekind s)) (k s))
(match Ast0.unwrap s with
V0.flat_combiner bind option_default
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
donothing donothing donothing donothing donothing donothing
- ident expression typeC init param donothing stmt donothing
+ ident expression typeC init param decl stmt donothing
donothing in
let add_pure_list_binding name pure is_pure builder1 builder2 lst =
let rec match_ident pattern id =
match Ast0.unwrap pattern with
- Ast0.MetaId(name,_,pure) ->
+ Ast0.MetaId(name,_,_,pure) ->
(add_pure_binding name pure pure_sp_code.VT0.combiner_rec_ident
(function id -> Ast0.IdentTag id) id)
| Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
if mcode_equal namea nameb
then check_mcode namea nameb
else return false
+ | (Ast0.DisjId(_,ids,_,_),_) ->
+ failwith "not allowed in the pattern of an isomorphism"
| (Ast0.OptIdent(ida),Ast0.OptIdent(idb))
| (Ast0.UniqueIdent(ida),Ast0.UniqueIdent(idb)) ->
match_ident ida idb
let rec matches e =
match Ast0.unwrap e with
Ast0.Constant(c) -> true
+ | Ast0.Ident(c) ->
+ (match Ast0.unwrap c with
+ Ast0.Id(nm) ->
+ let nm = Ast0.unwrap_mcode nm in
+ (* all caps is a const *)
+ Str.string_match all_caps nm 0
+ | _ -> false)
| Ast0.Cast(lp,ty,rp,e) -> matches e
| Ast0.SizeOfExpr(se,exp) -> true
| Ast0.SizeOfType(se,lp,ty,rp) -> true
attempts
then
(* not sure why this is ok. can there be more
- than one OK? *)
+ than one OK? *)
OK (List.concat
(List.map
(function Fail _ -> [] | OK x -> x)
[check_mcode opa opb; match_expr lefta leftb;
match_expr righta rightb]
else return false
+ | (Ast0.Sequence(lefta,opa,righta),
+ Ast0.Sequence(leftb,opb,rightb)) ->
+ if mcode_equal opa opb
+ then
+ conjunct_many_bindings
+ [check_mcode opa opb; match_expr lefta leftb;
+ match_expr righta rightb]
+ else return false
| (Ast0.CondExpr(exp1a,lp1,exp2a,rp1,exp3a),
Ast0.CondExpr(exp1b,lp,exp2b,rp,exp3b)) ->
conjunct_many_bindings
conjunct_many_bindings
[check_mcode lp1 lp; check_mcode rp1 rp;
check_mcode szf1 szf; match_typeC tya tyb]
+ | (Ast0.Constructor(lp1,tya,rp1,inita),
+ Ast0.Constructor(lp,tyb,rp,initb)) ->
+ conjunct_many_bindings
+ [check_mcode lp1 lp; check_mcode rp1 rp;
+ match_typeC tya tyb; match_init inita initb]
| (Ast0.TypeExp(tya),Ast0.TypeExp(tyb)) ->
match_typeC tya tyb
| (Ast0.EComma(cm1),Ast0.EComma(cm)) -> check_mcode cm1 cm
| (Ast0.Estars(_,Some _),_) ->
failwith "whencode not allowed in a pattern1"
| (Ast0.OptExp(expa),Ast0.OptExp(expb))
- | (Ast0.UniqueExp(expa),Ast0.UniqueExp(expb)) -> match_expr expa expb
+ | (Ast0.UniqueExp(expa),Ast0.UniqueExp(expb)) ->
+ match_expr expa expb
| (_,Ast0.OptExp(expb))
| (_,Ast0.UniqueExp(expb)) -> match_expr pattern expb
| _ -> return false
conjunct_many_bindings
[check_mcode lb1 lb; check_mcode rb1 rb;
match_typeC tya tyb; match_option match_expr sizea sizeb]
- | (Ast0.EnumName(kinda,namea),Ast0.EnumName(kindb,nameb)) ->
- conjunct_bindings (check_mcode kinda kindb)
- (match_ident namea nameb)
+ | (Ast0.EnumName(kinda,Some namea),
+ Ast0.EnumName(kindb,Some nameb)) ->
+ conjunct_bindings (check_mcode kinda kindb)
+ (match_ident namea nameb)
+ | (Ast0.EnumDef(tya,lb1,idsa,rb1),
+ Ast0.EnumDef(tyb,lb,idsb,rb)) ->
+ conjunct_many_bindings
+ [check_mcode lb1 lb; check_mcode rb1 rb;
+ match_typeC tya tyb;
+ match_dots match_expr no_list do_nolist_match idsa idsb]
| (Ast0.StructUnionName(kinda,Some namea),
Ast0.StructUnionName(kindb,Some nameb)) ->
if mcode_equal kinda kindb
if mcode_equal namea nameb
then check_mcode namea nameb
else return false
- | (Ast0.DisjType(_,typesa,_,_),Ast0.DisjType(_,typesb,_,_)) ->
+ | (Ast0.DisjType(_,typesa,_,_),_) ->
failwith "not allowed in the pattern of an isomorphism"
| (Ast0.OptType(tya),Ast0.OptType(tyb))
| (Ast0.UniqueType(tya),Ast0.UniqueType(tyb)) -> match_typeC tya tyb
else return_false (ContextRequired (Ast0.TypeCTag t))
and match_decl pattern d =
- if not(checks_needed) or not(context_required) or is_context d
- then
- match (Ast0.unwrap pattern,Ast0.unwrap d) with
- (Ast0.Init(stga,tya,ida,eq1,inia,sc1),
- Ast0.Init(stgb,tyb,idb,eq,inib,sc)) ->
- if bool_match_option mcode_equal stga stgb
- then
- conjunct_many_bindings
- [check_mcode eq1 eq; check_mcode sc1 sc;
- match_option check_mcode stga stgb;
- match_typeC tya tyb; match_ident ida idb;
- match_init inia inib]
- else return false
- | (Ast0.UnInit(stga,tya,ida,sc1),Ast0.UnInit(stgb,tyb,idb,sc)) ->
- if bool_match_option mcode_equal stga stgb
- then
- conjunct_many_bindings
- [check_mcode sc1 sc; match_option check_mcode stga stgb;
- match_typeC tya tyb; match_ident ida idb]
- else return false
- | (Ast0.MacroDecl(namea,lp1,argsa,rp1,sc1),
- Ast0.MacroDecl(nameb,lp,argsb,rp,sc)) ->
- conjunct_many_bindings
- [match_ident namea nameb;
- check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode sc1 sc;
- match_dots match_expr is_elist_matcher do_elist_match
- argsa argsb]
- | (Ast0.TyDecl(tya,sc1),Ast0.TyDecl(tyb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc) (match_typeC tya tyb)
- | (Ast0.Typedef(stga,tya,ida,sc1),Ast0.Typedef(stgb,tyb,idb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc)
- (conjunct_bindings (match_typeC tya tyb) (match_typeC ida idb))
- | (Ast0.DisjDecl(_,declsa,_,_),Ast0.DisjDecl(_,declsb,_,_)) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.Ddots(d1,None),Ast0.Ddots(d,None)) -> check_mcode d1 d
- | (Ast0.Ddots(dd,None),Ast0.Ddots(d,Some wc)) ->
- conjunct_bindings (check_mcode dd d)
+ match Ast0.unwrap pattern with
+ Ast0.MetaDecl(name,pure) ->
+ add_pure_binding name pure pure_sp_code.VT0.combiner_rec_declaration
+ (function d -> Ast0.DeclTag d)
+ d
+ | Ast0.MetaField(name,pure) ->
+ add_pure_binding name pure pure_sp_code.VT0.combiner_rec_declaration
+ (function d -> Ast0.DeclTag d)
+ d
+ | Ast0.MetaFieldList(name,_,pure) -> failwith "metafieldlist not supporte"
+ | up ->
+ if not(checks_needed) or not(context_required) or is_context d
+ then
+ match (up,Ast0.unwrap d) with
+ (Ast0.Init(stga,tya,ida,eq1,inia,sc1),
+ Ast0.Init(stgb,tyb,idb,eq,inib,sc)) ->
+ if bool_match_option mcode_equal stga stgb
+ then
+ conjunct_many_bindings
+ [check_mcode eq1 eq; check_mcode sc1 sc;
+ match_option check_mcode stga stgb;
+ match_typeC tya tyb; match_ident ida idb;
+ match_init inia inib]
+ else return false
+ | (Ast0.UnInit(stga,tya,ida,sc1),Ast0.UnInit(stgb,tyb,idb,sc)) ->
+ if bool_match_option mcode_equal stga stgb
+ then
+ conjunct_many_bindings
+ [check_mcode sc1 sc; match_option check_mcode stga stgb;
+ match_typeC tya tyb; match_ident ida idb]
+ else return false
+ | (Ast0.MacroDecl(namea,lp1,argsa,rp1,sc1),
+ Ast0.MacroDecl(nameb,lp,argsb,rp,sc)) ->
+ conjunct_many_bindings
+ [match_ident namea nameb;
+ check_mcode lp1 lp; check_mcode rp1 rp;
+ check_mcode sc1 sc;
+ match_dots match_expr is_elist_matcher do_elist_match
+ argsa argsb]
+ | (Ast0.MacroDeclInit(namea,lp1,argsa,rp1,eq1,ini1,sc1),
+ Ast0.MacroDeclInit(nameb,lp,argsb,rp,eq,ini,sc)) ->
+ conjunct_many_bindings
+ [match_ident namea nameb;
+ check_mcode lp1 lp; check_mcode rp1 rp;
+ check_mcode eq1 eq;
+ check_mcode sc1 sc;
+ match_dots match_expr is_elist_matcher do_elist_match
+ argsa argsb;
+ match_init ini1 ini]
+ | (Ast0.TyDecl(tya,sc1),Ast0.TyDecl(tyb,sc)) ->
+ conjunct_bindings (check_mcode sc1 sc) (match_typeC tya tyb)
+ | (Ast0.Typedef(stga,tya,ida,sc1),Ast0.Typedef(stgb,tyb,idb,sc)) ->
+ conjunct_bindings (check_mcode sc1 sc)
+ (conjunct_bindings (match_typeC tya tyb) (match_typeC ida idb))
+ | (Ast0.DisjDecl(_,declsa,_,_),_) ->
+ failwith "not allowed in the pattern of an isomorphism"
+ | (Ast0.Ddots(d1,None),Ast0.Ddots(d,None)) -> check_mcode d1 d
+ | (Ast0.Ddots(dd,None),Ast0.Ddots(d,Some wc)) ->
+ conjunct_bindings (check_mcode dd d)
(* hope that mcode of ddots is unique somehow *)
- (let (ddots_whencode_allowed,_,_) = whencode_allowed in
- if ddots_whencode_allowed
- then add_dot_binding dd (Ast0.DeclTag wc)
- else
- (Printf.printf "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Ddots(_,Some _),_) ->
- failwith "whencode not allowed in a pattern1"
-
- | (Ast0.OptDecl(decla),Ast0.OptDecl(declb))
- | (Ast0.UniqueDecl(decla),Ast0.UniqueDecl(declb)) ->
- match_decl decla declb
- | (_,Ast0.OptDecl(declb))
- | (_,Ast0.UniqueDecl(declb)) ->
- match_decl pattern declb
- | _ -> return false
- else return_false (ContextRequired (Ast0.DeclTag d))
+ (let (ddots_whencode_allowed,_,_) = whencode_allowed in
+ if ddots_whencode_allowed
+ then add_dot_binding dd (Ast0.DeclTag wc)
+ else
+ (Printf.printf "warning: not applying iso because of whencode";
+ return false))
+ | (Ast0.Ddots(_,Some _),_) ->
+ failwith "whencode not allowed in a pattern1"
+
+ | (Ast0.OptDecl(decla),Ast0.OptDecl(declb))
+ | (Ast0.UniqueDecl(decla),Ast0.UniqueDecl(declb)) ->
+ match_decl decla declb
+ | (_,Ast0.OptDecl(declb))
+ | (_,Ast0.UniqueDecl(declb)) ->
+ match_decl pattern declb
+ | _ -> return false
+ else return_false (ContextRequired (Ast0.DeclTag d))
and match_init pattern i =
match Ast0.unwrap pattern with
match (up,Ast0.unwrap i) with
(Ast0.InitExpr(expa),Ast0.InitExpr(expb)) ->
match_expr expa expb
- | (Ast0.InitList(lb1,initlista,rb1),Ast0.InitList(lb,initlistb,rb))
- ->
+ | (Ast0.InitList(lb1,initlista,rb1,oa),
+ Ast0.InitList(lb,initlistb,rb,ob))
+ when oa = ob ->
conjunct_many_bindings
[check_mcode lb1 lb; check_mcode rb1 rb;
match_dots match_init no_list do_nolist_match
single_statement can't deal with this case, perhaps because
it starts introducing too many braces? don't remember the
exact problem...
- *)
+ *)
conjunct_bindings (check_mcode lb1 lb)
(conjunct_bindings (check_mcode rb1 rb)
(if not(checks_needed) or is_minus s or
bodya bodyb
else return_false (Braces(s))))
| (Ast0.ExprStatement(expa,sc1),Ast0.ExprStatement(expb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc) (match_expr expa expb)
+ conjunct_bindings (check_mcode sc1 sc)
+ (match_option match_expr expa expb)
| (Ast0.IfThen(if1,lp1,expa,rp1,branch1a,_),
Ast0.IfThen(if2,lp2,expb,rp2,branch1b,_)) ->
conjunct_many_bindings
[check_mcode r1 r; check_mcode sc1 sc; match_expr expa expb]
| (Ast0.Disj(_,statement_dots_lista,_,_),_) ->
failwith "disj not supported in patterns"
+ | (Ast0.Nest(_,stmt_dotsa,_,[],multia),
+ Ast0.Nest(_,stmt_dotsb,_,wc,multib)) ->
+ if multia = multib
+ then
+ (match wc with
+ [] ->
+ (* not sure this is correct, perhaps too restrictive *)
+ if not(checks_needed) or is_minus s or
+ (is_context s &&
+ List.for_all is_pure_context (Ast0.undots stmt_dotsb))
+ then
+ match_dots match_statement
+ is_slist_matcher do_slist_match
+ stmt_dotsa stmt_dotsb
+ else return_false (Braces(s))
+ | _ -> return_false (Nest(s)))
+ else return false (* diff kind of nest *)
| (Ast0.Nest(_,stmt_dotsa,_,_,_),_) ->
- failwith "nest not supported in patterns"
+ failwith "nest with whencode not supported in patterns"
| (Ast0.Exp(expa),Ast0.Exp(expb)) -> match_expr expa expb
| (Ast0.TopExp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
| (Ast0.Exp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
match mcodekind with
Ast0.CONTEXT(mc) ->
(match !mc with
- (Ast.NOTHING,_,_) -> Ast0.MINUS(ref([],Ast0.default_token_info))
+ (Ast.NOTHING,_,_) ->
+ Ast0.MINUS(ref(Ast.NOREPLACEMENT,Ast0.default_token_info))
| _ -> failwith "make_minus: unexpected befaft")
| Ast0.MINUS(mc) -> mcodekind (* in the part copied from the src term *)
| _ -> failwith "make_minus mcode: unexpected mcodekind" in
Ast0.CONTEXT(mc) ->
(match !mc with
(Ast.NOTHING,_,_) ->
- mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info))
+ mcodekind :=
+ Ast0.MINUS(ref(Ast.NOREPLACEMENT,Ast0.default_token_info))
| _ -> failwith "make_minus: unexpected befaft")
| Ast0.MINUS(_mc) -> () (* in the part copied from the src term *)
| Ast0.PLUS _ -> failwith "make_minus donothing: unexpected plus mcodekind"
let mcodekind = Ast0.get_mcodekind_ref e in
match Ast0.unwrap e with
Ast0.Edots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
+ (*don't recurse because whencode hasn't been processed by context_neg*)
update_mc mcodekind e; Ast0.rewrap e (Ast0.Edots(mcode d,whencode))
| Ast0.Ecircles(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
+ (*don't recurse because whencode hasn't been processed by context_neg*)
update_mc mcodekind e; Ast0.rewrap e (Ast0.Ecircles(mcode d,whencode))
| Ast0.Estars(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
+ (*don't recurse because whencode hasn't been processed by context_neg*)
update_mc mcodekind e; Ast0.rewrap e (Ast0.Estars(mcode d,whencode))
| Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) ->
update_mc mcodekind e;
let mcodekind = Ast0.get_mcodekind_ref e in
match Ast0.unwrap e with
Ast0.Ddots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
+ (*don't recurse because whencode hasn't been processed by context_neg*)
update_mc mcodekind e; Ast0.rewrap e (Ast0.Ddots(mcode d,whencode))
| _ -> donothing r k e in
let mcodekind = Ast0.get_mcodekind_ref e in
match Ast0.unwrap e with
Ast0.Dots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
+ (*don't recurse because whencode hasn't been processed by context_neg*)
update_mc mcodekind e; Ast0.rewrap e (Ast0.Dots(mcode d,whencode))
| Ast0.Circles(d,whencode) ->
update_mc mcodekind e; Ast0.rewrap e (Ast0.Circles(mcode d,whencode))
let mcodekind = Ast0.get_mcodekind_ref e in
match Ast0.unwrap e with
Ast0.Idots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
+ (*don't recurse because whencode hasn't been processed by context_neg*)
update_mc mcodekind e; Ast0.rewrap e (Ast0.Idots(mcode d,whencode))
| _ -> donothing r k e in
Ast0.MIXED(mc) | Ast0.CONTEXT(mc) ->
(match !mc with
(Ast.NOTHING,_,_) ->
- mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info));
+ mcodekind :=
+ Ast0.MINUS(ref(Ast.NOREPLACEMENT,Ast0.default_token_info));
e
| _ -> failwith "make_minus: unexpected befaft")
(* code already processed by an enclosing iso *)
| Ast0.PLUS count ->
(* this function is used elsewhere where we need to rebuild the
indices, and so we allow PLUS code as well *)
- Ast0.PLUS count in
+ Ast0.PLUS count in
let mcode (term,arity,info,mcodekind,pos,adj) =
let info =
Common.Right (List.assoc (term name) mv_bindings)
(* mv_bindings is for the fresh metavariables that are introduced by the
-isomorphism *)
+ isomorphism *)
let instantiate bindings mv_bindings =
let mcode x =
- match Ast0.get_pos x with
- Ast0.MetaPos(name,_,_) ->
- (try
- match lookup name bindings mv_bindings with
- Common.Left(Ast0.MetaPosTag(id)) -> Ast0.set_pos id x
- | _ -> failwith "not possible"
- with Not_found -> Ast0.set_pos Ast0.NoMetaPos x)
- | _ -> x in
+ let (hidden,others) =
+ List.partition
+ (function Ast0.HiddenVarTag _ -> true | _ -> false)
+ (Ast0.get_pos x) in
+ let new_names =
+ match hidden with
+ [Ast0.HiddenVarTag([Ast0.MetaPosTag(Ast0.MetaPos (name,_,_))])] ->
+ (try
+ (* not at all sure that this is good enough *)
+ match lookup name bindings mv_bindings with
+ Common.Left(Ast0.HiddenVarTag(ids)) -> ids
+ | _ -> failwith "not possible"
+ with Not_found ->
+ (*can't fail because checks_needed could be false?*)
+ [])
+ | [] -> [] (* no hidden metavars allowed *)
+ | _ -> failwith "badly compiled mcode" in
+ Ast0.set_pos (new_names@others) x in
let donothing r k e = k e in
(* cases where metavariables can occur *)
let identfn r k e =
let e = k e in
match Ast0.unwrap e with
- Ast0.MetaId(name,constraints,pure) ->
+ Ast0.MetaId(name,constraints,seed,pure) ->
(rebuild_mcode None).VT0.rebuilder_rec_ident
(match lookup name bindings mv_bindings with
Common.Left(Ast0.IdentTag(id)) -> id
| Common.Right(new_mv) ->
Ast0.rewrap e
(Ast0.MetaId
- (Ast0.set_mcode_data new_mv name,constraints,pure)))
+ (Ast0.set_mcode_data new_mv name,constraints,seed,pure)))
| Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
| Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
| _ -> e in
Ast0.MetaParamList(name,lenname,pure) ->
failwith "meta_param_list in iso not supported"
(*match lookup name bindings mv_bindings with
- Common.Left(Ast0.DotsParamTag(param)) ->
+ Common.Left(Ast0.DotsParamTag(param)) ->
(match same_dots param with
- Some l -> l
+ Some l -> l
| None -> failwith "dots put in incompatible context")
- | Common.Left(Ast0.ParamTag(param)) -> [param]
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
+ | Common.Left(Ast0.ParamTag(param)) -> [param]
+ | Common.Left(_) -> failwith "not possible 1"
+ | Common.Right(new_mv) ->
failwith "MetaExprList in SP not supported"*)
| _ -> [r.VT0.rebuilder_rec_parameter x])
| x::xs -> (r.VT0.rebuilder_rec_parameter x)::(plist r same_dots xs) in
let rec renamer = function
Type_cocci.MetaType(name,keep,inherited) ->
(match
- lookup (name,(),(),(),None,-1) bindings mv_bindings
+ lookup (name,(),(),(),None,-1)
+ bindings mv_bindings
with
Common.Left(Ast0.TypeCTag(t)) ->
Ast0.ast0_type_to_type t
let nomodif = function
Ast0.MINUS(x) ->
(match !x with
- ([],_) -> true
+ (Ast.NOREPLACEMENT,_) -> true
| _ -> false)
| Ast0.CONTEXT(x) | Ast0.MIXED(x) ->
(match !x with
surely has no + code) *)
match (newop,oldop) with
(Ast0.MINUS(x1),Ast0.MINUS(x2)) -> nomodif oldop
- | (Ast0.CONTEXT(x1),Ast0.CONTEXT(x2)) -> nomodif oldop
- | (Ast0.MIXED(x1),Ast0.MIXED(x2)) -> nomodif oldop
- | _ -> false in
+ | (Ast0.CONTEXT(x1),Ast0.CONTEXT(x2)) -> nomodif oldop
+ | (Ast0.MIXED(x1),Ast0.MIXED(x2)) -> nomodif oldop
+ | _ -> false in
if was_meta
then
let idcont x = x in
| Ast0.Binary(e1,op,e2) when
same_modif
(Ast0.get_mcode_mcodekind unop)
- (Ast0.get_mcode_mcodekind op)->
+ (Ast0.get_mcode_mcodekind op) ->
let reb nop =
Ast0.rewrap_mcode op (Ast.Logical(nop)) in
let k1 x = k (Ast0.rewrap e x) in
| Ast.Logical(Ast.NotEq) ->
k1 (Ast0.Binary(e1,reb Ast.Eq,e2))
| Ast.Logical(Ast.AndLog) ->
- k1 (Ast0.Binary(negate e1 e1 idcont,
+ k1 (Ast0.Binary(negate_reb e e1 idcont,
reb Ast.OrLog,
- negate e2 e2 idcont))
+ negate_reb e e2 idcont))
| Ast.Logical(Ast.OrLog) ->
- k1 (Ast0.Binary(negate e1 e1 idcont,
+ k1 (Ast0.Binary(negate_reb e e1 idcont,
reb Ast.AndLog,
- negate e2 e2 idcont))
+ negate_reb e e2 idcont))
| _ ->
Ast0.rewrap e
(Ast0.Unary(k res,
Ast0.rewrap_mcode op Ast.Not)))
| Ast0.DisjExpr(lp,exps,mids,rp) ->
(* use res because it is the transformed argument *)
- let exps = List.map (function e -> negate e e k) exps in
+ let exps =
+ List.map (function e1 -> negate_reb e e1 k) exps in
Ast0.rewrap res (Ast0.DisjExpr(lp,exps,mids,rp))
| _ ->
(*use e, because this might be the toplevel expression*)
(Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not))
else
Ast0.rewrap e
- (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not)) in
+ (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not))
+ and negate_reb e e1 k =
+ (* used when ! is propagated to multiple places, to avoid
+ duplicating mcode cells *)
+ let start_line =
+ Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
+ (rebuild_mcode start_line).VT0.rebuilder_rec_expression
+ (negate e e1 k) in
negate e exp idcont
else e
| _ -> e)
let declfn r k e =
let e = k e in
match Ast0.unwrap e with
- Ast0.Ddots(d,_) ->
+ Ast0.MetaDecl(name,pure) ->
+ (rebuild_mcode None).VT0.rebuilder_rec_declaration
+ (match lookup name bindings mv_bindings with
+ Common.Left(Ast0.DeclTag(d)) -> d
+ | Common.Left(_) -> failwith "not possible 1"
+ | Common.Right(new_mv) ->
+ Ast0.rewrap e
+ (Ast0.MetaDecl(Ast0.set_mcode_data new_mv name, pure)))
+ | Ast0.MetaField(name,pure) ->
+ (rebuild_mcode None).VT0.rebuilder_rec_declaration
+ (match lookup name bindings mv_bindings with
+ Common.Left(Ast0.DeclTag(d)) -> d
+ | Common.Left(_) -> failwith "not possible 1"
+ | Common.Right(new_mv) ->
+ Ast0.rewrap e
+ (Ast0.MetaField(Ast0.set_mcode_data new_mv name, pure)))
+ | Ast0.MetaFieldList(name,lenname,pure) ->
+ failwith "metafieldlist not supported"
+ | Ast0.Ddots(d,_) ->
(try
(match List.assoc (dot_term d) bindings with
Ast0.DeclTag(exp) -> Ast0.rewrap e (Ast0.Ddots(d,Some exp))
let stmtfn r k e =
let e = k e in
match Ast0.unwrap e with
- Ast0.MetaStmt(name,pure) ->
+ Ast0.MetaStmt(name,pure) ->
(rebuild_mcode None).VT0.rebuilder_rec_statement
(match lookup name bindings mv_bindings with
Common.Left(Ast0.StmtTag(stm)) -> stm
Ast0.MINUS(emc) ->
emc :=
(match (!mc,!emc) with
- (([],_),(x,t)) | ((x,_),([],t)) -> (x,t)
+ ((Ast.NOREPLACEMENT,_),(x,t))
+ | ((x,_),(Ast.NOREPLACEMENT,t)) -> (x,t)
| _ -> failwith "how can we combine minuses?")
| _ -> failwith "not possible 6")
| Ast0.CONTEXT(mc) ->
| (Ast.BEFOREAFTER(b,a1,it1),Ast.AFTER(a2,it2)) ->
Ast.BEFOREAFTER(b,a2@a1,Ast.lub_count it1 it2)
| (Ast.BEFOREAFTER(b1,a1,it1),Ast.BEFOREAFTER(b2,a2,it2)) ->
- Ast.BEFOREAFTER(b1@b2,a2@a1,Ast.lub_count it1 it2) in
+ Ast.BEFOREAFTER(b1@b2,a2@a1,Ast.lub_count it1 it2) in
emc := (merged,tb,ta)
| Ast0.MINUS(emc) ->
let (anything_bef_aft,_,_) = !mc in
let (anythings,t) = !emc in
- emc :=
- (match anything_bef_aft with
- Ast.BEFORE(b,_) -> (b@anythings,t)
- | Ast.AFTER(a,_) -> (anythings@a,t)
- | Ast.BEFOREAFTER(b,a,_) -> (b@anythings@a,t)
- | Ast.NOTHING -> (anythings,t))
+ (match (anything_bef_aft,anythings) with
+ (Ast.BEFORE(b1,it1),Ast.NOREPLACEMENT) ->
+ emc := (Ast.REPLACEMENT(b1,it1),t)
+ | (Ast.AFTER(a1,it1),Ast.NOREPLACEMENT) ->
+ emc := (Ast.REPLACEMENT(a1,it1),t)
+ | (Ast.BEFOREAFTER(b1,a1,it1),Ast.NOREPLACEMENT) ->
+ emc := (Ast.REPLACEMENT(b1@a1,it1),t)
+ | (Ast.NOTHING,Ast.NOREPLACEMENT) ->
+ emc := (Ast.NOREPLACEMENT,t)
+ | (Ast.BEFORE(b1,it1),Ast.REPLACEMENT(a2,it2)) ->
+ emc := (Ast.REPLACEMENT(b1@a2,Ast.lub_count it1 it2),t)
+ | (Ast.AFTER(a1,it1),Ast.REPLACEMENT(a2,it2)) ->
+ emc := (Ast.REPLACEMENT(a2@a1,Ast.lub_count it1 it2),t)
+ | (Ast.BEFOREAFTER(b1,a1,it1),Ast.REPLACEMENT(a2,it2)) ->
+ emc := (Ast.REPLACEMENT(b1@a2@a1,Ast.lub_count it1 it2),t)
+ | (Ast.NOTHING,Ast.REPLACEMENT(a2,it2)) -> ()) (* no change *)
| Ast0.MIXED(_) -> failwith "how did this become mixed?"
| _ -> failwith "not possible 7")
| Ast0.MIXED(_) -> failwith "not possible 8"
if !Flag.sgrep_mode2
then e (* no plus code, can cause a "not possible" error, so just avoid it *)
else
- let e =
- match Ast0.get_mcodekind model with
- Ast0.MINUS(mc) -> minusify e
- | Ast0.CONTEXT(mc) -> e
- | _ -> failwith "not possible: copy_plus\n" in
- merge_plus (Ast0.get_mcodekind model) (Ast0.get_mcodekind e);
- e
+ begin
+ let e =
+ match Ast0.get_mcodekind model with
+ Ast0.MINUS(mc) -> minusify e
+ | Ast0.CONTEXT(mc) -> e
+ | _ -> failwith "not possible: copy_plus\n" in
+ merge_plus (Ast0.get_mcodekind model) (Ast0.get_mcodekind e);
+ e
+ end
let copy_minus printer minusify model e =
match Ast0.get_mcodekind model with
"_"^s^"_"^(string_of_int ct)
let get_name = function
- Ast.MetaIdDecl(ar,nm) ->
+ Ast.MetaMetaDecl(ar,nm) ->
+ (nm,function nm -> Ast.MetaMetaDecl(ar,nm))
+ | Ast.MetaIdDecl(ar,nm) ->
(nm,function nm -> Ast.MetaIdDecl(ar,nm))
| Ast.MetaFreshIdDecl(nm,seed) ->
(nm,function nm -> Ast.MetaFreshIdDecl(nm,seed))
(nm,function nm -> Ast.MetaTypeDecl(ar,nm))
| Ast.MetaInitDecl(ar,nm) ->
(nm,function nm -> Ast.MetaInitDecl(ar,nm))
+ | Ast.MetaInitListDecl(ar,nm,nm1) ->
+ (nm,function nm -> Ast.MetaInitListDecl(ar,nm,nm1))
| Ast.MetaListlenDecl(nm) ->
failwith "should not be rebuilt"
| Ast.MetaParamDecl(ar,nm) ->
(nm,function nm -> Ast.MetaLocalIdExpDecl(ar,nm,ty))
| Ast.MetaExpListDecl(ar,nm,nm1) ->
(nm,function nm -> Ast.MetaExpListDecl(ar,nm,nm1))
+ | Ast.MetaDeclDecl(ar,nm) ->
+ (nm,function nm -> Ast.MetaDeclDecl(ar,nm))
+ | Ast.MetaFieldListDecl(ar,nm,nm1) ->
+ (nm,function nm -> Ast.MetaFieldListDecl(ar,nm,nm1))
+ | Ast.MetaFieldDecl(ar,nm) ->
+ (nm,function nm -> Ast.MetaFieldDecl(ar,nm))
| Ast.MetaStmDecl(ar,nm) ->
(nm,function nm -> Ast.MetaStmDecl(ar,nm))
| Ast.MetaStmListDecl(ar,nm) ->
let do_nothing x = x
let mkdisj matcher metavars alts e instantiater mkiso disj_maker minusify
- rebuild_mcodes name printer extra_plus update_others =
- let call_instantiate bindings mv_bindings alts =
+ rebuild_mcodes name printer extra_plus update_others has_context =
+ let call_instantiate bindings mv_bindings alts pattern has_context =
List.concat
(List.map
(function (a,_,_,_) ->
(* no need to create duplicates when the bindings have no effect *)
(List.map
(function bindings ->
- Ast0.set_iso
- (copy_plus printer minusify e
- (extra_plus e
- (instantiater bindings mv_bindings
- (rebuild_mcodes a))))
+ let instantiated =
+ instantiater bindings mv_bindings (rebuild_mcodes a) in
+ let plus_added =
+ if has_context (* ie if pat is not just a metavara *)
+ then
+ copy_plus printer minusify e (extra_plus e instantiated)
+ else instantiated in
+ if pattern = a
+ then plus_added
+ else (* iso tracking *)
+ Ast0.set_iso plus_added
((name,mkiso a)::(Ast0.get_iso e))) (* keep count, not U *)
bindings))
alts) in
make_new_metavars metavars (nub(List.concat bindings)) in
Common.Right
(new_metavars,
- call_instantiate bindings mv_bindings all_alts))) in
+ call_instantiate bindings mv_bindings all_alts pattern
+ (has_context pattern)))) in
let rec outer_loop prev_ecount prev_icount prev_dcount = function
[] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
| (alts::rest) as all_alts ->
{ Ast0.pos_info = new_pos_info;
Ast0.attachable_start = false; Ast0.attachable_end = false;
Ast0.mcode_start = []; Ast0.mcode_end = [];
- Ast0.strings_before = []; Ast0.strings_after = [] } in
+ Ast0.strings_before = []; Ast0.strings_after = [];
+ Ast0.isSymbolIdent = false; } in
Ast0.make_mcode_info "(" info
let disj_ender lst =
{ Ast0.pos_info = new_pos_info;
Ast0.attachable_start = false; Ast0.attachable_end = false;
Ast0.mcode_start = []; Ast0.mcode_end = [];
- Ast0.strings_before = []; Ast0.strings_after = [] } in
+ Ast0.strings_before = []; Ast0.strings_after = [];
+ Ast0.isSymbolIdent = false; } in
Ast0.make_mcode_info ")" info
let disj_mid _ = Ast0.make_mcode "|"
make_disj_type make_minus.VT0.rebuilder_rec_typeC
(rebuild_mcode start_line).VT0.rebuilder_rec_typeC
name Unparse_ast0.typeC extra_copy_other_plus do_nothing
+ (function x ->
+ match Ast0.unwrap x with Ast0.MetaType _ -> false | _ -> true)
| _ -> (0,[],e)
(make_disj_expr e)
make_minus.VT0.rebuilder_rec_expression
(rebuild_mcode start_line).VT0.rebuilder_rec_expression
- name Unparse_ast0.expression extra_copy_other_plus update_others in
+ name Unparse_ast0.expression extra_copy_other_plus update_others
+ (function x ->
+ match Ast0.unwrap x with
+ Ast0.MetaExpr _ | Ast0.MetaExprList _ | Ast0.MetaErr _ -> false
+ | _ -> true)
+ in
match alts with
- (Ast0.ExprTag(_)::_)::_ -> process do_nothing
+ (Ast0.ExprTag(_)::r)::rs ->
+ (* hack to accomodate ToTestExpression case, where the first pattern is
+ a normal expression, but the others are test expressions *)
+ let others = r @ (List.concat rs) in
+ let is_test = function Ast0.TestExprTag(_) -> true | _ -> false in
+ if List.for_all is_test others then process Ast0.set_test_exp
+ else if List.exists is_test others then failwith "inconsistent iso"
+ else process do_nothing
| (Ast0.ArgExprTag(_)::_)::_ when Ast0.get_arg_exp e -> process do_nothing
| (Ast0.TestExprTag(_)::_)::_ when Ast0.get_test_pos e ->
process Ast0.set_test_exp
make_minus.VT0.rebuilder_rec_declaration
(rebuild_mcode start_line).VT0.rebuilder_rec_declaration
name Unparse_ast0.declaration extra_copy_other_plus do_nothing
+ (function _ -> true (* no metavars *))
| _ -> (0,[],e)
let transform_stmt (metavars,alts,name) e =
make_disj_stmt make_minus.VT0.rebuilder_rec_statement
(rebuild_mcode start_line).VT0.rebuilder_rec_statement
name (Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
+ (function x ->
+ match Ast0.unwrap x with
+ Ast0.MetaStmt _ | Ast0.MetaStmtList _ -> false
+ | _ -> true)
| _ -> (0,[],e)
(* sort of a hack, because there is no disj at top level *)
let transform_top (metavars,alts,name) e =
match Ast0.unwrap e with
- Ast0.DECL(declstm) ->
+ Ast0.NONDECL(declstm) ->
(try
let strip alts =
List.map
| _ -> raise (Failure "")))
alts in
let (count,mv,s) = transform_stmt (metavars,strip alts,name) declstm in
- (count,mv,Ast0.rewrap e (Ast0.DECL(s)))
+ (count,mv,Ast0.rewrap e (Ast0.NONDECL(s)))
with Failure _ -> (0,[],e))
| Ast0.CODE(stmts) ->
let (count,mv,res) =
match alts with
(Ast0.DotsStmtTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
+ (* start line is given to any leaves in the iso code *)
let start_line =
Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
let alts =
make_minus.VT0.rebuilder_rec_statement_dots x)
(rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
name Unparse_ast0.statement_dots extra_copy_other_plus do_nothing
+ (function _ -> true)
| _ -> (0,[],stmts) in
(count,mv,Ast0.rewrap e (Ast0.CODE res))
| _ -> (0,[],e)
| Ast0.IsoWhenTag(_) | Ast0.IsoWhenTTag(_) | Ast0.IsoWhenFTag(_) ->
failwith "only for isos within iso phase"
| Ast0.MetaPosTag(p) -> Ast0.MetaPosTag(p)
+ | Ast0.HiddenVarTag(p) -> Ast0.HiddenVarTag(p) (* not sure it is possible *)
(* --------------------------------------------------------------------- *)
HCoop / bpt / coccinelle.git / blobdiff