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