(*
-* Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen
+* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
* This file is part of Coccinelle.
*
module Ast = Ast_cocci
module Ast0 = Ast0_cocci
module V0 = Visitor_ast0
+module VT0 = Visitor_ast0_types
let current_rule = ref ""
{(Ast0.wrap (Ast0.unwrap x)) with
Ast0.mcodekind = ref Ast0.PLUS;
Ast0.true_if_test = x.Ast0.true_if_test} in
- V0.rebuilder
+ V0.flat_rebuilder
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
donothing donothing donothing donothing donothing donothing
donothing donothing donothing donothing donothing donothing donothing
donothing donothing
| (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
failwith "not a possible variable binding"
| (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) ->
- (strip_info.V0.rebuilder_statement_dots d1) =
- (strip_info.V0.rebuilder_statement_dots d2)
+ (strip_info.VT0.rebuilder_rec_statement_dots d1) =
+ (strip_info.VT0.rebuilder_rec_statement_dots d2)
| (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) ->
failwith "not a possible variable binding"
| (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) ->
failwith "not a possible variable binding"
| (Ast0.IdentTag(d1),Ast0.IdentTag(d2)) ->
- (strip_info.V0.rebuilder_ident d1) = (strip_info.V0.rebuilder_ident d2)
+ (strip_info.VT0.rebuilder_rec_ident d1) = (strip_info.VT0.rebuilder_rec_ident d2)
| (Ast0.ExprTag(d1),Ast0.ExprTag(d2)) ->
- (strip_info.V0.rebuilder_expression d1) =
- (strip_info.V0.rebuilder_expression d2)
+ (strip_info.VT0.rebuilder_rec_expression d1) =
+ (strip_info.VT0.rebuilder_rec_expression d2)
| (Ast0.ArgExprTag(_),_) | (_,Ast0.ArgExprTag(_)) ->
failwith "not possible - only in isos1"
| (Ast0.TestExprTag(_),_) | (_,Ast0.TestExprTag(_)) ->
failwith "not possible - only in isos1"
| (Ast0.TypeCTag(d1),Ast0.TypeCTag(d2)) ->
- (strip_info.V0.rebuilder_typeC d1) =
- (strip_info.V0.rebuilder_typeC d2)
+ (strip_info.VT0.rebuilder_rec_typeC d1) =
+ (strip_info.VT0.rebuilder_rec_typeC d2)
| (Ast0.InitTag(d1),Ast0.InitTag(d2)) ->
- (strip_info.V0.rebuilder_initialiser d1) =
- (strip_info.V0.rebuilder_initialiser d2)
+ (strip_info.VT0.rebuilder_rec_initialiser d1) =
+ (strip_info.VT0.rebuilder_rec_initialiser d2)
| (Ast0.ParamTag(d1),Ast0.ParamTag(d2)) ->
- (strip_info.V0.rebuilder_parameter d1) =
- (strip_info.V0.rebuilder_parameter d2)
+ (strip_info.VT0.rebuilder_rec_parameter d1) =
+ (strip_info.VT0.rebuilder_rec_parameter d2)
| (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) ->
- (strip_info.V0.rebuilder_declaration d1) =
- (strip_info.V0.rebuilder_declaration d2)
+ (strip_info.VT0.rebuilder_rec_declaration d1) =
+ (strip_info.VT0.rebuilder_rec_declaration d2)
| (Ast0.StmtTag(d1),Ast0.StmtTag(d2)) ->
- (strip_info.V0.rebuilder_statement d1) =
- (strip_info.V0.rebuilder_statement d2)
+ (strip_info.VT0.rebuilder_rec_statement d1) =
+ (strip_info.VT0.rebuilder_rec_statement d2)
| (Ast0.CaseLineTag(d1),Ast0.CaseLineTag(d2)) ->
- (strip_info.V0.rebuilder_case_line d1) =
- (strip_info.V0.rebuilder_case_line d2)
+ (strip_info.VT0.rebuilder_rec_case_line d1) =
+ (strip_info.VT0.rebuilder_rec_case_line d2)
| (Ast0.TopTag(d1),Ast0.TopTag(d2)) ->
- (strip_info.V0.rebuilder_top_level d1) =
- (strip_info.V0.rebuilder_top_level d2)
+ (strip_info.VT0.rebuilder_rec_top_level d1) =
+ (strip_info.VT0.rebuilder_rec_top_level d2)
| (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_)) ->
failwith "only for isos within iso phase"
| (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
| _ -> false
let term (var1,_,_,_,_) = var1
-let dot_term (var1,_,info,_,_) = ("", var1 ^ (string_of_int info.Ast0.offset))
+let dot_term (var1,_,info,_,_) =
+ ("", var1 ^ (string_of_int info.Ast0.pos_info.Ast0.offset))
type reason =
| NonMatch
| Braces of Ast0.statement
| Position of string * string
+ | TypeMatch of reason list
-let interpret_reason name line reason printer =
+let rec interpret_reason name line reason printer =
Printf.printf
"warning: iso %s does not match the code below on line %d\n" name line;
printer(); Format.print_newline();
| Position(rule,name) ->
Printf.printf "position variable %s.%s conflicts with an isomorphism\n"
rule name;
+ | TypeMatch reason_list ->
+ List.iter (function r -> interpret_reason name line r printer)
+ reason_list
| _ -> failwith "not possible"
type 'a either = OK of 'a | Fail of reason
let pure_sp_code =
let bind = Ast0.lub_pure in
let option_default = Ast0.Context in
- let pure_mcodekind = function
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) -> Ast0.PureContext
- | _ -> Ast0.Context)
- | Ast0.MINUS(mc) ->
- (match !mc with ([],_) -> Ast0.Pure | _ -> Ast0.Impure)
- | _ -> Ast0.Impure in
+ let pure_mcodekind mc =
+ if !Flag.sgrep_mode2
+ then Ast0.PureContext
+ else
+ match mc with
+ Ast0.CONTEXT(mc) ->
+ (match !mc with
+ (Ast.NOTHING,_,_) -> Ast0.PureContext
+ | _ -> Ast0.Context)
+ | Ast0.MINUS(mc) ->
+ (match !mc with ([],_) -> Ast0.Pure | _ -> Ast0.Impure)
+ | _ -> Ast0.Impure in
let donothing r k e =
bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e) in
Ast0.MetaType(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.Impure) in
+
let param r k p =
bind (bind (pure_mcodekind (Ast0.get_mcodekind p)) (k p))
(match Ast0.unwrap p with
Ast0.MetaStmt(name,pure) | Ast0.MetaStmtList(name,pure) -> pure
| _ -> Ast0.Impure) in
- V0.combiner bind option_default
+ V0.flat_combiner bind option_default
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
donothing donothing donothing donothing donothing donothing
- ident expression typeC donothing param donothing stmt donothing
+ ident expression typeC init param donothing stmt donothing
donothing in
let add_pure_list_binding name pure is_pure builder1 builder2 lst =
match Ast0.unwrap sl with
Ast0.MetaStmtList(name,pure) ->
add_pure_list_binding name pure
- pure_sp_code.V0.combiner_statement
+ pure_sp_code.VT0.combiner_rec_statement
(function lst -> Ast0.StmtTag(List.hd lst))
(function lst -> Ast0.DotsStmtTag(build_dots builder lst))
lst
let rec match_ident pattern id =
match Ast0.unwrap pattern with
Ast0.MetaId(name,_,pure) ->
- (add_pure_binding name pure pure_sp_code.V0.combiner_ident
+ (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"
| Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
(match expty with
Some expty ->
let tyname = Ast0.rewrap_mcode name tyname in
- (function bindings ->
- let attempts =
- List.map
- (function expty ->
- (try
- conjunct_bindings
- (add_pure_binding tyname Ast0.Impure
- (function _ -> Ast0.Impure)
- (function ty -> Ast0.TypeCTag ty)
- (Ast0.rewrap expr
- (Ast0.reverse_type expty)))
- (add_pure_binding name pure
- pure_sp_code.V0.combiner_expression
- (function expr -> Ast0.ExprTag expr)
- expr)
- bindings
- with Ast0.TyConv ->
- Printf.printf "warning: unconvertible type";
- return false bindings))
- expty in
- match
- List.concat
- (List.map (function Fail _ -> [] | OK x -> x)
- attempts)
- with
- [] -> Fail NonMatch
- | x -> OK x)
- | _ ->
+ conjunct_bindings
+ (add_pure_binding name pure
+ pure_sp_code.VT0.combiner_rec_expression
+ (function expr -> Ast0.ExprTag expr)
+ expr)
+ (function bindings ->
+ let attempts =
+ List.map
+ (function expty ->
+ (try
+ add_pure_binding tyname Ast0.Impure
+ (function _ -> Ast0.Impure)
+ (function ty -> Ast0.TypeCTag ty)
+ (Ast0.rewrap expr
+ (Ast0.reverse_type expty))
+ bindings
+ with Ast0.TyConv ->
+ Printf.printf
+ "warning: unconvertible type";
+ return false bindings))
+ expty in
+ if List.exists
+ (function Fail _ -> false | OK x -> true)
+ attempts
+ then
+ (* not sure why this is ok. can there be more
+ than one OK? *)
+ OK (List.concat
+ (List.map
+ (function Fail _ -> [] | OK x -> x)
+ attempts))
+ else
+ Fail
+ (TypeMatch
+ (List.map
+ (function
+ Fail r -> r
+ | OK x -> failwith "not possible")
+ attempts)))
+ | _ ->
(*Printf.printf
"warning: type metavar can only match one type";*)
return false)
if List.exists (function t -> Type_cocci.compatible t expty) ts
then
add_pure_binding name pure
- pure_sp_code.V0.combiner_expression
+ pure_sp_code.VT0.combiner_rec_expression
(function expr -> Ast0.ExprTag expr)
expr
else return false
| None ->
- add_pure_binding name pure pure_sp_code.V0.combiner_expression
+ add_pure_binding name pure pure_sp_code.VT0.combiner_rec_expression
(function expr -> Ast0.ExprTag expr)
expr
else return false
| (_,Ast0.UniqueExp(expb)) -> match_expr pattern expb
| _ -> return false
else return_false (ContextRequired (Ast0.ExprTag expr))
-
+
(* the special case for function types prevents the eg T X; -> T X = E; iso
from applying, which doesn't seem very relevant, but it also avoids a
mysterious bug that is obtained with eg int attach(...); *)
(match Ast0.unwrap t with
Ast0.FunctionType(tya,lp1a,paramsa,rp1a) -> return false
| _ ->
- add_pure_binding name pure pure_sp_code.V0.combiner_typeC
+ add_pure_binding name pure pure_sp_code.VT0.combiner_rec_typeC
(function ty -> Ast0.TypeCTag ty)
t)
| up ->
then
conjunct_bindings (check_mcode cva cvb) (match_typeC tya tyb)
else return false
- | (Ast0.BaseType(tya,signa),Ast0.BaseType(tyb,signb)) ->
- if (mcode_equal tya tyb &&
- bool_match_option mcode_equal signa signb)
+ | (Ast0.BaseType(tya,stringsa),Ast0.BaseType(tyb,stringsb)) ->
+ if tya = tyb
then
- conjunct_bindings (check_mcode tya tyb)
- (match_option check_mcode signa signb)
+ match_list check_mcode
+ (function _ -> false) (function _ -> failwith "")
+ stringsa stringsb
else return false
- | (Ast0.ImplicitInt(signa),Ast0.ImplicitInt(signb)) ->
+ | (Ast0.Signed(signa,tya),Ast0.Signed(signb,tyb)) ->
if mcode_equal signa signb
- then check_mcode signa signb
+ then
+ conjunct_bindings (check_mcode signa signb)
+ (match_option match_typeC tya tyb)
else return false
| (Ast0.Pointer(tya,star1),Ast0.Pointer(tyb,star)) ->
conjunct_bindings (check_mcode star1 star) (match_typeC tya tyb)
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.StructUnionName(kinda,Some namea),
Ast0.StructUnionName(kindb,Some nameb)) ->
if mcode_equal kinda kindb
| (_,Ast0.UniqueType(tyb)) -> match_typeC pattern tyb
| _ -> return false
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
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
match_decl pattern declb
| _ -> return false
else return_false (ContextRequired (Ast0.DeclTag d))
-
+
and match_init pattern i =
- if not(checks_needed) or not(context_required) or is_context i
- then
- match (Ast0.unwrap pattern,Ast0.unwrap i) with
- (Ast0.InitExpr(expa),Ast0.InitExpr(expb)) ->
- match_expr expa expb
- | (Ast0.InitList(lb1,initlista,rb1),Ast0.InitList(lb,initlistb,rb)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_dots match_init no_list do_nolist_match
- initlista initlistb]
- | (Ast0.InitGccDotName(d1,namea,e1,inia),
- Ast0.InitGccDotName(d,nameb,e,inib)) ->
- conjunct_many_bindings
- [check_mcode d1 d; check_mcode e1 e;
- match_ident namea nameb; match_init inia inib]
- | (Ast0.InitGccName(namea,c1,inia),Ast0.InitGccName(nameb,c,inib)) ->
- conjunct_many_bindings
- [check_mcode c1 c; match_ident namea nameb;
- match_init inia inib]
- | (Ast0.InitGccIndex(lb1,expa,rb1,e1,inia),
- Ast0.InitGccIndex(lb2,expb,rb2,e2,inib)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb2; check_mcode rb1 rb2; check_mcode e1 e2;
- match_expr expa expb; match_init inia inib]
- | (Ast0.InitGccRange(lb1,exp1a,d1,exp2a,rb1,e1,inia),
- Ast0.InitGccRange(lb2,exp1b,d2,exp2b,rb2,e2,inib)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb2; check_mcode d1 d2;
- check_mcode rb1 rb2; check_mcode e1 e2;
- match_expr exp1a exp1b; match_expr exp2a exp2b;
- match_init inia inib]
- | (Ast0.IComma(c1),Ast0.IComma(c)) -> check_mcode c1 c
- | (Ast0.Idots(d1,None),Ast0.Idots(d,None)) -> check_mcode d1 d
- | (Ast0.Idots(id,None),Ast0.Idots(d,Some wc)) ->
- conjunct_bindings (check_mcode id d)
+ match Ast0.unwrap pattern with
+ Ast0.MetaInit(name,pure) ->
+ add_pure_binding name pure pure_sp_code.VT0.combiner_rec_initialiser
+ (function ini -> Ast0.InitTag ini)
+ i
+ | up ->
+ if not(checks_needed) or not(context_required) or is_context i
+ then
+ 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))
+ ->
+ conjunct_many_bindings
+ [check_mcode lb1 lb; check_mcode rb1 rb;
+ match_dots match_init no_list do_nolist_match
+ initlista initlistb]
+ | (Ast0.InitGccExt(designators1,e1,inia),
+ Ast0.InitGccExt(designators2,e2,inib)) ->
+ conjunct_many_bindings
+ [match_list match_designator
+ (function _ -> false) (function _ -> failwith "")
+ designators1 designators2;
+ check_mcode e1 e2;
+ match_init inia inib]
+ | (Ast0.InitGccName(namea,c1,inia),Ast0.InitGccName(nameb,c,inib)) ->
+ conjunct_many_bindings
+ [check_mcode c1 c; match_ident namea nameb;
+ match_init inia inib]
+ | (Ast0.IComma(c1),Ast0.IComma(c)) -> check_mcode c1 c
+ | (Ast0.Idots(d1,None),Ast0.Idots(d,None)) -> check_mcode d1 d
+ | (Ast0.Idots(id,None),Ast0.Idots(d,Some wc)) ->
+ conjunct_bindings (check_mcode id d)
(* hope that mcode of edots is unique somehow *)
- (let (_,idots_whencode_allowed,_) = whencode_allowed in
- if idots_whencode_allowed
- then add_dot_binding id (Ast0.InitTag wc)
- else
- (Printf.printf "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Idots(_,Some _),_) ->
- failwith "whencode not allowed in a pattern2"
- | (Ast0.OptIni(ia),Ast0.OptIni(ib))
- | (Ast0.UniqueIni(ia),Ast0.UniqueIni(ib)) -> match_init ia ib
- | (_,Ast0.OptIni(ib))
- | (_,Ast0.UniqueIni(ib)) -> match_init pattern ib
- | _ -> return false
- else return_false (ContextRequired (Ast0.InitTag i))
-
+ (let (_,idots_whencode_allowed,_) = whencode_allowed in
+ if idots_whencode_allowed
+ then add_dot_binding id (Ast0.InitTag wc)
+ else
+ (Printf.printf
+ "warning: not applying iso because of whencode";
+ return false))
+ | (Ast0.Idots(_,Some _),_) ->
+ failwith "whencode not allowed in a pattern2"
+ | (Ast0.OptIni(ia),Ast0.OptIni(ib))
+ | (Ast0.UniqueIni(ia),Ast0.UniqueIni(ib)) -> match_init ia ib
+ | (_,Ast0.OptIni(ib))
+ | (_,Ast0.UniqueIni(ib)) -> match_init pattern ib
+ | _ -> return false
+ else return_false (ContextRequired (Ast0.InitTag i))
+
+ and match_designator pattern d =
+ match (pattern,d) with
+ (Ast0.DesignatorField(dota,ida),Ast0.DesignatorField(dotb,idb)) ->
+ conjunct_bindings (check_mcode dota dotb) (match_ident ida idb)
+ | (Ast0.DesignatorIndex(lba,expa,rba),
+ Ast0.DesignatorIndex(lbb,expb,rbb)) ->
+ conjunct_many_bindings
+ [check_mcode lba lbb; match_expr expa expb;
+ check_mcode rba rbb]
+ | (Ast0.DesignatorRange(lba,mina,dotsa,maxa,rba),
+ Ast0.DesignatorRange(lbb,minb,dotsb,maxb,rbb)) ->
+ conjunct_many_bindings
+ [check_mcode lba lbb; match_expr mina minb;
+ check_mcode dotsa dotsb; match_expr maxa maxb;
+ check_mcode rba rbb]
+ | _ -> return false
+
and match_param pattern p =
match Ast0.unwrap pattern with
Ast0.MetaParam(name,pure) ->
- add_pure_binding name pure pure_sp_code.V0.combiner_parameter
+ add_pure_binding name pure pure_sp_code.VT0.combiner_rec_parameter
(function p -> Ast0.ParamTag p)
p
| Ast0.MetaParamList(name,_,pure) -> failwith "metaparamlist not supported"
| (_,Ast0.UniqueParam(paramb)) -> match_param pattern paramb
| _ -> return false
else return_false (ContextRequired (Ast0.ParamTag p))
-
+
and match_statement pattern s =
match Ast0.unwrap pattern with
Ast0.MetaStmt(name,pure) ->
Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) ->
return false (* ... is not a single statement *)
| _ ->
- add_pure_binding name pure pure_sp_code.V0.combiner_statement
+ add_pure_binding name pure pure_sp_code.VT0.combiner_rec_statement
(function ty -> Ast0.StmtTag ty)
s)
| Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
| (_,Ast0.UniqueStm(reb)) -> match_statement pattern reb
| _ -> return false
else return_false (ContextRequired (Ast0.StmtTag s))
-
+
(* first should provide a subset of the information in the second *)
and match_fninfo patterninfo cinfo =
let patterninfo = List.sort compare patterninfo in
| _ -> failwith "not possible")
| _ -> return false in
loop (patterninfo,cinfo)
-
+
and match_case_line pattern c =
if not(checks_needed) or not(context_required) or is_context c
then
| (_,Ast0.OptCase(cb)) -> match_case_line pattern cb
| _ -> return false
else return_false (ContextRequired (Ast0.CaseLineTag c)) in
-
+
let match_statement_dots x y =
match_dots match_statement is_slist_matcher do_slist_match x y in
-
+
(match_expr, match_decl, match_statement, match_typeC,
match_statement_dots)
-
+
let match_expr dochecks context_required whencode_allowed =
let (fn,_,_,_,_) = match_maker dochecks context_required whencode_allowed in
fn
-
+
let match_decl dochecks context_required whencode_allowed =
let (_,fn,_,_,_) = match_maker dochecks context_required whencode_allowed in
fn
-
+
let match_statement dochecks context_required whencode_allowed =
let (_,_,fn,_,_) = match_maker dochecks context_required whencode_allowed in
fn
-
+
let match_typeC dochecks context_required whencode_allowed =
let (_,_,_,fn,_) = match_maker dochecks context_required whencode_allowed in
fn
-
+
let match_statement_dots dochecks context_required whencode_allowed =
let (_,_,_,_,fn) = match_maker dochecks context_required whencode_allowed in
fn
-
+
(* --------------------------------------------------------------------- *)
(* make an entire tree MINUS *)
-
+
let make_minus =
let mcode (term,arity,info,mcodekind,pos) =
let new_mcodekind =
| Ast0.MINUS(mc) -> mcodekind (* in the part copied from the src term *)
| _ -> failwith "make_minus mcode: unexpected mcodekind" in
(term,arity,info,new_mcodekind,pos) in
-
+
let update_mc mcodekind e =
match !mcodekind with
Ast0.CONTEXT(mc) ->
| Ast0.MINUS(_mc) -> () (* in the part copied from the src term *)
| Ast0.PLUS -> failwith "make_minus donothing: unexpected plus mcodekind"
| _ -> failwith "make_minus donothing: unexpected mcodekind" in
-
+
let donothing r k e =
let mcodekind = Ast0.get_mcodekind_ref e in
let e = k e in update_mc mcodekind e; e in
-
+
(* special case for whencode, because it isn't processed by contextneg,
since it doesn't appear in the + code *)
(* cases for dots and nests *)
update_mc mcodekind e;
Ast0.rewrap e
(Ast0.NestExpr(mcode starter,
- r.V0.rebuilder_expression_dots expr_dots,
+ r.VT0.rebuilder_rec_expression_dots expr_dots,
mcode ender,whencode,multi))
| _ -> donothing r k e in
-
+
let declaration r k e =
let mcodekind = Ast0.get_mcodekind_ref e in
match Ast0.unwrap e with
(*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 statement r k e =
let mcodekind = Ast0.get_mcodekind_ref e in
match Ast0.unwrap e with
| Ast0.Nest(starter,stmt_dots,ender,whencode,multi) ->
update_mc mcodekind e;
Ast0.rewrap e
- (Ast0.Nest(mcode starter,r.V0.rebuilder_statement_dots stmt_dots,
- mcode ender,whencode,multi))
+ (Ast0.Nest
+ (mcode starter,r.VT0.rebuilder_rec_statement_dots stmt_dots,
+ mcode ender,whencode,multi))
| _ -> donothing r k e in
-
+
let initialiser r k e =
let mcodekind = Ast0.get_mcodekind_ref e in
match Ast0.unwrap e with
(*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
-
+
let dots r k e =
let info = Ast0.get_info e in
let mcodekind = Ast0.get_mcodekind_ref e in
Ast0.DOTS([]) ->
(* if context is - this should be - as well. There are no tokens
here though, so the bottom-up minusifier in context_neg leaves it
- as mixed. It would be better to fix context_neg, but that would
+ as mixed (or context for sgrep2). It would be better to fix
+ context_neg, but that would
require a special case for each term with a dots subterm. *)
(match !mcodekind with
- Ast0.MIXED(mc) ->
+ Ast0.MIXED(mc) | Ast0.CONTEXT(mc) ->
(match !mc with
(Ast.NOTHING,_,_) ->
mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info));
| _ ->
failwith
(Printf.sprintf
- "%d: make_minus donothingxxx: unexpected mcodekind"
- info.Ast0.line_start))
+ "%d: make_minus donothingxxx: unexpected mcodekind: %s"
+ info.Ast0.pos_info.Ast0.line_start (Dumper.dump e)))
| _ -> donothing r k e in
-
- V0.rebuilder
+
+ V0.flat_rebuilder
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
dots dots dots dots dots dots
donothing expression donothing initialiser donothing declaration
statement donothing donothing
-
+
(* --------------------------------------------------------------------- *)
(* rebuild mcode cells in an instantiated alt *)
-
+
(* mcodes will be side effected later with plus code, so we have to copy
them on instantiating an isomorphism. One could wonder whether it would
be better not to use side-effects, but they are convenient for insert_plus
(* this function is used elsewhere where we need to rebuild the
indices, and so we allow PLUS code as well *)
Ast0.PLUS in
-
+
let mcode (term,arity,info,mcodekind,pos) =
let info =
match start_line with
- Some x -> {info with Ast0.line_start = x; Ast0.line_end = x}
+ Some x ->
+ let new_pos_info =
+ {info.Ast0.pos_info with
+ Ast0.line_start = x;
+ Ast0.line_end = x; } in
+ {info with Ast0.pos_info = new_pos_info}
| None -> info in
(term,arity,info,copy_mcodekind mcodekind,pos) in
-
+
let copy_one x =
let old_info = Ast0.get_info x in
let info =
match start_line with
- Some x -> {old_info with Ast0.line_start = x; Ast0.line_end = x}
+ Some x ->
+ let new_pos_info =
+ {old_info.Ast0.pos_info with
+ Ast0.line_start = x;
+ Ast0.line_end = x; } in
+ {old_info with Ast0.pos_info = new_pos_info}
| None -> old_info in
{x with Ast0.info = info; Ast0.index = ref(Ast0.get_index x);
Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind x))} in
-
+
let donothing r k e = copy_one (k e) in
-
+
(* case for control operators (if, etc) *)
let statement r k e =
let s = k e in
(match Ast0.get_dots_bef_aft res with
Ast0.NoDots -> Ast0.NoDots
| Ast0.AddingBetweenDots s ->
- Ast0.AddingBetweenDots(r.V0.rebuilder_statement s)
+ Ast0.AddingBetweenDots(r.VT0.rebuilder_rec_statement s)
| Ast0.DroppingBetweenDots s ->
- Ast0.DroppingBetweenDots(r.V0.rebuilder_statement s)) in
-
- V0.rebuilder
+ Ast0.DroppingBetweenDots(r.VT0.rebuilder_rec_statement s)) in
+
+ V0.flat_rebuilder
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
donothing donothing donothing donothing donothing donothing
donothing donothing donothing donothing donothing
donothing statement donothing donothing
-
+
(* --------------------------------------------------------------------- *)
(* The problem of whencode. If an isomorphism contains dots in multiple
rules, then the code that is matched cannot contain whencode, because we
won't know which dots it goes with. Should worry about nests, but they
aren't allowed in isomorphisms for the moment. *)
-
+
let count_edots =
- let mcode x = 0 in
let option_default = 0 in
let bind x y = x + y in
- let donothing r k e = k e in
let exprfn r k e =
match Ast0.unwrap e with
Ast0.Edots(_,_) | Ast0.Ecircles(_,_) | Ast0.Estars(_,_) -> 1
| _ -> 0 in
-
+
V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
- donothing donothing donothing donothing donothing donothing
- donothing exprfn donothing donothing donothing donothing donothing
- donothing donothing
-
+ {V0.combiner_functions with VT0.combiner_exprfn = exprfn}
+
let count_idots =
- let mcode x = 0 in
let option_default = 0 in
let bind x y = x + y in
- let donothing r k e = k e in
let initfn r k e =
match Ast0.unwrap e with Ast0.Idots(_,_) -> 1 | _ -> 0 in
-
+
V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing initfn donothing donothing donothing
- donothing donothing
-
+ {V0.combiner_functions with VT0.combiner_initfn = initfn}
+
let count_dots =
- let mcode x = 0 in
let option_default = 0 in
let bind x y = x + y in
- let donothing r k e = k e in
let stmtfn r k e =
match Ast0.unwrap e with
Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> 1
| _ -> 0 in
-
+
V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing stmtfn
- donothing donothing
-
+ {V0.combiner_functions with VT0.combiner_stmtfn = stmtfn}
+
(* --------------------------------------------------------------------- *)
-
+
let lookup name bindings mv_bindings =
try Common.Left (List.assoc (term name) bindings)
with
let e = k e in
match Ast0.unwrap e with
Ast0.MetaId(name,constraints,pure) ->
- (rebuild_mcode None).V0.rebuilder_ident
+ (rebuild_mcode None).VT0.rebuilder_rec_ident
(match lookup name bindings mv_bindings with
Common.Left(Ast0.IdentTag(id)) -> id
| Common.Left(_) -> failwith "not possible 1"
| Common.Left(_) -> failwith "not possible 1"
| Common.Right(new_mv) ->
failwith "MetaExprList in SP not supported"*)
- | _ -> [r.V0.rebuilder_expression x])
- | x::xs -> (r.V0.rebuilder_expression x)::(elist r same_dots xs) in
+ | _ -> [r.VT0.rebuilder_rec_expression x])
+ | x::xs -> (r.VT0.rebuilder_rec_expression x)::(elist r same_dots xs) in
let rec plist r same_dots = function
[] -> []
| Common.Left(_) -> failwith "not possible 1"
| Common.Right(new_mv) ->
failwith "MetaExprList in SP not supported"*)
- | _ -> [r.V0.rebuilder_parameter x])
- | x::xs -> (r.V0.rebuilder_parameter x)::(plist r same_dots xs) in
+ | _ -> [r.VT0.rebuilder_rec_parameter x])
+ | x::xs -> (r.VT0.rebuilder_rec_parameter x)::(plist r same_dots xs) in
let rec slist r same_dots = function
[] -> []
| Common.Left(_) -> failwith "not possible 1"
| Common.Right(new_mv) ->
failwith "MetaExprList in SP not supported")
- | _ -> [r.V0.rebuilder_statement x])
- | x::xs -> (r.V0.rebuilder_statement x)::(slist r same_dots xs) in
+ | _ -> [r.VT0.rebuilder_rec_statement x])
+ | x::xs -> (r.VT0.rebuilder_rec_statement x)::(slist r same_dots xs) in
let same_dots d =
match Ast0.unwrap d with Ast0.DOTS(l) -> Some l |_ -> None in
let e1 =
match Ast0.unwrap e with
Ast0.MetaExpr(name,constraints,x,form,pure) ->
- (rebuild_mcode None).V0.rebuilder_expression
+ (rebuild_mcode None).VT0.rebuilder_rec_expression
(match lookup name bindings mv_bindings with
Common.Left(Ast0.ExprTag(exp)) -> exp
| Common.Left(_) -> failwith "not possible 1"
| _ -> failwith "plus not possible" in
if was_meta && nomodif exp && nomodif e
then
- let rec negate e (*for rewrapping*) res (*code to process*) =
+ let idcont x = x in
+ let rec negate e (*for rewrapping*) res (*code to process*) k =
+ (* k accumulates parens, to keep negation outside if no
+ propagation is possible *)
match Ast0.unwrap res with
Ast0.Unary(e1,op) when Ast0.unwrap_mcode op = Ast.Not ->
- Ast0.rewrap e (Ast0.unwrap e1)
- | Ast0.Edots(_,_) -> Ast0.rewrap e (Ast0.unwrap res)
+ k (Ast0.rewrap e (Ast0.unwrap e1))
+ | Ast0.Edots(_,_) -> k (Ast0.rewrap e (Ast0.unwrap res))
| Ast0.Paren(lp,e,rp) ->
- Ast0.rewrap res (Ast0.Paren(lp,negate e e,rp))
+ negate e e
+ (function x ->
+ k (Ast0.rewrap res (Ast0.Paren(lp,x,rp))))
| Ast0.Binary(e1,op,e2) ->
let reb nop = Ast0.rewrap_mcode op (Ast.Logical(nop)) in
- let invop =
- match Ast0.unwrap_mcode op with
- Ast.Logical(Ast.Inf) ->
- Ast0.Binary(e1,reb Ast.SupEq,e2)
- | Ast.Logical(Ast.Sup) ->
- Ast0.Binary(e1,reb Ast.InfEq,e2)
- | Ast.Logical(Ast.InfEq) ->
- Ast0.Binary(e1,reb Ast.Sup,e2)
- | Ast.Logical(Ast.SupEq) ->
- Ast0.Binary(e1,reb Ast.Inf,e2)
- | Ast.Logical(Ast.Eq) ->
- Ast0.Binary(e1,reb Ast.NotEq,e2)
- | Ast.Logical(Ast.NotEq) ->
- Ast0.Binary(e1,reb Ast.Eq,e2)
- | Ast.Logical(Ast.AndLog) ->
- Ast0.Binary(negate e1 e1,reb Ast.OrLog,
- negate e2 e2)
- | Ast.Logical(Ast.OrLog) ->
- Ast0.Binary(negate e1 e1,reb Ast.AndLog,
- negate e2 e2)
- | _ -> Ast0.Unary(res,Ast0.rewrap_mcode op Ast.Not) in
- Ast0.rewrap e invop
+ let k1 x = k (Ast0.rewrap e x) in
+ (match Ast0.unwrap_mcode op with
+ Ast.Logical(Ast.Inf) ->
+ k1 (Ast0.Binary(e1,reb Ast.SupEq,e2))
+ | Ast.Logical(Ast.Sup) ->
+ k1 (Ast0.Binary(e1,reb Ast.InfEq,e2))
+ | Ast.Logical(Ast.InfEq) ->
+ k1 (Ast0.Binary(e1,reb Ast.Sup,e2))
+ | Ast.Logical(Ast.SupEq) ->
+ k1 (Ast0.Binary(e1,reb Ast.Inf,e2))
+ | Ast.Logical(Ast.Eq) ->
+ k1 (Ast0.Binary(e1,reb Ast.NotEq,e2))
+ | Ast.Logical(Ast.NotEq) ->
+ k1 (Ast0.Binary(e1,reb Ast.Eq,e2))
+ | Ast.Logical(Ast.AndLog) ->
+ k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.OrLog,
+ negate e2 e2 idcont))
+ | Ast.Logical(Ast.OrLog) ->
+ k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.AndLog,
+ negate e2 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) exps in
+ let exps = List.map (function e -> negate e e k) exps in
Ast0.rewrap res (Ast0.DisjExpr(lp,exps,mids,rp))
| _ ->
(*use e, because this might be the toplevel expression*)
Ast0.rewrap e
- (Ast0.Unary(res,Ast0.rewrap_mcode unop Ast.Not)) in
- negate e exp
+ (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not)) in
+ negate e exp idcont
else e
| _ -> e)
| Ast0.Edots(d,_) ->
let e = k e in
match Ast0.unwrap e with
Ast0.MetaType(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_typeC
+ (rebuild_mcode None).VT0.rebuilder_rec_typeC
(match lookup name bindings mv_bindings with
Common.Left(Ast0.TypeCTag(ty)) -> ty
| Common.Left(_) -> failwith "not possible 1"
(Ast0.MetaType(Ast0.set_mcode_data new_mv name,pure)))
| _ -> e in
+ let initfn r k e =
+ let e = k e in
+ match Ast0.unwrap e with
+ Ast0.MetaInit(name,pure) ->
+ (rebuild_mcode None).VT0.rebuilder_rec_initialiser
+ (match lookup name bindings mv_bindings with
+ Common.Left(Ast0.InitTag(ty)) -> ty
+ | Common.Left(_) -> failwith "not possible 1"
+ | Common.Right(new_mv) ->
+ Ast0.rewrap e
+ (Ast0.MetaInit(Ast0.set_mcode_data new_mv name,pure)))
+ | _ -> e in
+
let declfn r k e =
let e = k e in
match Ast0.unwrap e with
let e = k e in
match Ast0.unwrap e with
Ast0.MetaParam(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_parameter
+ (rebuild_mcode None).VT0.rebuilder_rec_parameter
(match lookup name bindings mv_bindings with
Common.Left(Ast0.ParamTag(param)) -> param
| Common.Left(_) -> failwith "not possible 1"
let e = k e in
match Ast0.unwrap e with
Ast0.MetaStmt(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_statement
+ (rebuild_mcode None).VT0.rebuilder_rec_statement
(match lookup name bindings mv_bindings with
Common.Left(Ast0.StmtTag(stm)) -> stm
| Common.Left(_) -> failwith "not possible 1"
(List.filter (function (x,v) -> x = (dot_term d)) bindings)))
| _ -> e in
- V0.rebuilder
+ V0.flat_rebuilder
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
(dots elist) donothing (dots plist) (dots slist) donothing donothing
- identfn exprfn tyfn donothing paramfn declfn stmtfn donothing donothing
+ identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
(* --------------------------------------------------------------------- *)
let get_name = function
Ast.MetaIdDecl(ar,nm) ->
(nm,function nm -> Ast.MetaIdDecl(ar,nm))
- | Ast.MetaFreshIdDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaFreshIdDecl(ar,nm))
+ | Ast.MetaFreshIdDecl(nm,seed) ->
+ (nm,function nm -> Ast.MetaFreshIdDecl(nm,seed))
| Ast.MetaTypeDecl(ar,nm) ->
(nm,function nm -> Ast.MetaTypeDecl(ar,nm))
+ | Ast.MetaInitDecl(ar,nm) ->
+ (nm,function nm -> Ast.MetaInitDecl(ar,nm))
| Ast.MetaListlenDecl(nm) ->
failwith "should not be rebuilt"
| Ast.MetaParamDecl(ar,nm) ->
(extra_plus e
(instantiater bindings mv_bindings
(rebuild_mcodes a))))
- (Common.union_set [(name,mkiso a)] (Ast0.get_iso e)))
+ ((name,mkiso a)::(Ast0.get_iso e))) (* keep count, not U *)
bindings))
alts) in
let rec inner_loop all_alts prev_ecount prev_icount prev_dcount = function
(new_metavars,
call_instantiate bindings mv_bindings all_alts))) in
let rec outer_loop prev_ecount prev_icount prev_dcount = function
- [] | [[_]] (*only one alternative*) -> ([],e) (* nothing matched *)
+ [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
| (alts::rest) as all_alts ->
match inner_loop all_alts prev_ecount prev_icount prev_dcount alts with
Common.Left(prev_ecount, prev_icount, prev_dcount) ->
outer_loop prev_ecount prev_icount prev_dcount rest
| Common.Right (new_metavars,res) ->
- (new_metavars,
+ (1,new_metavars,
copy_minus printer minusify e (disj_maker res)) in
- outer_loop 0 0 0 alts
+ let (count,metavars,e) = outer_loop 0 0 0 alts in
+ (count, metavars, e)
(* no one should ever look at the information stored in these mcodes *)
let disj_starter lst =
let old_info = Ast0.get_info(List.hd lst) in
+ let new_pos_info =
+ { old_info.Ast0.pos_info with
+ Ast0.line_end = old_info.Ast0.pos_info.Ast0.line_start;
+ Ast0.logical_end = old_info.Ast0.pos_info.Ast0.logical_start; } in
let info =
- { old_info with
- Ast0.line_end = old_info.Ast0.line_start;
- Ast0.logical_end = old_info.Ast0.logical_start;
+ { 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
let disj_ender lst =
let old_info = Ast0.get_info(List.hd lst) in
+ let new_pos_info =
+ { old_info.Ast0.pos_info with
+ Ast0.line_start = old_info.Ast0.pos_info.Ast0.line_end;
+ Ast0.logical_start = old_info.Ast0.pos_info.Ast0.logical_end; } in
let info =
- { old_info with
- Ast0.line_start = old_info.Ast0.line_end;
- Ast0.logical_start = old_info.Ast0.logical_end;
+ { 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
match alts with
(Ast0.TypeCTag(_)::_)::_ ->
(* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
+ let start_line =
+ Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
let alts =
List.map
(List.map
(function
Ast0.TypeCTag(p) ->
- (p,count_edots.V0.combiner_typeC p,
- count_idots.V0.combiner_typeC p,
- count_dots.V0.combiner_typeC p)
+ (p,count_edots.VT0.combiner_rec_typeC p,
+ count_idots.VT0.combiner_rec_typeC p,
+ count_dots.VT0.combiner_rec_typeC p)
| _ -> failwith "invalid alt"))
alts in
mkdisj match_typeC metavars alts e
(function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_typeC)
+ (instantiate b mv_b).VT0.rebuilder_rec_typeC)
(function t -> Ast0.TypeCTag t)
- make_disj_type make_minus.V0.rebuilder_typeC
- (rebuild_mcode start_line).V0.rebuilder_typeC
+ 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
- | _ -> ([],e)
+ | _ -> (0,[],e)
let transform_expr (metavars,alts,name) e =
let process update_others =
(* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
+ let start_line =
+ Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
let alts =
List.map
(List.map
(function
Ast0.ExprTag(p) | Ast0.ArgExprTag(p) | Ast0.TestExprTag(p) ->
- (p,count_edots.V0.combiner_expression p,
- count_idots.V0.combiner_expression p,
- count_dots.V0.combiner_expression p)
+ (p,count_edots.VT0.combiner_rec_expression p,
+ count_idots.VT0.combiner_rec_expression p,
+ count_dots.VT0.combiner_rec_expression p)
| _ -> failwith "invalid alt"))
alts in
mkdisj match_expr metavars alts e
(function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_expression)
+ (instantiate b mv_b).VT0.rebuilder_rec_expression)
(function e -> Ast0.ExprTag e)
- (make_disj_expr e) make_minus.V0.rebuilder_expression
- (rebuild_mcode start_line).V0.rebuilder_expression
+ (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
match alts with
(Ast0.ExprTag(_)::_)::_ -> 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
- | _ -> ([],e)
+ | _ -> (0,[],e)
let transform_decl (metavars,alts,name) e =
match alts with
(Ast0.DeclTag(_)::_)::_ ->
(* start line is given to any leaves in the iso code *)
- let start_line = Some (Ast0.get_info e).Ast0.line_start in
+ let start_line =
+ Some (Ast0.get_info e).Ast0.pos_info.Ast0.line_start in
let alts =
List.map
(List.map
(function
Ast0.DeclTag(p) ->
- (p,count_edots.V0.combiner_declaration p,
- count_idots.V0.combiner_declaration p,
- count_dots.V0.combiner_declaration p)
+ (p,count_edots.VT0.combiner_rec_declaration p,
+ count_idots.VT0.combiner_rec_declaration p,
+ count_dots.VT0.combiner_rec_declaration p)
| _ -> failwith "invalid alt"))
alts in
mkdisj match_decl metavars alts e
(function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_declaration)
+ (instantiate b mv_b).VT0.rebuilder_rec_declaration)
(function d -> Ast0.DeclTag d)
make_disj_decl
- make_minus.V0.rebuilder_declaration
- (rebuild_mcode start_line).V0.rebuilder_declaration
+ make_minus.VT0.rebuilder_rec_declaration
+ (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
name Unparse_ast0.declaration extra_copy_other_plus do_nothing
- | _ -> ([],e)
+ | _ -> (0,[],e)
let transform_stmt (metavars,alts,name) e =
match alts with
(Ast0.StmtTag(_)::_)::_ ->
(* start line is given to any leaves in the iso code *)
- let start_line = Some (Ast0.get_info e).Ast0.line_start in
+ let start_line =
+ Some (Ast0.get_info e).Ast0.pos_info.Ast0.line_start in
let alts =
List.map
(List.map
(function
Ast0.StmtTag(p) ->
- (p,count_edots.V0.combiner_statement p,
- count_idots.V0.combiner_statement p,
- count_dots.V0.combiner_statement p)
+ (p,count_edots.VT0.combiner_rec_statement p,
+ count_idots.VT0.combiner_rec_statement p,
+ count_dots.VT0.combiner_rec_statement p)
| _ -> failwith "invalid alt"))
alts in
mkdisj match_statement metavars alts e
(function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_statement)
+ (instantiate b mv_b).VT0.rebuilder_rec_statement)
(function s -> Ast0.StmtTag s)
- make_disj_stmt make_minus.V0.rebuilder_statement
- (rebuild_mcode start_line).V0.rebuilder_statement
+ 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
- | _ -> ([],e)
+ | _ -> (0,[],e)
(* sort of a hack, because there is no disj at top level *)
let transform_top (metavars,alts,name) e =
| _ -> raise (Failure ""))
| _ -> raise (Failure "")))
alts in
- let (mv,s) = transform_stmt (metavars,strip alts,name) declstm in
- (mv,Ast0.rewrap e (Ast0.DECL(s)))
- with Failure _ -> ([],e))
+ let (count,mv,s) = transform_stmt (metavars,strip alts,name) declstm in
+ (count,mv,Ast0.rewrap e (Ast0.DECL(s)))
+ with Failure _ -> (0,[],e))
| Ast0.CODE(stmts) ->
- let (mv,res) =
+ let (count,mv,res) =
match alts with
(Ast0.DotsStmtTag(_)::_)::_ ->
(* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
+ let start_line =
+ Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
let alts =
List.map
(List.map
(function
Ast0.DotsStmtTag(p) ->
- (p,count_edots.V0.combiner_statement_dots p,
- count_idots.V0.combiner_statement_dots p,
- count_dots.V0.combiner_statement_dots p)
+ (p,count_edots.VT0.combiner_rec_statement_dots p,
+ count_idots.VT0.combiner_rec_statement_dots p,
+ count_dots.VT0.combiner_rec_statement_dots p)
| _ -> failwith "invalid alt"))
alts in
mkdisj match_statement_dots metavars alts stmts
(function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_statement_dots)
+ (instantiate b mv_b).VT0.rebuilder_rec_statement_dots)
(function s -> Ast0.DotsStmtTag s)
(function x ->
Ast0.rewrap e (Ast0.DOTS([make_disj_stmt_list x])))
- make_minus.V0.rebuilder_statement_dots
- (rebuild_mcode start_line).V0.rebuilder_statement_dots
+ (function x ->
+ 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
- | _ -> ([],stmts) in
- (mv,Ast0.rewrap e (Ast0.CODE res))
- | _ -> ([],e)
+ | _ -> (0,[],stmts) in
+ (count,mv,Ast0.rewrap e (Ast0.CODE res))
+ | _ -> (0,[],e)
(* --------------------------------------------------------------------- *)
let transform (alts : isomorphism) t =
(* the following ugliness is because rebuilder only returns a new term *)
let extra_meta_decls = ref ([] : Ast_cocci.metavar list) in
- let mcode x = x in
- let donothing r k e = k e in
+ let in_limit n = function
+ None -> true
+ | Some n1 ->
+ n < n1 or
+ ((if !Flag_parsing_cocci.show_iso_failures
+ then Common.pr2_once "execeeded iso threshold, see -iso_limit option");
+ false) in
+ let bind x y = x + y in
+ let option_default = 0 in
let exprfn r k e =
- let (extra_meta,exp) = transform_expr alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- exp in
+ let (e_count,e) = k e in
+ if in_limit e_count !Flag_parsing_cocci.iso_limit
+ then
+ let (count,extra_meta,exp) = transform_expr alts e in
+ extra_meta_decls := extra_meta @ !extra_meta_decls;
+ (bind count e_count,exp)
+ else (e_count,e) in
let declfn r k e =
- let (extra_meta,dec) = transform_decl alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- dec in
+ let (e_count,e) = k e in
+ if in_limit e_count !Flag_parsing_cocci.iso_limit
+ then
+ let (count,extra_meta,dec) = transform_decl alts e in
+ extra_meta_decls := extra_meta @ !extra_meta_decls;
+ (bind count e_count,dec)
+ else (e_count,e) in
let stmtfn r k e =
- let (extra_meta,stm) = transform_stmt alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- stm in
-
+ let (e_count,e) = k e in
+ if in_limit e_count !Flag_parsing_cocci.iso_limit
+ then
+ let (count,extra_meta,stm) = transform_stmt alts e in
+ extra_meta_decls := extra_meta @ !extra_meta_decls;
+ (bind count e_count,stm)
+ else (e_count,e) in
+
let typefn r k e =
- let (extra_meta,ty) = transform_type alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- ty in
-
+ let (continue,e_count,e) =
+ match Ast0.unwrap e with
+ Ast0.Signed(signb,tyb) ->
+ (* Hack! How else to prevent iso from applying under an
+ unsigned??? *)
+ (true,0,e)
+ | _ ->
+ let (e_count,e) = k e in
+ if in_limit e_count !Flag_parsing_cocci.iso_limit
+ then (true,e_count,e)
+ else (false,e_count,e) in
+ if continue
+ then
+ let (count,extra_meta,ty) = transform_type alts e in
+ extra_meta_decls := extra_meta @ !extra_meta_decls;
+ (bind count e_count,ty)
+ else (e_count,e) in
+
let topfn r k e =
- let (extra_meta,ty) = transform_top alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- ty in
-
+ let (e_count,e) = k e in
+ if in_limit e_count !Flag_parsing_cocci.iso_limit
+ then
+ let (count,extra_meta,ty) = transform_top alts e in
+ extra_meta_decls := extra_meta @ !extra_meta_decls;
+ (bind count e_count,ty)
+ else (e_count,e) in
+
let res =
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
- donothing donothing donothing donothing donothing donothing
- donothing exprfn typefn donothing donothing declfn stmtfn
- donothing topfn in
- let res = res.V0.rebuilder_top_level t in
+ V0.combiner_rebuilder bind option_default
+ {V0.combiner_rebuilder_functions with
+ VT0.combiner_rebuilder_exprfn = exprfn;
+ VT0.combiner_rebuilder_tyfn = typefn;
+ VT0.combiner_rebuilder_declfn = declfn;
+ VT0.combiner_rebuilder_stmtfn = stmtfn;
+ VT0.combiner_rebuilder_topfn = topfn} in
+ let (_,res) = res.VT0.top_level t in
(!extra_meta_decls,res)
(* --------------------------------------------------------------------- *)
let rewrap =
let mcode (x,a,i,mc,pos) = (x,a,i,Ast0.context_befaft(),pos) in
let donothing r k e = Ast0.context_wrap(Ast0.unwrap(k e)) in
- V0.rebuilder
+ V0.flat_rebuilder
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode
donothing donothing donothing donothing donothing donothing
donothing donothing donothing donothing donothing donothing donothing
donothing donothing
let rewrap_anything = function
Ast0.DotsExprTag(d) ->
- Ast0.DotsExprTag(rewrap.V0.rebuilder_expression_dots d)
+ Ast0.DotsExprTag(rewrap.VT0.rebuilder_rec_expression_dots d)
| Ast0.DotsInitTag(d) ->
- Ast0.DotsInitTag(rewrap.V0.rebuilder_initialiser_list d)
+ Ast0.DotsInitTag(rewrap.VT0.rebuilder_rec_initialiser_list d)
| Ast0.DotsParamTag(d) ->
- Ast0.DotsParamTag(rewrap.V0.rebuilder_parameter_list d)
+ Ast0.DotsParamTag(rewrap.VT0.rebuilder_rec_parameter_list d)
| Ast0.DotsStmtTag(d) ->
- Ast0.DotsStmtTag(rewrap.V0.rebuilder_statement_dots d)
+ Ast0.DotsStmtTag(rewrap.VT0.rebuilder_rec_statement_dots d)
| Ast0.DotsDeclTag(d) ->
- Ast0.DotsDeclTag(rewrap.V0.rebuilder_declaration_dots d)
+ Ast0.DotsDeclTag(rewrap.VT0.rebuilder_rec_declaration_dots d)
| Ast0.DotsCaseTag(d) ->
- Ast0.DotsCaseTag(rewrap.V0.rebuilder_case_line_dots d)
- | Ast0.IdentTag(d) -> Ast0.IdentTag(rewrap.V0.rebuilder_ident d)
- | Ast0.ExprTag(d) -> Ast0.ExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.ArgExprTag(d) -> Ast0.ArgExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.TestExprTag(d) -> Ast0.TestExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.TypeCTag(d) -> Ast0.TypeCTag(rewrap.V0.rebuilder_typeC d)
- | Ast0.InitTag(d) -> Ast0.InitTag(rewrap.V0.rebuilder_initialiser d)
- | Ast0.ParamTag(d) -> Ast0.ParamTag(rewrap.V0.rebuilder_parameter d)
- | Ast0.DeclTag(d) -> Ast0.DeclTag(rewrap.V0.rebuilder_declaration d)
- | Ast0.StmtTag(d) -> Ast0.StmtTag(rewrap.V0.rebuilder_statement d)
- | Ast0.CaseLineTag(d) -> Ast0.CaseLineTag(rewrap.V0.rebuilder_case_line d)
- | Ast0.TopTag(d) -> Ast0.TopTag(rewrap.V0.rebuilder_top_level d)
+ Ast0.DotsCaseTag(rewrap.VT0.rebuilder_rec_case_line_dots d)
+ | Ast0.IdentTag(d) -> Ast0.IdentTag(rewrap.VT0.rebuilder_rec_ident d)
+ | Ast0.ExprTag(d) -> Ast0.ExprTag(rewrap.VT0.rebuilder_rec_expression d)
+ | Ast0.ArgExprTag(d) ->
+ Ast0.ArgExprTag(rewrap.VT0.rebuilder_rec_expression d)
+ | Ast0.TestExprTag(d) ->
+ Ast0.TestExprTag(rewrap.VT0.rebuilder_rec_expression d)
+ | Ast0.TypeCTag(d) -> Ast0.TypeCTag(rewrap.VT0.rebuilder_rec_typeC d)
+ | Ast0.InitTag(d) -> Ast0.InitTag(rewrap.VT0.rebuilder_rec_initialiser d)
+ | Ast0.ParamTag(d) -> Ast0.ParamTag(rewrap.VT0.rebuilder_rec_parameter d)
+ | Ast0.DeclTag(d) -> Ast0.DeclTag(rewrap.VT0.rebuilder_rec_declaration d)
+ | Ast0.StmtTag(d) -> Ast0.StmtTag(rewrap.VT0.rebuilder_rec_statement d)
+ | Ast0.CaseLineTag(d) ->
+ Ast0.CaseLineTag(rewrap.VT0.rebuilder_rec_case_line d)
+ | Ast0.TopTag(d) -> Ast0.TopTag(rewrap.VT0.rebuilder_rec_top_level d)
| Ast0.IsoWhenTag(_) | Ast0.IsoWhenTTag(_) | Ast0.IsoWhenFTag(_) ->
failwith "only for isos within iso phase"
| Ast0.MetaPosTag(p) -> Ast0.MetaPosTag(p)
HCoop / bpt / coccinelle.git / blobdiff