3 exception CompileFailure
of string
4 exception LinkFailure
of string
6 let ext = if Dynlink.is_native
then ".cmxs" else ".cma"
9 let sysdircmd = !Flag.ocamlfind ^
" printconf stdlib" in
10 match Common.cmd_to_list
sysdircmd with
12 | _
-> raise
(CompileFailure
(sysdircmd ^
" has failed"))
15 let (_
,stat
) = Common.cmd_to_list_and_status cmd
in
17 Unix.WEXITED
0 -> true
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
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"
32 Common.pr2
"Using bytecode version of ocamlc/ocamlopt/ocamldep"
34 if Dynlink.is_native
then
36 "No OCaml compiler found! Install either ocamlopt or ocamlopt.opt"
39 "No OCaml compiler found! Install either ocamlc or ocamlc.opt"
41 let init_ocamlcocci _
=
44 let print_match ctr nm kind
=
45 let endlet = "| _ -> failwith \"bad value\" in\n" in
49 "let %s = match List.nth args %d with Coccilib.%s x -> x %s"
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"
59 let ast_rep_binding ctr
= function
60 (Some nm
,Ast.MetaPosDecl _
) ->
62 (Printf.sprintf
"%s: No AST representation for position variables" nm
)
63 | (Some nm
,Ast.MetaMetaDecl _
) ->
66 "%s: No AST representation for metavariables declared as \"%s\""
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.MetaInitListDecl _
) -> print_match ctr nm
"InitList"
73 | (Some nm
,Ast.MetaListlenDecl _
) ->
75 (Printf.sprintf
"%s: No AST representation for listlen variables" nm
)
76 | (Some nm
,Ast.MetaParamDecl _
) -> print_match ctr nm
"Param"
77 | (Some nm
,Ast.MetaParamListDecl _
) -> print_match ctr nm
"ParamList"
78 | (Some nm
,Ast.MetaConstDecl _
) -> print_match ctr nm
"Expr"
79 | (Some nm
,Ast.MetaErrDecl _
) -> failwith
("not supported: "^nm
)
80 | (Some nm
,Ast.MetaExpDecl _
) -> print_match ctr nm
"Expr"
81 | (Some nm
,Ast.MetaIdExpDecl _
) -> print_match ctr nm
"Expr"
82 | (Some nm
,Ast.MetaLocalIdExpDecl _
) -> print_match ctr nm
"Expr"
83 | (Some nm
,Ast.MetaExpListDecl _
) -> print_match ctr nm
"ExprList"
84 | (Some nm
,Ast.MetaDeclDecl _
) -> print_match ctr nm
"Decl"
85 | (Some nm
,Ast.MetaFieldDecl _
) -> print_match ctr nm
"Field"
86 | (Some nm
,Ast.MetaFieldListDecl _
) -> print_match ctr nm
"FieldList"
87 | (Some nm
,Ast.MetaStmDecl _
) -> print_match ctr nm
"Stmt"
88 | (Some nm
,Ast.MetaStmListDecl _
) -> failwith
("not supported: "^nm
)
89 | (Some nm
,Ast.MetaFuncDecl _
) -> print_match ctr nm
"Str"
90 | (Some nm
,Ast.MetaLocalFuncDecl _
) -> print_match ctr nm
"Str"
91 | (Some nm
,Ast.MetaDeclarerDecl _
) -> print_match ctr nm
"Str"
92 | (Some nm
,Ast.MetaIteratorDecl _
) -> print_match ctr nm
"Str"
95 let manage_script_vars script_vars
=
96 let rec loop n
= function
99 (Printf.sprintf
"let %s = List.nth script_args %d in\n" x n
) ^
103 (* ---------------------------------------------------------------------- *)
104 (* Iteration management *)
106 let print_iteration_code o
=
108 String.concat
"\n | "
110 (function x
-> Printf.sprintf
"%s -> \"%s\""
111 (String.capitalize x
) x
)
113 let add_virt_rules_method =
114 match !Iteration.parsed_virtual_rules
with
118 method add_virtual_rule r =
119 let r = match r with %s in
120 virtual_rules <- Common.union_set [r] virtual_rules\n"
122 let add_virt_ids_method =
123 match !Iteration.parsed_virtual_identifiers
with
127 method add_virtual_identifier i v =
128 let i = match i with %s in
130 let v1 = List.assoc i virtual_identifiers in
132 then failwith (\"multiple values specified for \"^i)
134 virtual_identifiers <- (i,v) :: virtual_identifiers"
139 val mutable files = None
140 val mutable files_changed = false
141 val mutable virtual_rules = ([] : string list)
142 val mutable virtual_identifiers = ([] : (string * string) list)
143 method set_files f = files <- Some f
146 Iteration.add_pending_instance (files,virtual_rules,virtual_identifiers)
147 end\n\n" add_virt_rules_method add_virt_ids_method
149 (* ---------------------------------------------------------------------- *)
151 let prepare_rule (name
, metavars
, script_vars
, code
) =
152 let fname = String.concat
"_" (Str.split
(Str.regexp
" ") name
) in
153 (* function header *)
154 let function_header body
=
155 Printf.sprintf
"let %s args script_args =\n %s" fname body
in
157 let build_parameter_list body
=
164 function ((str_nm
,ast_nm
),_
,mv
) ->
165 (* order important; ctr is incremented *)
166 let string_rep = string_rep_binding ctr (str_nm
,mv
) in
167 let ast_rep = ast_rep_binding ctr (ast_nm
,mv
) in
168 ast_rep :: string_rep :: prev
)
170 lets ^
(manage_script_vars script_vars
) ^ body
in
171 (* add to hash table *)
174 "%s\nlet _ = Hashtbl.add Coccilib.fcts \"%s\" %s\n" body name
fname in
175 hash_add (function_header (build_parameter_list code
))
177 let prepare coccifile code
=
182 Ast_cocci.InitialScriptRule
(name
,"ocaml",deps
,code
) ->
186 let init_rules = List.rev
init_rules in
191 Ast_cocci.ScriptRule
(name
,"ocaml",deps
,mv
,script_vars
,code
) ->
192 (name
,mv
,script_vars
,code
) :: prev
193 | Ast_cocci.InitialScriptRule
(name
,"ocaml",deps
,code
) -> prev
194 | Ast_cocci.FinalScriptRule
(name
,"ocaml",deps
,code
) ->
195 (name
,[],[],code
) :: prev
198 let other_rules = List.rev
other_rules in
199 if init_rules = [] && other_rules = []
203 let basefile = Filename.basename
(Filename.chop_extension coccifile
) in
205 String.concat
"_" (Str.split
(Str.regexp
"-") basefile) in
206 let (file
,o
) = Filename.open_temp_file
basefile ".ml" in
207 (* Global initialization *)
208 Printf.fprintf o
"%s\n" (init_ocamlcocci());
209 (* virtual rules and identifiers *)
210 (if !Iteration.parsed_virtual_rules
!= []
212 Printf.fprintf o
"type __virtual_rules__ = %s\n\n"
214 (List.map
String.capitalize
!Iteration.parsed_virtual_rules
)));
215 (if !Iteration.parsed_virtual_identifiers
!= []
217 Printf.fprintf o
"type __virtual_identifiers__ = %s\n\n"
220 (function x
-> Printf.sprintf
"%s" x
)
221 (List.map
String.capitalize
222 !Iteration.parsed_virtual_identifiers
))));
223 print_iteration_code o
;
224 (* Semantic patch specific initialization *)
225 Printf.fprintf o
"%s" (String.concat
"\n\n" init_rules);
226 (* Semantic patch rules and finalizer *)
227 let rule_code = List.map
prepare_rule other_rules in
228 Printf.fprintf o
"%s" (String.concat
"\n\n" rule_code);
234 let filter_dep (accld
, accinc
) dep
=
236 (* Built-in and OCaml defaults are filtered out *)
237 "Arg" | "Arith_status" | "Array" | "ArrayLabels" | "Big_int" | "Bigarray"
238 | "Buffer" | "Callback" | "CamlinternalLazy" | "CamlinternalMod"
240 | "Char" | "Complex" | "Condition" | "Digest" | "Dynlink" | "Event"
242 | "Format" | "Gc" | "Genlex" | "GraphicsX11" | "Hashtbl" | "Int32"
244 | "Lazy" | "Lexing" | "List" | "ListLabels" | "Map" | "Marshal"
245 | "MoreLabels" | "Mutex"
246 | "Nativeint" | "Num" | "Obj" | "Oo" | "Parsing" | "Pervasives"
247 | "Printexc" | "Printf"
248 | "Queue" | "Random" | "Scanf" | "Set" | "Sort" | "Stack" | "StdLabels"
250 | "String" | "StringLabels" | "Sys" | "ThreadUnix" | "Unix" | "UnixLabels"
253 (* Coccilib is filtered out too *)
254 | "Coccilib" | "Common" | "Ast_c" | "Visitor_c" | "Lib_parsing_c"
258 | "Dbm" -> ("dbm"::accld
, accinc
)
259 | "Graphics" -> ("graphics"::accld
, accinc
)
260 | "Thread" -> ("thread"::accld
, accinc
)
261 | "Tk" -> ("tk"::accld
, accinc
)
264 let l = Char.lowercase
(String.get dep
0)in
269 let inclcmd = !Flag.ocamlfind ^
" query "^p
in
270 let dir = List.hd
(Common.cmd_to_list
inclcmd) in
273 let parse_dep mlfile depout
=
274 let re_colon = Str.regexp_string
":" in
275 match Str.split
re_colon depout
with
277 let deplist = Str.split
(Str.regexp_string
" ") dep
in
278 let (libs
, orderdep
) = List.fold_left
filter_dep ([],[]) deplist in
279 if libs
<> [] || orderdep
<> [] then
281 if check_cmd (!Flag.ocamlfind ^
" printconf 2>&1 > /dev/null")
283 let packages = List.rev orderdep
in
284 let inclflags = List.map
get_dir packages in
285 let intlib = List.map
get_dir libs
in
286 let alllibs = List.rev_append
intlib inclflags in
288 List.fold_left
(fun acc
(_,p
) -> acc ^
" "^p
) "" alllibs in
290 String.concat
" " (List.map
(fun (d
,_) -> "-I "^d
) inclflags) in
291 if flags <> "" || libs
<> []
295 ("Extra OCaml packages used in the semantic patch:"^
plist);
296 (alllibs (* , inclflags *), flags)
301 ("ocamlfind did not find "^
302 (if (List.length libs
+ List.length orderdep
) = 1
304 else "one of these packages:")^
plist))
307 (CompileFailure
("ocamlfind not found but "^mlfile^
" uses "^dep
))
313 (CompileFailure
("Wrong dependencies for "^mlfile^
" (Got "^depout^
")"))
315 let dep_flag mlfile
=
316 let depcmd = !Flag.ocamldep ^
" -modules "^mlfile
in
317 match Common.cmd_to_list
depcmd with
318 [dep
] -> parse_dep mlfile dep
320 List.iter
(function x
-> Common.pr2
(x^
"\n")) err
;
321 raise
(CompileFailure
("Failed ocamldep for "^mlfile
))
323 let compile_bytecode_cmd flags mlfile
=
324 let obj = (Filename.chop_extension mlfile
) ^
".cmo" in
325 (obj, Printf.sprintf
"%s -c %s %s %s" !Flag.ocamlc
obj flags mlfile
)
327 let compile_native_cmd flags mlfile
=
328 let obj = (Filename.chop_extension mlfile
) ^
".cmxs" in
330 Printf.sprintf
"%s -shared -o %s %s %s" !Flag.ocamlopt
obj flags mlfile
)
332 let compile mlfile cmd
=
334 match Sys.command cmd
with
336 | _ -> raise
(CompileFailure mlfile
)
338 let rec load_obj obj =
341 with Dynlink.Error e
->
343 Dynlink.Unsafe_file
->
344 Dynlink.allow_unsafe_modules
true;
347 Common.pr2
(Dynlink.error_message e
);
348 raise
(LinkFailure
obj)
351 let link_lib (dir, name) = name ^ ext
354 String.concat " " (List.map link_lib libs)
357 let load_lib (dir, name
) =
358 let obj = dir ^
"/" ^name ^
ext in
359 Common.pr2
("Loading "^
obj ^
"...");
363 List.iter
load_lib libs
365 let load_file mlfile
=
366 let (ldlibs
(* , lklibs *), inc
) = dep_flag mlfile
in
367 (* let linklibs = link_libs lklibs in *)
370 "-thread -g -dtypes -I %s %s -I %s/globals -I %s/ocaml -I %s/parsing_c -I %s/commons "
371 (sysdir ()) inc
Config.path
Config.path
Config.path
Config.path
in
374 then compile_native_cmd flags mlfile
375 else compile_bytecode_cmd flags mlfile
in
377 Common.pr2
"Compilation OK!";
379 Common.pr2
"Loading ML code of the SP...";
380 try Dynlink.loadfile
obj
381 with Dynlink.Error e
->
382 Common.pr2
(Dynlink.error_message e
);
383 raise
(LinkFailure
obj)
385 let clean_file mlfile
=
386 let basefile = Filename.chop_extension mlfile
in
388 if Dynlink.is_native
then
398 Sys.remove
(basefile^
".cmi");
399 List.iter
(fun f
-> try Sys.remove f
with _ -> ()) files
402 This function is used in testing.ml.
403 Once the ML file is compiled and loaded,
404 newly available functions are reported here.
409 Common.pr2
("Fct registered: \""^key^
"\"")