tools/bridge.ml

   1 (*
   2  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   3  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   4  * This file is part of Coccinelle.
   5  *
   6  * Coccinelle is free software: you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation, according to version 2 of the License.
   9  *
  10  * Coccinelle is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  17  *
  18  * The authors reserve the right to distribute this or future versions of
  19  * Coccinelle under other licenses.
  20  *)
  21
  22
  23 let drop_spaces s =
  24   String.concat "" (Str.split (Str.regexp "[ ]+") s)
  25
  26 let parse_line fp l n =
  27   if List.mem l fp
  28   then None
  29   else
  30     if Str.string_match (Str.regexp "#") l 0
  31     then None (* comment line *)
  32     else
  33       let top_split = Str.split (Str.regexp ":") l in
  34       match top_split with
  35         cocci::first::others ->
  36           let rec loop tag = function
  37               [x] ->
  38                 let x =
  39                   String.concat "\\ " (Str.split (Str.regexp "[ ]+") x) in
  40                 [(tag,x)]
  41             | first::rest ->
  42                 let splitted = Str.split (Str.regexp "[ ]+") first in
  43                 (match List.rev splitted with
  44                   new_tag::info ->
  45                     let rest = loop new_tag rest in
  46                     (tag,String.concat "\\ " info)::rest
  47                 |       _ -> failwith "bad element")
  48             | _ -> failwith "no data" in
  49           Some (cocci,loop (drop_spaces first) others)
  50       | _ -> failwith (Printf.sprintf "bad line: %s" l)
  51
  52 let collect_lines fp i =
  53   let lines = ref [] in
  54   let ln = ref 0 in
  55   let rec loop _ =
  56     ln := !ln + 1;
  57     (match parse_line fp (input_line i) !ln with
  58       Some l ->
  59         if List.mem l !lines
  60         then ()
  61         else lines := l::!lines
  62     | None -> ());
  63     loop() in
  64   try loop() with End_of_file -> !lines
  65
  66 (* --------------------------------------------------------------------- *)
  67
  68 let process_fp fl =
  69   let i = open_in fl in
  70   let lines = ref ([] : string list) in
  71   let rec loop _ =
  72     let l = input_line i in
  73     (if not(Str.string_match (Str.regexp "#") l 0)
  74     then lines := l :: !lines);
  75     loop() in
  76   (try loop() with End_of_file -> ());
  77   close_in i;
  78   !lines
  79
  80 (* --------------------------------------------------------------------- *)
  81
  82 let discard_ambiguous lines =
  83   let rec loop = function
  84       [] -> []
  85     | (cocci,tags)::rest ->
  86         let (same,others) =
  87           List.partition
  88             (function (cocci2,tags2) -> tags = tags2 && not(cocci = cocci2))
  89             rest in
  90         match same with
  91           [] -> (cocci,tags)::loop rest
  92         | _ ->
  93             Printf.printf "ignoring ambiguity:\n";
  94             List.iter
  95               (function (cocci,tags) ->
  96                 Printf.printf "%s: %s\n" cocci
  97                   (String.concat ", "
  98                      (List.map
  99                         (function (tag,tagval) ->
 100                           Printf.sprintf "%s: %s" tag tagval)
 101                         tags)))
 102               ((cocci,tags)::same);
 103             loop others in
 104   loop lines
 105
 106 (* --------------------------------------------------------------------- *)
 107 (* only actually collects the rightmost element into ors *)
 108
 109 let split_or (cocci,line) =
 110   let rev = List.rev line in
 111   (cocci,List.rev(List.tl rev), List.hd rev)
 112
 113 let collect_ors fp lines =
 114   let rec loop = function
 115       [] -> failwith "no lines"
 116     | [line] ->
 117         let (c,k,v) = split_or line in
 118         ((c,k,[v]),[])
 119     | line::xs ->
 120         let (c,k,v) = split_or line in
 121         let ((c1,k1,v1),rest) = loop xs in
 122         if c = c1 && k = k1 && not (k = [])
 123         then
 124           if List.mem v v1
 125           then ((c1,k1,v1),rest)
 126           else ((c1,k1,v::v1),rest)
 127         else ((c,k,[v]),((c1,k1,v1)::rest)) in
 128   let ((c,k,v),rest) = loop lines in
 129   let res = (c,k,v)::rest in
 130   List.fold_left
 131     (function prev ->
 132       function (c,k,v) ->
 133         match v with
 134           [] -> failwith "not possible"
 135         | [x] -> (c,k@v) :: prev
 136         | (tag,_)::_ ->
 137             (*let vs =
 138               Printf.sprintf "%s:(%s)" tag
 139                 (String.concat "|"
 140                    (List.sort compare
 141                       (List.map (function (_,vl) -> vl) v))) in
 142             let attempt =
 143               Printf.sprintf "%s: %s %s" c
 144                 (String.concat " " (List.map (function (k,v) -> k^":"^v) k))
 145                 vs in*)
 146             if true (*List.mem attempt fp*)
 147             then
 148               let vs =
 149                 Printf.sprintf "\\\\\\\\\\(%s\\\\\\\\\\)"
 150                   (String.concat "\\\\\\\\\\|"
 151                      (List.sort compare
 152                         (List.map (function (_,vl) -> vl) v))) in
 153               (c,k@[(tag,vs)]) :: prev
 154             else (List.map (function vi -> (c,k@[vi])) v) @ prev)
 155     [] res
 156
 157 (* --------------------------------------------------------------------- *)
 158
 159 let command s =
 160   let _ = Sys.command s in
 161   ()
 162
 163 let created = ref ([] : (string * (int ref * out_channel)) list)
 164
 165 let mktag n = Printf.sprintf "x%d" n
 166
 167 let created_files = ref ([] : (string * int ref) list)
 168
 169 let process_line env (cocci,tags) =
 170   let files = List.filter (function (c,f) -> c = cocci) env in
 171   List.iter
 172     (function (_,cocci_file) ->
 173       let resdir = Filename.chop_extension cocci_file in
 174       (if not(Sys.file_exists cocci_file)
 175       then failwith "no cocci file");
 176       let (n,o) =
 177         try List.assoc resdir !created
 178         with Not_found ->
 179           begin
 180             command
 181               (Printf.sprintf "/bin/rm -r -f %s; mkdir %s" resdir resdir);
 182             let files = Printf.sprintf "%s/files" resdir in
 183             let o = open_out files in
 184             Printf.fprintf o "all: real_all\n\n";
 185             let cell = ((ref 0),o) in
 186             created := (resdir,cell) :: !created;
 187             cell
 188           end in
 189       let temp_file = Filename.temp_file cocci ".cocci" in
 190       command (Printf.sprintf "cp %s %s" cocci_file temp_file);
 191       let first_tag_val =
 192         match tags with
 193           [] -> failwith "no tags"
 194         | (_,first_tag_val)::_ ->
 195             let cell =
 196               try List.assoc first_tag_val !created_files
 197               with Not_found ->
 198                 let c = ref (-1) in
 199                 created_files := (first_tag_val,c)::!created_files;
 200                 c in
 201             cell := !cell + 1;
 202             if !cell = 0
 203             then first_tag_val
 204             else Printf.sprintf "%s%d" first_tag_val !cell in
 205       List.iter
 206         (function (tag,tagval) ->
 207           command
 208             (Printf.sprintf "sed s/%s/%s/ %s > %s_out; cp %s_out %s"
 209                tag tagval temp_file temp_file temp_file temp_file))
 210         tags;
 211       command
 212         (Printf.sprintf "mv %s %s/%s.cocci" temp_file resdir first_tag_val);
 213       Printf.fprintf o "%s:\n\tmono_spatch_linux %s.cocci ${ARGS}\n\n"
 214         (mktag !n) first_tag_val;
 215       n := !n + 1)
 216     files
 217
 218 (* --------------------------------------------------------------------- *)
 219
 220 let rec mkenv = function
 221     [] -> []
 222   | [_] -> failwith "required arguments: file (category x cocci file)*"
 223   | category::cocci::rest ->
 224       if Filename.check_suffix cocci ".cocci"
 225       then (category,cocci)::mkenv rest
 226       else failwith "required arguments: file (category x cocci file)*"
 227
 228 let rec upto = function
 229     0 -> []
 230   | n -> (mktag (n-1)) :: (upto (n-1))
 231
 232 let _ =
 233   let (file,fp,env) =
 234     match List.tl(Array.to_list Sys.argv) with
 235       file::env ->
 236         let rec loop prev = function
 237             [] ->
 238               if prev = ""
 239               then ([],[])
 240               else ([prev],[])
 241           | x::xs ->
 242               try
 243                 let _ = Str.search_forward (Str.regexp ".cocci") x 0 in
 244                 if prev = ""
 245                 then ([],x::xs)
 246                 else ([],prev::x::xs)
 247               with Not_found ->
 248                 let (fp,env) = loop x xs in
 249                 if prev = ""
 250                 then (fp,env)
 251                 else (prev::fp,env) in
 252         let (fp,env) = loop "" env in
 253         (file,fp,mkenv env)
 254     | _ -> failwith "one argument expected" in
 255   let fp = List.fold_left (@) [] (List.map process_fp fp) in
 256   let i = open_in file in
 257   let lines = collect_lines fp i in
 258   let lines = collect_ors fp lines in
 259   close_in i;
 260   let lines = discard_ambiguous lines in
 261   List.iter (process_line env) lines;
 262   List.iter
 263     (function (resdir,(n,o)) ->
 264       Printf.fprintf o "real_all: %s\n"
 265         (String.concat " " (List.rev (upto !n)));
 266       close_out o)
 267     !created