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