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 (* ---------------------------------------------------------------------- *)
 100 (* Iteration management *)
 101
 102 let print_iteration_code o =
 103   let translator l =
 104     String.concat "\n              | "
 105       (List.map
 106          (function x -> Printf.sprintf "%s -> \"%s\""
 107              (String.capitalize x) x)
 108          l) in
 109   let add_virt_rules_method =
 110     match !Iteration.parsed_virtual_rules with
 111       [] -> ""
 112     | l ->
 113         Printf.sprintf "
 114     method add_virtual_rule r =
 115       let r = match r with %s in
 116       virtual_rules <- Common.union_set [r] virtual_rules\n"
 117           (translator l) in
 118   let add_virt_ids_method =
 119     match !Iteration.parsed_virtual_identifiers with
 120       [] -> ""
 121     | l ->
 122         Printf.sprintf "
 123     method add_virtual_identifier i v =
 124       let i = match i with %s in
 125       try
 126         let v1 = List.assoc i virtual_identifiers in
 127         if not (v = v1)
 128         then failwith (\"multiple values specified for \"^i)
 129       with Not_found ->
 130         virtual_identifiers <- (i,v) :: virtual_identifiers"
 131                                          (translator l) in
 132     Printf.fprintf o "
 133 class iteration () =
 134   object
 135     val mutable files = None
 136     val mutable files_changed = false
 137     val mutable virtual_rules = ([] : string list)
 138     val mutable virtual_identifiers = ([] : (string * string) list)
 139     method set_files f = files <- Some f
 140     %s%s
 141     method register () =
 142       Iteration.add_pending_instance (files,virtual_rules,virtual_identifiers)
 143   end\n\n" add_virt_rules_method add_virt_ids_method
 144
 145 (* ---------------------------------------------------------------------- *)
 146
 147 let prepare_rule (name, metavars, script_vars, code) =
 148   let fname = String.concat "_" (Str.split (Str.regexp " ") name) in
 149   (* function header *)
 150   let function_header body =
 151     Printf.sprintf "let %s args script_args =\n %s" fname body in
 152   (* parameter list *)
 153   let build_parameter_list body =
 154     let ctr = ref 0 in
 155     let lets =
 156       String.concat ""
 157         (List.rev
 158            (List.fold_left
 159               (function prev ->
 160                 function ((str_nm,ast_nm),_,mv) ->
 161                   (* order important; ctr is incremented *)
 162                   let string_rep = string_rep_binding ctr (str_nm,mv) in
 163                   let ast_rep = ast_rep_binding ctr (ast_nm,mv) in
 164                   ast_rep :: string_rep :: prev)
 165               [] metavars)) in
 166     lets ^ (manage_script_vars script_vars) ^ body in
 167   (* add to hash table *)
 168   let hash_add body =
 169     Printf.sprintf
 170       "%s\nlet _ = Hashtbl.add Coccilib.fcts \"%s\" %s\n" body name fname in
 171   hash_add (function_header (build_parameter_list code))
 172
 173 let prepare coccifile code =
 174   let init_rules =
 175     List.fold_left
 176       (function prev ->
 177         function
 178             Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) ->
 179               code :: prev
 180           | _ -> prev)
 181       [] code in
 182   let init_rules = List.rev init_rules in
 183   let other_rules =
 184     List.fold_left
 185       (function prev ->
 186         function
 187             Ast_cocci.ScriptRule (name,"ocaml",deps,mv,script_vars,code) ->
 188               (name,mv,script_vars,code) :: prev
 189           | Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) -> prev
 190           | Ast_cocci.FinalScriptRule (name,"ocaml",deps,code) ->
 191               (name,[],[],code) :: prev
 192           | _ -> prev)
 193       [] code in
 194   let other_rules = List.rev other_rules in
 195   if init_rules = [] && other_rules = []
 196   then None
 197   else
 198     begin
 199       let basefile = Filename.basename (Filename.chop_extension coccifile) in
 200       let basefile =
 201         String.concat "_" (Str.split (Str.regexp "-") basefile) in
 202       let (file,o) = Filename.open_temp_file  basefile ".ml" in
 203       (* Global initialization *)
 204       Printf.fprintf o "%s\n" (init_ocamlcocci());
 205       (* virtual rules and identifiers *)
 206       (if !Iteration.parsed_virtual_rules != []
 207       then
 208         Printf.fprintf o "type __virtual_rules__ = %s\n\n"
 209           (String.concat " | "
 210              (List.map String.capitalize !Iteration.parsed_virtual_rules)));
 211       (if !Iteration.parsed_virtual_identifiers != []
 212       then
 213         Printf.fprintf o "type __virtual_identifiers__ = %s\n\n"
 214           (String.concat " | "
 215              (List.map
 216                 (function x -> Printf.sprintf "%s" x)
 217                 (List.map String.capitalize
 218                    !Iteration.parsed_virtual_identifiers))));
 219       print_iteration_code o;
 220       (* Semantic patch specific initialization *)
 221       Printf.fprintf o "%s" (String.concat "\n\n" init_rules);
 222       (* Semantic patch rules and finalizer *)
 223       let rule_code = List.map prepare_rule other_rules in
 224       Printf.fprintf o "%s" (String.concat "\n\n" rule_code);
 225       close_out o;
 226       check_runtime ();
 227       Some file
 228     end
 229
 230 let filter_dep (accld, accinc) dep =
 231   match dep with
 232       (* Built-in and OCaml defaults are filtered out *)
 233       "Arg" | "Arith_status" | "Array" | "ArrayLabels" | "Big_int" | "Bigarray"
 234     | "Buffer" | "Callback" | "CamlinternalLazy" | "CamlinternalMod"
 235     | "CamlinternalOO"
 236     | "Char" | "Complex" | "Condition" | "Digest" | "Dynlink" | "Event"
 237     | "Filename"
 238     | "Format" | "Gc" | "Genlex" | "GraphicsX11" | "Hashtbl" | "Int32"
 239     | "Int64"
 240     | "Lazy" | "Lexing" | "List" | "ListLabels" | "Map" | "Marshal"
 241     | "MoreLabels" | "Mutex"
 242     | "Nativeint" | "Num" | "Obj" | "Oo" | "Parsing" | "Pervasives"
 243     | "Printexc" | "Printf"
 244     | "Queue" | "Random" | "Scanf" | "Set" | "Sort" | "Stack" | "StdLabels"
 245     | "Str" | "Stream"
 246     | "String" | "StringLabels" | "Sys" | "ThreadUnix" | "Unix" | "UnixLabels"
 247     | "Weak"
 248
 249     (* Coccilib is filtered out too *)
 250     | "Coccilib" | "Common" | "Ast_c" | "Visitor_c" | "Lib_parsing_c"
 251     | "Iteration" ->
 252         (accld, accinc)
 253
 254     | "Dbm"      -> ("dbm"::accld, accinc)
 255     | "Graphics" -> ("graphics"::accld, accinc)
 256     | "Thread"   -> ("thread"::accld, accinc)
 257     | "Tk"       -> ("tk"::accld, accinc)
 258
 259     | _ ->
 260         let l = Char.lowercase (String.get dep 0)in
 261           String.set dep 0 l;
 262           (accld, dep::accinc)
 263
 264 let get_dir p =
 265   let inclcmd = !Flag.ocamlfind ^" query "^p in
 266   let dir = List.hd (Common.cmd_to_list inclcmd) in
 267     (dir, p)
 268
 269 let parse_dep mlfile depout =
 270   let re_colon = Str.regexp_string ":" in
 271   match Str.split re_colon depout with
 272     _::[dep] ->
 273       let deplist = Str.split (Str.regexp_string " ") dep in
 274       let (libs, orderdep) = List.fold_left filter_dep ([],[]) deplist in
 275       if libs <> [] || orderdep <> [] then
 276         if !has_ocamlfind
 277         then
 278           let packages = List.rev orderdep in
 279           let inclflags = List.map get_dir packages in
 280           let intlib = List.map get_dir libs in
 281           let alllibs = List.rev_append intlib inclflags in
 282           let plist =
 283             List.fold_left (fun acc (_,p) -> acc ^" "^p) "" alllibs in
 284           let flags =
 285             String.concat " " (List.map (fun (d,_) -> "-I "^d) inclflags) in
 286           if flags <> "" || libs <> []
 287           then
 288             begin
 289               Common.pr2
 290                 ("Extra OCaml packages used in the semantic patch:"^ plist);
 291               (alllibs (* , inclflags *), flags)
 292             end
 293           else
 294             raise
 295               (CompileFailure
 296                  ("ocamlfind did not find "^
 297                   (if (List.length libs + List.length orderdep) = 1
 298                   then "this package:"
 299                   else "one of these packages:")^ plist))
 300         else
 301           raise
 302             (CompileFailure ("ocamlfind not found but "^mlfile^" uses "^dep))
 303       else
 304         ([] (* , [] *), "")
 305   | _ ->
 306       raise
 307         (CompileFailure ("Wrong dependencies for "^mlfile^" (Got "^depout^")"))
 308
 309 let dep_flag mlfile =
 310   let depcmd  = !Flag.ocamldep ^" -modules "^mlfile in
 311   match Common.cmd_to_list depcmd with
 312     [dep] -> parse_dep mlfile dep
 313   | err ->
 314       List.iter (function x -> Common.pr2 (x^"\n")) err;
 315       raise (CompileFailure ("Failed ocamldep for "^mlfile))
 316
 317 let compile_bytecode_cmd flags mlfile =
 318   let obj = (Filename.chop_extension mlfile) ^ ".cmo" in
 319   (obj, Printf.sprintf "%s -c %s %s %s" !Flag.ocamlc obj flags mlfile)
 320
 321 let compile_native_cmd flags mlfile =
 322   let obj = (Filename.chop_extension mlfile) ^ ".cmxs" in
 323   (obj,
 324    Printf.sprintf "%s -shared -o %s %s %s" !Flag.ocamlopt obj flags mlfile)
 325
 326 let compile mlfile cmd =
 327   Common.pr2 cmd;
 328   match Sys.command cmd with
 329       0 -> ()
 330     | _ -> raise (CompileFailure mlfile)
 331
 332 let rec load_obj obj =
 333   try
 334     Dynlink.loadfile obj
 335   with Dynlink.Error e ->
 336     match e with
 337         Dynlink.Unsafe_file ->
 338           Dynlink.allow_unsafe_modules true;
 339           load_obj obj
 340       | _ ->
 341           Common.pr2 (Dynlink.error_message e);
 342           raise (LinkFailure obj)
 343
 344 (*
 345 let link_lib (dir, name) = name ^ ext
 346
 347 let link_libs libs =
 348     String.concat " " (List.map link_lib libs)
 349 *)
 350
 351 let load_lib (dir, name) =
 352   let obj = dir ^ "/" ^name ^ ext in
 353     Common.pr2 ("Loading "^ obj ^"...");
 354     load_obj obj
 355
 356 let load_libs libs =
 357   List.iter load_lib libs
 358
 359 let load_file mlfile =
 360   let (ldlibs (* , lklibs *), inc) = dep_flag mlfile in
 361 (*   let linklibs = link_libs lklibs in *)
 362   let flags =
 363     Printf.sprintf
 364     "-thread -g -dtypes -I %s %s -I %s/globals -I %s/ocaml -I %s/parsing_c -I %s/commons "
 365       sysdir inc Config.path Config.path Config.path Config.path in
 366   let (obj, cmd) =
 367     if Dynlink.is_native
 368     then compile_native_cmd flags mlfile
 369     else compile_bytecode_cmd flags mlfile in
 370   compile mlfile cmd;
 371   Common.pr2 "Compilation OK!";
 372   load_libs ldlibs;
 373   Common.pr2 "Loading ML code of the SP...";
 374   try Dynlink.loadfile obj
 375   with Dynlink.Error e ->
 376     Common.pr2 (Dynlink.error_message e);
 377     raise (LinkFailure obj)
 378
 379 let clean_file mlfile =
 380   let basefile = Filename.chop_extension mlfile in
 381   let files =
 382     if Dynlink.is_native then
 383       [basefile ^ ".cmxs";
 384        basefile ^ ".cmx";
 385        basefile ^ ".o";
 386        basefile ^ ".annot"]
 387     else
 388       [basefile ^ ".cmo";
 389        basefile ^ ".annot"]
 390   in
 391     Sys.remove mlfile;
 392     Sys.remove (basefile^".cmi");
 393     List.iter (fun f -> try Sys.remove f with _ -> ()) files
 394
 395 (*
 396   This function is used in testing.ml.
 397   Once the ML file is compiled and loaded,
 398   newly available functions are reported here.
 399 *)
 400 let test () =
 401   Hashtbl.iter
 402     (fun key fct ->
 403        Common.pr2 ("Fct registered: \""^key^"\"")
 404     ) Coccilib.fcts