parsing_cocci/unitary_ast0.ml

   1 (* find unitary metavariables *)
   2 module Ast0 = Ast0_cocci
   3 module Ast = Ast_cocci
   4 module V0 = Visitor_ast0
   5 module VT0 = Visitor_ast0_types
   6
   7 let set_minus s minus = List.filter (function n -> not (List.mem n minus)) s
   8
   9 let rec nub = function
  10     [] -> []
  11   | (x::xs) when (List.mem x xs) -> nub xs
  12   | (x::xs) -> x::(nub xs)
  13
  14 (* ----------------------------------------------------------------------- *)
  15 (* Find the variables that occur free and occur free in a unitary way *)
  16
  17 (* take everything *)
  18 let minus_checker name = let id = Ast0.unwrap_mcode name in [id]
  19
  20 (* take only what is in the plus code *)
  21 let plus_checker (nm,_,_,mc,_,_) =
  22   match mc with Ast0.PLUS _ -> [nm] | _ -> []
  23
  24 let get_free checker t =
  25   let bind x y = x @ y in
  26   let option_default = [] in
  27
  28   (* considers a single list *)
  29   let collect_unitary_nonunitary free_usage =
  30     let free_usage = List.sort compare free_usage in
  31     let rec loop1 todrop = function
  32         [] -> []
  33       | (x::xs) as all -> if x = todrop then loop1 todrop xs else all in
  34     let rec loop2 = function
  35         [] -> ([],[])
  36       | [x] -> ([x],[])
  37       | x::y::xs ->
  38           if x = y
  39           then
  40             let (unitary,non_unitary) = loop2(loop1 x xs) in
  41             (unitary,x::non_unitary)
  42           else
  43             let (unitary,non_unitary) = loop2 (y::xs) in
  44             (x::unitary,non_unitary) in
  45     loop2 free_usage in
  46
  47   (* considers a list of lists *)
  48   let detect_unitary_frees l =
  49     let (unitary,nonunitary) =
  50       List.split (List.map collect_unitary_nonunitary l) in
  51     let unitary = nub (List.concat unitary) in
  52     let nonunitary = nub (List.concat nonunitary) in
  53     let unitary =
  54       List.filter (function x -> not (List.mem x nonunitary)) unitary in
  55     unitary@nonunitary@nonunitary in
  56
  57   let whencode afn bfn expression = function
  58       Ast0.WhenNot(a) -> afn a
  59     | Ast0.WhenAlways(b) -> bfn b
  60     | Ast0.WhenModifier(_) -> option_default
  61     | Ast0.WhenNotTrue(a) -> expression a
  62     | Ast0.WhenNotFalse(a) -> expression a in
  63
  64   let ident r k i =
  65     match Ast0.unwrap i with
  66       Ast0.MetaId(name,_,_) | Ast0.MetaFunc(name,_,_)
  67     | Ast0.MetaLocalFunc(name,_,_) -> checker name
  68     | _ -> k i in
  69
  70   let expression r k e =
  71     match Ast0.unwrap e with
  72       Ast0.MetaErr(name,_,_) | Ast0.MetaExpr(name,_,_,_,_)
  73     | Ast0.MetaExprList(name,_,_) -> checker name
  74     | Ast0.DisjExpr(starter,expr_list,mids,ender) ->
  75         detect_unitary_frees(List.map r.VT0.combiner_rec_expression expr_list)
  76     | _ -> k e in
  77
  78   let typeC r k t =
  79     match Ast0.unwrap t with
  80       Ast0.MetaType(name,_) -> checker name
  81     | Ast0.DisjType(starter,types,mids,ender) ->
  82         detect_unitary_frees(List.map r.VT0.combiner_rec_typeC types)
  83     | _ -> k t in
  84
  85   let parameter r k p =
  86     match Ast0.unwrap p with
  87       Ast0.MetaParam(name,_) | Ast0.MetaParamList(name,_,_) -> checker name
  88     | _ -> k p in
  89
  90   let declaration r k d =
  91     match Ast0.unwrap d with
  92       Ast0.DisjDecl(starter,decls,mids,ender) ->
  93         detect_unitary_frees(List.map r.VT0.combiner_rec_declaration decls)
  94     | _ -> k d in
  95
  96   let case_line r k c =
  97     match Ast0.unwrap c with
  98       Ast0.DisjCase(starter,case_lines,mids,ender) ->
  99         detect_unitary_frees(List.map r.VT0.combiner_rec_case_line case_lines)
 100     | _ -> k c in
 101
 102   let statement r k s =
 103     match Ast0.unwrap s with
 104       Ast0.MetaStmt(name,_) | Ast0.MetaStmtList(name,_) -> checker name
 105     | Ast0.Disj(starter,stmt_list,mids,ender) ->
 106         detect_unitary_frees
 107           (List.map r.VT0.combiner_rec_statement_dots stmt_list)
 108     | Ast0.Nest(starter,stmt_dots,ender,whn,multi) ->
 109         bind (r.VT0.combiner_rec_statement_dots stmt_dots)
 110           (detect_unitary_frees
 111              (List.map
 112                 (whencode
 113                    r.VT0.combiner_rec_statement_dots
 114                    r.VT0.combiner_rec_statement
 115                     r.VT0.combiner_rec_expression)
 116                 whn))
 117     | Ast0.Dots(d,whn) | Ast0.Circles(d,whn) | Ast0.Stars(d,whn) ->
 118         detect_unitary_frees
 119           (List.map
 120              (whencode
 121                 r.VT0.combiner_rec_statement_dots r.VT0.combiner_rec_statement
 122                 r.VT0.combiner_rec_expression)
 123              whn)
 124     | _ -> k s in
 125
 126   let res = V0.combiner bind option_default
 127       {V0.combiner_functions with
 128         VT0.combiner_identfn = ident;
 129         VT0.combiner_exprfn = expression;
 130         VT0.combiner_tyfn = typeC;
 131         VT0.combiner_paramfn = parameter;
 132         VT0.combiner_declfn = declaration;
 133         VT0.combiner_stmtfn = statement;
 134         VT0.combiner_casefn = case_line} in
 135
 136   collect_unitary_nonunitary
 137     (List.concat (List.map res.VT0.combiner_rec_top_level t))
 138
 139 (* ----------------------------------------------------------------------- *)
 140 (* update the variables that are unitary *)
 141
 142 let update_unitary unitary =
 143   let is_unitary name =
 144     match (List.mem (Ast0.unwrap_mcode name) unitary,
 145            !Flag.sgrep_mode2, Ast0.get_mcode_mcodekind name) with
 146       (true,true,_) | (true,_,Ast0.CONTEXT(_)) -> Ast0.PureContext
 147     | (true,_,_) -> Ast0.Pure
 148     | (false,true,_) | (false,_,Ast0.CONTEXT(_)) -> Ast0.Context
 149     | (false,_,_) -> Ast0.Impure in
 150
 151   let ident r k i =
 152     match Ast0.unwrap i with
 153       Ast0.MetaId(name,constraints,_) ->
 154         Ast0.rewrap i (Ast0.MetaId(name,constraints,is_unitary name))
 155     | Ast0.MetaFunc(name,constraints,_) ->
 156         Ast0.rewrap i (Ast0.MetaFunc(name,constraints,is_unitary name))
 157     | Ast0.MetaLocalFunc(name,constraints,_) ->
 158         Ast0.rewrap i (Ast0.MetaLocalFunc(name,constraints,is_unitary name))
 159     | _ -> k i in
 160
 161   let expression r k e =
 162     match Ast0.unwrap e with
 163       Ast0.MetaErr(name,constraints,_) ->
 164         Ast0.rewrap e (Ast0.MetaErr(name,constraints,is_unitary name))
 165     | Ast0.MetaExpr(name,constraints,ty,form,_) ->
 166         Ast0.rewrap e (Ast0.MetaExpr(name,constraints,ty,form,is_unitary name))
 167     | Ast0.MetaExprList(name,lenname,_) ->
 168         Ast0.rewrap e (Ast0.MetaExprList(name,lenname,is_unitary name))
 169     | _ -> k e in
 170
 171   let typeC r k t =
 172     match Ast0.unwrap t with
 173       Ast0.MetaType(name,_) ->
 174         Ast0.rewrap t (Ast0.MetaType(name,is_unitary name))
 175     | _ -> k t in
 176
 177   let parameter r k p =
 178     match Ast0.unwrap p with
 179       Ast0.MetaParam(name,_) ->
 180         Ast0.rewrap p (Ast0.MetaParam(name,is_unitary name))
 181     | Ast0.MetaParamList(name,lenname,_) ->
 182         Ast0.rewrap p (Ast0.MetaParamList(name,lenname,is_unitary name))
 183     | _ -> k p in
 184
 185   let statement r k s =
 186     match Ast0.unwrap s with
 187       Ast0.MetaStmt(name,_) ->
 188         Ast0.rewrap s (Ast0.MetaStmt(name,is_unitary name))
 189     | Ast0.MetaStmtList(name,_) ->
 190         Ast0.rewrap s (Ast0.MetaStmtList(name,is_unitary name))
 191     | _ -> k s in
 192
 193   let res = V0.rebuilder
 194       {V0.rebuilder_functions with
 195         VT0.rebuilder_identfn = ident;
 196         VT0.rebuilder_exprfn = expression;
 197         VT0.rebuilder_tyfn = typeC;
 198         VT0.rebuilder_paramfn = parameter;
 199         VT0.rebuilder_stmtfn = statement} in
 200
 201   List.map res.VT0.rebuilder_rec_top_level
 202
 203 (* ----------------------------------------------------------------------- *)
 204
 205 let rec split3 = function
 206     [] -> ([],[],[])
 207   | (a,b,c)::xs -> let (l1,l2,l3) = split3 xs in (a::l1,b::l2,c::l3)
 208
 209 let rec combine3 = function
 210     ([],[],[]) -> []
 211   | (a::l1,b::l2,c::l3) -> (a,b,c) :: combine3 (l1,l2,l3)
 212   | _ -> failwith "not possible"
 213
 214 (* ----------------------------------------------------------------------- *)
 215 (* process all rules *)
 216
 217 let do_unitary rules =
 218   let rec loop = function
 219       [] -> ([],[])
 220     | (r::rules) ->
 221       match r with
 222         Ast0.ScriptRule (_,_,_,_)
 223       | Ast0.InitialScriptRule (_,_) | Ast0.FinalScriptRule (_,_) ->
 224           let (x,rules) = loop rules in
 225           (x, r::rules)
 226       | Ast0.CocciRule ((minus,metavars,chosen_isos),((plus,_) as plusz),rt) ->
 227           let mm1 = List.map Ast.get_meta_name metavars in
 228           let (used_after, rest) = loop rules in
 229           let (m_unitary, m_nonunitary) = get_free minus_checker minus in
 230           let (p_unitary, p_nonunitary) = get_free plus_checker plus in
 231           let p_free =
 232             if !Flag.sgrep_mode2 then []
 233             else p_unitary @ p_nonunitary in
 234           let (in_p, m_unitary) =
 235             List.partition (function x -> List.mem x p_free) m_unitary in
 236           let m_nonunitary = in_p @ m_nonunitary in
 237           let (m_unitary, not_local) =
 238             List.partition (function x -> List.mem x mm1) m_unitary in
 239           let m_unitary =
 240             List.filter (function x -> not (List.mem x used_after))
 241               m_unitary in
 242           let rebuilt = update_unitary m_unitary minus in
 243           (set_minus (m_nonunitary @ used_after) mm1,
 244              (Ast0.CocciRule
 245                 ((rebuilt, metavars, chosen_isos),plusz,rt))::rest) in
 246   let (_,rules) = loop rules in
 247   rules
 248
 249 (*
 250 let do_unitary minus plus =
 251   let (minus,metavars,chosen_isos) = split3 minus in
 252   let (plus,_) = List.split plus in
 253   let rec loop = function
 254       ([],[],[]) -> ([],[])
 255     | (mm1::metavars,m1::minus,p1::plus) ->
 256         let mm1 = List.map Ast.get_meta_name mm1 in
 257         let (used_after,rest) = loop (metavars,minus,plus) in
 258         let (m_unitary,m_nonunitary) = get_free minus_checker m1 in
 259         let (p_unitary,p_nonunitary) = get_free plus_checker p1 in
 260         let p_free =
 261           if !Flag.sgrep_mode2
 262           then []
 263           else p_unitary @ p_nonunitary in
 264         let (in_p,m_unitary) =
 265           List.partition (function x -> List.mem x p_free) m_unitary in
 266         let m_nonunitary = in_p@m_nonunitary in
 267         let (m_unitary,not_local) =
 268           List.partition (function x -> List.mem x mm1) m_unitary in
 269         let m_unitary =
 270           List.filter (function x -> not(List.mem x used_after)) m_unitary in
 271         let rebuilt = update_unitary m_unitary m1 in
 272         (set_minus (m_nonunitary @ used_after) mm1,
 273          rebuilt::rest)
 274     | _ -> failwith "not possible" in
 275   let (_,rules) = loop (metavars,minus,plus) in
 276   combine3 (rules,metavars,chosen_isos)
 277 *)