ocaml/yes_prepare_ocamlcocci.ml

   1 module Ast = Ast_cocci
   2
   3 exception CompileFailure of string
   4 exception LinkFailure of string
   5
   6 let ext = if Dynlink.is_native then ".cmxs" else ".cma"
   7 let has_ocamlfind = ref false
   8
   9 let check_cmd cmd =
  10   match Sys.command cmd with
  11       0 -> true
  12     | _ -> false
  13
  14 let check_runtime () =
  15   let has_opt  = check_cmd (!Flag.ocamlc ^".opt -version 2>&1 > /dev/null") in
  16   let has_c    = check_cmd (!Flag.ocamlc ^" -version 2>&1 > /dev/null") in
  17   let has_find = check_cmd (!Flag.ocamlfind ^ " printconf 2>&1 > /dev/null") in
  18     has_ocamlfind := has_find;
  19     if has_opt then
  20       begin
  21         Flag.ocamlc   := !Flag.ocamlc   ^ ".opt";
  22         Flag.ocamlopt := !Flag.ocamlopt ^ ".opt";
  23         Flag.ocamldep := !Flag.ocamldep ^ ".opt";
  24         Common.pr2 "Using native version of ocamlc/ocamlopt/ocamldep"
  25       end
  26     else
  27       if has_c then
  28         Common.pr2 "Using bytecode version of ocamlc/ocamlopt/ocamldep"
  29       else
  30         if Dynlink.is_native then
  31           failwith
  32             "No OCaml compiler found! Install either ocamlopt or ocamlopt.opt"
  33         else
  34           failwith
  35             "No OCaml compiler found! Install either ocamlc or ocamlc.opt"
  36
  37 let init_ocamlcocci _ =
  38   "open Coccilib\n"
  39
  40 let print_match ctr nm kind =
  41   let endlet = "| _ -> failwith \"bad value\" in\n" in
  42   let index = !ctr in
  43   ctr := !ctr + 1;
  44   Printf.sprintf
  45     "let %s = match List.nth args %d with Coccilib.%s x -> x %s"
  46     nm index kind endlet
  47
  48 let string_rep_binding ctr = function
  49     (Some nm,Ast.MetaPosDecl _) -> print_match ctr nm "Pos"
  50   | (Some nm,Ast.MetaListlenDecl _) -> print_match ctr nm "Int"
  51   | (Some nm,_) (* strings for everything else *) ->
  52       print_match ctr nm "Str"
  53   | (None,_) -> ""
  54
  55 let ast_rep_binding ctr = function
  56     (Some nm,Ast.MetaPosDecl _) ->
  57       failwith
  58         (Printf.sprintf "%s: No AST representation for position variables" nm)
  59   | (Some nm,Ast.MetaIdDecl _) -> print_match ctr nm "Str"
  60   | (Some nm,Ast.MetaFreshIdDecl _) -> print_match ctr nm "Str"
  61   | (Some nm,Ast.MetaTypeDecl _) -> print_match ctr nm "Type"
  62   | (Some nm,Ast.MetaInitDecl _) -> print_match ctr nm "Init"
  63   | (Some nm,Ast.MetaListlenDecl _) ->
  64       failwith
  65         (Printf.sprintf "%s: No AST representation for listlen variables" nm)
  66   | (Some nm,Ast.MetaParamDecl _) -> print_match ctr nm "Param"
  67   | (Some nm,Ast.MetaParamListDecl _) -> print_match ctr nm "ParamList"
  68   | (Some nm,Ast.MetaConstDecl _) -> print_match ctr nm "Expr"
  69   | (Some nm,Ast.MetaErrDecl _) -> failwith ("not supported: "^nm)
  70   | (Some nm,Ast.MetaExpDecl _) -> print_match ctr nm "Expr"
  71   | (Some nm,Ast.MetaIdExpDecl _) -> print_match ctr nm "Expr"
  72   | (Some nm,Ast.MetaLocalIdExpDecl _) -> print_match ctr nm "Expr"
  73   | (Some nm,Ast.MetaExpListDecl _) -> print_match ctr nm "ExprList"
  74   | (Some nm,Ast.MetaStmDecl _) -> print_match ctr nm "Stmt"
  75   | (Some nm,Ast.MetaStmListDecl _) -> failwith ("not supported: "^nm)
  76   | (Some nm,Ast.MetaFuncDecl _) -> print_match ctr nm "Str"
  77   | (Some nm,Ast.MetaLocalFuncDecl _) -> print_match ctr nm "Str"
  78   | (Some nm,Ast.MetaDeclarerDecl _) -> print_match ctr nm "Str"
  79   | (Some nm,Ast.MetaIteratorDecl _) -> print_match ctr nm "Str"
  80   | (None,_) -> ""
  81
  82 let prepare_rule (name, metavars, code) =
  83   let fname = String.concat "_" (Str.split (Str.regexp " ") name) in
  84   (* function header *)
  85   let function_header body =
  86     Printf.sprintf "let %s args =\n %s" fname body in
  87   (* parameter list *)
  88   let build_parameter_list body =
  89     let ctr = ref 0 in
  90     let lets =
  91       String.concat ""
  92         (List.rev
  93            (List.fold_left
  94               (function prev ->
  95                 function ((str_nm,ast_nm),_,mv) ->
  96                   (* order important; ctr is incremented *)
  97                   let string_rep = string_rep_binding ctr (str_nm,mv) in
  98                   let ast_rep = ast_rep_binding ctr (ast_nm,mv) in
  99                   ast_rep :: string_rep :: prev)
 100               [] metavars)) in
 101     lets ^ body in
 102   (* add to hash table *)
 103   let hash_add body =
 104     Printf.sprintf
 105       "%s\nlet _ = Hashtbl.add Coccilib.fcts \"%s\" %s\n" body name fname in
 106   hash_add (function_header (build_parameter_list code))
 107
 108 let prepare coccifile code =
 109   let init_rules =
 110     List.fold_left
 111       (function prev ->
 112         function
 113             Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) ->
 114               code :: prev
 115           | _ -> prev)
 116       [] code in
 117   let init_rules = List.rev init_rules in
 118   let other_rules =
 119     List.fold_left
 120       (function prev ->
 121         function
 122             Ast_cocci.ScriptRule (name,"ocaml",deps,mv,code) ->
 123               (name,mv,code) :: prev
 124           | Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) -> prev
 125           | Ast_cocci.FinalScriptRule (name,"ocaml",deps,code) ->
 126               (name,[],code) :: prev
 127           | _ -> prev)
 128       [] code in
 129   let other_rules = List.rev other_rules in
 130   if init_rules = [] && other_rules = []
 131   then None
 132   else
 133     let basefile = Filename.basename (Filename.chop_extension coccifile) in
 134     let basefile =
 135       String.concat "_" (Str.split (Str.regexp "-") basefile) in
 136     let (file,o) = Filename.open_temp_file  basefile ".ml" in
 137       (* Global initialization *)
 138       Printf.fprintf o "%s" (init_ocamlcocci());
 139       (* Semantic patch specific initialization *)
 140       Printf.fprintf o "%s" (String.concat "\n\n" init_rules);
 141       (* Semantic patch rules and finalizer *)
 142       let rule_code = List.map prepare_rule other_rules in
 143         Printf.fprintf o "%s" (String.concat "\n\n" rule_code);
 144         close_out o;
 145         check_runtime ();
 146         Some file
 147
 148 let filter_dep (accld, accinc) dep =
 149   match dep with
 150       (* Built-in and OCaml defaults are filtered out *)
 151       "Arg" | "Arith_status" | "Array" | "ArrayLabels" | "Big_int" | "Bigarray"
 152     | "Buffer" | "Callback" | "CamlinternalLazy" | "CamlinternalMod"
 153     | "CamlinternalOO"
 154     | "Char" | "Complex" | "Condition" | "Digest" | "Dynlink" | "Event"
 155     | "Filename"
 156     | "Format" | "Gc" | "Genlex" | "GraphicsX11" | "Hashtbl" | "Int32"
 157     | "Int64"
 158     | "Lazy" | "Lexing" | "List" | "ListLabels" | "Map" | "Marshal"
 159     | "MoreLabels" | "Mutex"
 160     | "Nativeint" | "Num" | "Obj" | "Oo" | "Parsing" | "Pervasives"
 161     | "Printexc" | "Printf"
 162     | "Queue" | "Random" | "Scanf" | "Set" | "Sort" | "Stack" | "StdLabels"
 163     | "Str" | "Stream"
 164     | "String" | "StringLabels" | "Sys" | "ThreadUnix" | "Unix" | "UnixLabels"
 165     | "Weak"
 166
 167     (* Coccilib is filtered out too *)
 168     | "Coccilib" | "Common" | "Ast_c" | "Visitor_c" | "Lib_parsing_c" ->
 169         (accld, accinc)
 170
 171     | "Dbm"      -> ("dbm"::accld, accinc)
 172     | "Graphics" -> ("graphics"::accld, accinc)
 173     | "Thread"   -> ("thread"::accld, accinc)
 174     | "Tk"       -> ("tk"::accld, accinc)
 175
 176     | _ ->
 177         let l = Char.lowercase (String.get dep 0)in
 178           String.set dep 0 l;
 179           (accld, dep::accinc)
 180
 181 let get_dir p =
 182   let inclcmd = !Flag.ocamlfind ^" query "^p in
 183   let dir = List.hd (Common.cmd_to_list inclcmd) in
 184     (dir, p)
 185
 186 let parse_dep mlfile depout =
 187   let re_colon = Str.regexp_string ":" in
 188   match Str.split re_colon depout with
 189     _::[dep] ->
 190       let deplist = Str.split (Str.regexp_string " ") dep in
 191       let (libs, orderdep) = List.fold_left filter_dep ([],[]) deplist in
 192       if libs <> [] || orderdep <> [] then
 193         if !has_ocamlfind
 194         then
 195           let packages = List.rev orderdep in
 196           let inclflags = List.map get_dir packages in
 197           let intlib = List.map get_dir libs in
 198           let alllibs = List.rev_append intlib inclflags in
 199           let plist =
 200             List.fold_left (fun acc (_,p) -> acc ^" "^p) "" alllibs in
 201           let flags =
 202             String.concat " " (List.map (fun (d,_) -> "-I "^d) inclflags) in
 203           if flags <> "" || libs <> []
 204           then
 205             begin
 206               Common.pr2
 207                 ("Extra OCaml packages used in the semantic patch:"^ plist);
 208               (alllibs (* , inclflags *), flags)
 209             end
 210           else
 211             raise
 212               (CompileFailure
 213                  ("ocamlfind did not find "^
 214                   (if (List.length libs + List.length orderdep) = 1
 215                   then "this package:"
 216                   else "one of these packages:")^ plist))
 217         else
 218           raise
 219             (CompileFailure ("ocamlfind not found but "^mlfile^" uses "^dep))
 220       else
 221         ([] (* , [] *), "")
 222   | _ ->
 223       raise
 224         (CompileFailure ("Wrong dependencies for "^mlfile^" (Got "^depout^")"))
 225
 226 let dep_flag mlfile =
 227   let depcmd  = !Flag.ocamldep ^" -modules "^mlfile in
 228   match Common.cmd_to_list depcmd with
 229     [dep] -> parse_dep mlfile dep
 230   | _ -> raise (CompileFailure ("Wrong dependencies for "^mlfile))
 231
 232 let compile_bytecode_cmd flags mlfile =
 233   let obj = (Filename.chop_extension mlfile) ^ ".cmo" in
 234   (obj, Printf.sprintf "%s -c %s %s %s" !Flag.ocamlc obj flags mlfile)
 235
 236 let compile_native_cmd flags mlfile =
 237   let obj = (Filename.chop_extension mlfile) ^ ".cmxs" in
 238   (obj,
 239    Printf.sprintf "%s -shared -o %s %s %s" !Flag.ocamlopt obj flags mlfile)
 240
 241 let compile mlfile cmd =
 242   Common.pr2 cmd;
 243   match Sys.command cmd with
 244       0 -> ()
 245     | _ -> raise (CompileFailure mlfile)
 246
 247 let rec load_obj obj =
 248   try
 249     Dynlink.loadfile obj
 250   with Dynlink.Error e ->
 251     match e with
 252         Dynlink.Unsafe_file ->
 253           Dynlink.allow_unsafe_modules true;
 254           load_obj obj
 255       | _ ->
 256           Common.pr2 (Dynlink.error_message e);
 257           raise (LinkFailure obj)
 258
 259 (*
 260 let link_lib (dir, name) = name ^ ext
 261
 262 let link_libs libs =
 263     String.concat " " (List.map link_lib libs)
 264 *)
 265
 266 let load_lib (dir, name) =
 267   let obj = dir ^ "/" ^name ^ ext in
 268     Common.pr2 ("Loading "^ obj ^"...");
 269     load_obj obj
 270
 271 let load_libs libs =
 272   List.iter load_lib libs
 273
 274 let load_file mlfile =
 275   let (ldlibs (* , lklibs *), inc) = dep_flag mlfile in
 276 (*   let linklibs = link_libs lklibs in *)
 277   let flags =
 278     Printf.sprintf
 279     "-thread -g -dtypes -I /usr/lib/ocaml %s -I %s/ocaml -I %s/parsing_c -I %s/commons "
 280       inc Config.path Config.path Config.path in
 281   let (obj, cmd) =
 282     if Dynlink.is_native
 283     then compile_native_cmd flags mlfile
 284     else compile_bytecode_cmd flags mlfile in
 285   compile mlfile cmd;
 286   Common.pr2 "Compilation OK!";
 287   load_libs ldlibs;
 288   Common.pr2 "Loading ML code of the SP...";
 289   try Dynlink.loadfile obj
 290   with Dynlink.Error e ->
 291     Common.pr2 (Dynlink.error_message e);
 292     raise (LinkFailure obj)
 293
 294 let clean_file mlfile =
 295   let basefile = Filename.chop_extension mlfile in
 296   let files =
 297     if Dynlink.is_native then
 298       [basefile ^ ".cmxs";
 299        basefile ^ ".cmx";
 300        basefile ^ ".o";
 301        basefile ^ ".annot"]
 302     else
 303       [basefile ^ ".cmo";
 304        basefile ^ ".annot"]
 305   in
 306     Sys.remove mlfile;
 307     Sys.remove (basefile^".cmi");
 308     List.iter (fun f -> try Sys.remove f with _ -> ()) files
 309
 310 (*
 311   This function is used in testing.ml.
 312   Once the ML file is compiled and loaded,
 313   newly available functions are reported here.
 314 *)
 315 let test () =
 316   Hashtbl.iter
 317     (fun key fct ->
 318        Common.pr2 ("Fct registered: \""^key^"\"")
 319     ) Coccilib.fcts