[bpt/coccinelle.git] / ocaml / yes_prepare_ocamlcocci.ml

module Ast = Ast_cocci

exception CompileFailure of string
exception LinkFailure of string

let ext = if Dynlink.is_native then ".cmxs" else ".cma"
let has_ocamlfind = ref false

let sysdir = 
  let sysdircmd = !Flag.ocamlfind ^ " printconf stdlib" in
  match Common.cmd_to_list sysdircmd with
    [sysdir] -> sysdir
  | _ -> raise (CompileFailure (sysdircmd ^" has failed"))

let check_cmd cmd =
  let (_,stat) = Common.cmd_to_list_and_status cmd in
  match stat with
      Unix.WEXITED 0 -> true
    | _ -> false

let check_runtime () =
  let has_opt  = check_cmd (!Flag.ocamlc ^".opt -version 2>&1 > /dev/null") in
  let has_c    = check_cmd (!Flag.ocamlc ^" -version 2>&1 > /dev/null") in
  let has_find = check_cmd (!Flag.ocamlfind ^ " printconf 2>&1 > /dev/null") in
    has_ocamlfind := has_find;
    if has_opt then
      begin
	Flag.ocamlc   := !Flag.ocamlc   ^ ".opt";
	Flag.ocamlopt := !Flag.ocamlopt ^ ".opt";
	Flag.ocamldep := !Flag.ocamldep ^ ".opt";
	Common.pr2 "Using native version of ocamlc/ocamlopt/ocamldep"
      end
    else
      if has_c then
	Common.pr2 "Using bytecode version of ocamlc/ocamlopt/ocamldep"
      else
	if Dynlink.is_native then
	  failwith
	    "No OCaml compiler found! Install either ocamlopt or ocamlopt.opt"
	else
	  failwith
	    "No OCaml compiler found! Install either ocamlc or ocamlc.opt"

let init_ocamlcocci _ =
  "open Coccilib\n"

let print_match ctr nm kind =
  let endlet = "| _ -> failwith \"bad value\" in\n" in
  let index = !ctr in
  ctr := !ctr + 1;
  Printf.sprintf
    "let %s = match List.nth args %d with Coccilib.%s x -> x %s"
    nm index kind endlet

let string_rep_binding ctr = function
    (Some nm,Ast.MetaPosDecl _) -> print_match ctr nm "Pos"
  | (Some nm,Ast.MetaListlenDecl _) -> print_match ctr nm "Int"
  | (Some nm,_) (* strings for everything else *) ->
      print_match ctr nm "Str"
  | (None,_) -> ""

let ast_rep_binding ctr = function
    (Some nm,Ast.MetaPosDecl _) ->
      failwith
	(Printf.sprintf "%s: No AST representation for position variables" nm)
  | (Some nm,Ast.MetaIdDecl _) -> print_match ctr nm "Str"
  | (Some nm,Ast.MetaFreshIdDecl _) -> print_match ctr nm "Str"
  | (Some nm,Ast.MetaTypeDecl _) -> print_match ctr nm "Type"
  | (Some nm,Ast.MetaInitDecl _) -> print_match ctr nm "Init"
  | (Some nm,Ast.MetaListlenDecl _) ->
      failwith
	(Printf.sprintf "%s: No AST representation for listlen variables" nm)
  | (Some nm,Ast.MetaParamDecl _) -> print_match ctr nm "Param"
  | (Some nm,Ast.MetaParamListDecl _) -> print_match ctr nm "ParamList"
  | (Some nm,Ast.MetaConstDecl _) -> print_match ctr nm "Expr"
  | (Some nm,Ast.MetaErrDecl _) -> failwith ("not supported: "^nm)
  | (Some nm,Ast.MetaExpDecl _) -> print_match ctr nm "Expr"
  | (Some nm,Ast.MetaIdExpDecl _) -> print_match ctr nm "Expr"
  | (Some nm,Ast.MetaLocalIdExpDecl _) -> print_match ctr nm "Expr"
  | (Some nm,Ast.MetaExpListDecl _) -> print_match ctr nm "ExprList"
  | (Some nm,Ast.MetaDeclDecl _) -> print_match ctr nm "Decl"
  | (Some nm,Ast.MetaFieldDecl _) -> print_match ctr nm "Field"
  | (Some nm,Ast.MetaStmDecl _) -> print_match ctr nm "Stmt"
  | (Some nm,Ast.MetaStmListDecl _) -> failwith ("not supported: "^nm)
  | (Some nm,Ast.MetaFuncDecl _) -> print_match ctr nm "Str"
  | (Some nm,Ast.MetaLocalFuncDecl _) -> print_match ctr nm "Str"
  | (Some nm,Ast.MetaDeclarerDecl _) -> print_match ctr nm "Str"
  | (Some nm,Ast.MetaIteratorDecl _) -> print_match ctr nm "Str"
  | (None,_) -> ""

let manage_script_vars script_vars =
  let rec loop n = function
      [] -> ""
    | (_,x)::xs ->
	(Printf.sprintf "let %s = List.nth script_args %d in\n" x n) ^
	(loop (n+1) xs) in
  loop 0 script_vars

let prepare_rule (name, metavars, script_vars, code) =
  let fname = String.concat "_" (Str.split (Str.regexp " ") name) in
  (* function header *)
  let function_header body =
    Printf.sprintf "let %s args script_args =\n %s" fname body in
  (* parameter list *)
  let build_parameter_list body =
    let ctr = ref 0 in
    let lets =
      String.concat ""
	(List.rev
	   (List.fold_left
	      (function prev ->
		function ((str_nm,ast_nm),_,mv) ->
	          (* order important; ctr is incremented *)
		  let string_rep = string_rep_binding ctr (str_nm,mv) in
		  let ast_rep = ast_rep_binding ctr (ast_nm,mv) in
		  ast_rep :: string_rep :: prev)
	      [] metavars)) in
    lets ^ (manage_script_vars script_vars) ^ body in
  (* add to hash table *)
  let hash_add body =
    Printf.sprintf
      "%s\nlet _ = Hashtbl.add Coccilib.fcts \"%s\" %s\n" body name fname in
  hash_add (function_header (build_parameter_list code))

let prepare coccifile code =
  let init_rules =
    List.fold_left
      (function prev ->
	function
	    Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) ->
	      code :: prev
	  | _ -> prev)
      [] code in
  let init_rules = List.rev init_rules in
  let other_rules =
    List.fold_left
      (function prev ->
	function
	    Ast_cocci.ScriptRule (name,"ocaml",deps,mv,script_vars,code) ->
	      (name,mv,script_vars,code) :: prev
	  | Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) -> prev
	  | Ast_cocci.FinalScriptRule (name,"ocaml",deps,code) ->
	      (name,[],[],code) :: prev
	  | _ -> prev)
      [] code in
  let other_rules = List.rev other_rules in
  if init_rules = [] && other_rules = []
  then None
  else
    let basefile = Filename.basename (Filename.chop_extension coccifile) in
    let basefile =
      String.concat "_" (Str.split (Str.regexp "-") basefile) in
    let (file,o) = Filename.open_temp_file  basefile ".ml" in
      (* Global initialization *)
      Printf.fprintf o "%s" (init_ocamlcocci());
      (* Semantic patch specific initialization *)
      Printf.fprintf o "%s" (String.concat "\n\n" init_rules);
      (* Semantic patch rules and finalizer *)
      let rule_code = List.map prepare_rule other_rules in
	Printf.fprintf o "%s" (String.concat "\n\n" rule_code);
	close_out o;
	check_runtime ();
	Some file

let filter_dep (accld, accinc) dep =
  match dep with
      (* Built-in and OCaml defaults are filtered out *)
      "Arg" | "Arith_status" | "Array" | "ArrayLabels" | "Big_int" | "Bigarray"
    | "Buffer" | "Callback" | "CamlinternalLazy" | "CamlinternalMod"
    | "CamlinternalOO"
    | "Char" | "Complex" | "Condition" | "Digest" | "Dynlink" | "Event"
    | "Filename"
    | "Format" | "Gc" | "Genlex" | "GraphicsX11" | "Hashtbl" | "Int32"
    | "Int64"
    | "Lazy" | "Lexing" | "List" | "ListLabels" | "Map" | "Marshal"
    | "MoreLabels" | "Mutex"
    | "Nativeint" | "Num" | "Obj" | "Oo" | "Parsing" | "Pervasives"
    | "Printexc" | "Printf"
    | "Queue" | "Random" | "Scanf" | "Set" | "Sort" | "Stack" | "StdLabels"
    | "Str" | "Stream"
    | "String" | "StringLabels" | "Sys" | "ThreadUnix" | "Unix" | "UnixLabels"
    | "Weak"

    (* Coccilib is filtered out too *)
    | "Coccilib" | "Common" | "Ast_c" | "Visitor_c" | "Lib_parsing_c" ->
	(accld, accinc)

    | "Dbm"      -> ("dbm"::accld, accinc)
    | "Graphics" -> ("graphics"::accld, accinc)
    | "Thread"   -> ("thread"::accld, accinc)
    | "Tk"       -> ("tk"::accld, accinc)

    | _ ->
	let l = Char.lowercase (String.get dep 0)in
	  String.set dep 0 l;
	  (accld, dep::accinc)

let get_dir p =
  let inclcmd = !Flag.ocamlfind ^" query "^p in
  let dir = List.hd (Common.cmd_to_list inclcmd) in
    (dir, p)

let parse_dep mlfile depout =
  let re_colon = Str.regexp_string ":" in
  match Str.split re_colon depout with
    _::[dep] ->
      let deplist = Str.split (Str.regexp_string " ") dep in
      let (libs, orderdep) = List.fold_left filter_dep ([],[]) deplist in
      if libs <> [] || orderdep <> [] then
	if !has_ocamlfind
	then
	  let packages = List.rev orderdep in
	  let inclflags = List.map get_dir packages in
	  let intlib = List.map get_dir libs in
	  let alllibs = List.rev_append intlib inclflags in
	  let plist =
	    List.fold_left (fun acc (_,p) -> acc ^" "^p) "" alllibs in
	  let flags =
	    String.concat " " (List.map (fun (d,_) -> "-I "^d) inclflags) in
	  if flags <> "" || libs <> []
	  then
	    begin
	      Common.pr2
		("Extra OCaml packages used in the semantic patch:"^ plist);
	      (alllibs (* , inclflags *), flags)
	    end
	  else
	    raise
	      (CompileFailure
		 ("ocamlfind did not find "^
		  (if (List.length libs + List.length orderdep) = 1
		  then "this package:"
		  else "one of these packages:")^ plist))
	else
	  raise
	    (CompileFailure ("ocamlfind not found but "^mlfile^" uses "^dep))
      else
	([] (* , [] *), "")
  | _ ->
      raise
	(CompileFailure ("Wrong dependencies for "^mlfile^" (Got "^depout^")"))

let dep_flag mlfile =
  let depcmd  = !Flag.ocamldep ^" -modules "^mlfile in
  match Common.cmd_to_list depcmd with
    [dep] -> parse_dep mlfile dep
  | err ->
      List.iter (function x -> Common.pr2 (x^"\n")) err;
      raise (CompileFailure ("Failed ocamldep for "^mlfile))

let compile_bytecode_cmd flags mlfile =
  let obj = (Filename.chop_extension mlfile) ^ ".cmo" in
  (obj, Printf.sprintf "%s -c %s %s %s" !Flag.ocamlc obj flags mlfile)

let compile_native_cmd flags mlfile =
  let obj = (Filename.chop_extension mlfile) ^ ".cmxs" in
  (obj,
   Printf.sprintf "%s -shared -o %s %s %s" !Flag.ocamlopt obj flags mlfile)

let compile mlfile cmd =
  Common.pr2 cmd;
  match Sys.command cmd with
      0 -> ()
    | _ -> raise (CompileFailure mlfile)

let rec load_obj obj =
  try
    Dynlink.loadfile obj
  with Dynlink.Error e ->
    match e with
	Dynlink.Unsafe_file ->
	  Dynlink.allow_unsafe_modules true;
	  load_obj obj
      | _ ->
	  Common.pr2 (Dynlink.error_message e);
	  raise (LinkFailure obj)

(*
let link_lib (dir, name) = name ^ ext

let link_libs libs =
    String.concat " " (List.map link_lib libs)
*)

let load_lib (dir, name) =
  let obj = dir ^ "/" ^name ^ ext in
    Common.pr2 ("Loading "^ obj ^"...");
    load_obj obj

let load_libs libs =
  List.iter load_lib libs

let load_file mlfile =
  let (ldlibs (* , lklibs *), inc) = dep_flag mlfile in
(*   let linklibs = link_libs lklibs in *)
  let flags =
    Printf.sprintf
    "-thread -g -dtypes -I %s %s -I %s/ocaml -I %s/parsing_c -I %s/commons "
      sysdir inc Config.path Config.path Config.path in
  let (obj, cmd) =
    if Dynlink.is_native
    then compile_native_cmd flags mlfile
    else compile_bytecode_cmd flags mlfile in
  compile mlfile cmd;
  Common.pr2 "Compilation OK!";
  load_libs ldlibs;
  Common.pr2 "Loading ML code of the SP...";
  try Dynlink.loadfile obj
  with Dynlink.Error e ->
    Common.pr2 (Dynlink.error_message e);
    raise (LinkFailure obj)

let clean_file mlfile =
  let basefile = Filename.chop_extension mlfile in
  let files =
    if Dynlink.is_native then
      [basefile ^ ".cmxs";
       basefile ^ ".cmx";
       basefile ^ ".o";
       basefile ^ ".annot"]
    else
      [basefile ^ ".cmo";
       basefile ^ ".annot"]
  in
    Sys.remove mlfile;
    Sys.remove (basefile^".cmi");
    List.iter (fun f -> try Sys.remove f with _ -> ()) files

(*
  This function is used in testing.ml.
  Once the ML file is compiled and loaded,
  newly available functions are reported here.
*)
let test () =
  Hashtbl.iter
    (fun key fct ->
       Common.pr2 ("Fct registered: \""^key^"\"")
    ) Coccilib.fcts
Commit	Line	Data
174d1640 C	1	module Ast = Ast_cocci
	2
	3	exception CompileFailure of string
	4	exception LinkFailure of string
	5
aba5c457	6	let ext = if Dynlink.is_native then ".cmxs" else ".cma"
174d1640 C	7	let has_ocamlfind = ref false
174d1640 C	8
1eddfd50 C	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
174d1640	15	let check_cmd cmd =
c491d8ee C	16	let (_,stat) = Common.cmd_to_list_and_status cmd in
	17	match stat with
	18	Unix.WEXITED 0 -> true
174d1640 C	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
aba5c457 C	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"
413ffc02 C	81	\| (Some nm,Ast.MetaDeclDecl _) -> print_match ctr nm "Decl"
413ffc02 C	82	\| (Some nm,Ast.MetaFieldDecl _) -> print_match ctr nm "Field"
aba5c457 C	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
413ffc02 C	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) =
174d1640 C	100	let fname = String.concat "_" (Str.split (Str.regexp " ") name) in
	101	(* function header *)
	102	let function_header body =
413ffc02	103	Printf.sprintf "let %s args script_args =\n %s" fname body in
174d1640 C	104	(* parameter list *)
	105	let build_parameter_list body =
	106	let ctr = ref 0 in
aba5c457 C	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
413ffc02	118	lets ^ (manage_script_vars script_vars) ^ body in
174d1640 C	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
413ffc02 C	139	Ast_cocci.ScriptRule (name,"ocaml",deps,mv,script_vars,code) ->
413ffc02 C	140	(name,mv,script_vars,code) :: prev
174d1640 C	141	\| Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) -> prev
174d1640 C	142	\| Ast_cocci.FinalScriptRule (name,"ocaml",deps,code) ->
413ffc02	143	(name,[],[],code) :: prev
174d1640 C	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
aba5c457 C	151	let basefile =
aba5c457 C	152	String.concat "_" (Str.split (Str.regexp "-") basefile) in
174d1640 C	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
aba5c457	165	let filter_dep (accld, accinc) dep =
174d1640 C	166	match dep with
	167	(* Built-in and OCaml defaults are filtered out *)
	168	"Arg" \| "Arith_status" \| "Array" \| "ArrayLabels" \| "Big_int" \| "Bigarray"
aba5c457 C	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"
174d1640 C	182	\| "Weak"
	183
	184	(* Coccilib is filtered out too *)
aba5c457 C	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)
174d1640 C	192
	193	\| _ ->
	194	let l = Char.lowercase (String.get dep 0)in
	195	String.set dep 0 l;
aba5c457 C	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)
174d1640 C	202
	203	let parse_dep mlfile depout =
	204	let re_colon = Str.regexp_string ":" in
	205	match Str.split re_colon depout with
aba5c457 C	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
174d1640	227	else
aba5c457 C	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^")"))
413ffc02	242
174d1640 C	243	let dep_flag mlfile =
174d1640 C	244	let depcmd = !Flag.ocamldep ^" -modules "^mlfile in
aba5c457 C	245	match Common.cmd_to_list depcmd with
aba5c457 C	246	[dep] -> parse_dep mlfile dep
1eddfd50 C	247	\| err ->
	248	List.iter (function x -> Common.pr2 (x^"\n")) err;
	249	raise (CompileFailure ("Failed ocamldep for "^mlfile))
413ffc02	250
174d1640 C	251	let compile_bytecode_cmd flags mlfile =
174d1640 C	252	let obj = (Filename.chop_extension mlfile) ^ ".cmo" in
aba5c457	253	(obj, Printf.sprintf "%s -c %s %s %s" !Flag.ocamlc obj flags mlfile)
413ffc02	254
174d1640 C	255	let compile_native_cmd flags mlfile =
174d1640 C	256	let obj = (Filename.chop_extension mlfile) ^ ".cmxs" in
aba5c457 C	257	(obj,
aba5c457 C	258	Printf.sprintf "%s -shared -o %s %s %s" !Flag.ocamlopt obj flags mlfile)
174d1640 C	259
	260	let compile mlfile cmd =
	261	Common.pr2 cmd;
	262	match Sys.command cmd with
	263	0 -> ()
	264	\| _ -> raise (CompileFailure mlfile)
	265
aba5c457 C	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
174d1640	293	let load_file mlfile =
aba5c457 C	294	let (ldlibs (* , lklibs *), inc) = dep_flag mlfile in
	295	(* let linklibs = link_libs lklibs in *)
	296	let flags =
	297	Printf.sprintf
1eddfd50 C	298	"-thread -g -dtypes -I %s %s -I %s/ocaml -I %s/parsing_c -I %s/commons "
1eddfd50 C	299	sysdir inc Config.path Config.path Config.path in
174d1640 C	300	let (obj, cmd) =
	301	if Dynlink.is_native
	302	then compile_native_cmd flags mlfile
aba5c457 C	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)
174d1640 C	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";
aba5c457 C	319	basefile ^ ".o";
aba5c457 C	320	basefile ^ ".annot"]
174d1640	321	else
aba5c457 C	322	[basefile ^ ".cmo";
aba5c457 C	323	basefile ^ ".annot"]
174d1640 C	324	in
	325	Sys.remove mlfile;
	326	Sys.remove (basefile^".cmi");
aba5c457	327	List.iter (fun f -> try Sys.remove f with _ -> ()) files
174d1640 C	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