| 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 |