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