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