2 * Copyright (C) 2010, University of Copenhagen DIKU and INRIA.
3 * Copyright (C) 2006, 2007 Julia Lawall
5 * This program is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU General Public License (GPL)
7 * version 2 as published by the Free Software Foundation.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * file license.txt for more details.
14 * This file was part of Coccinelle.
17 module Ast
= Ast_cocci
18 module V
= Visitor_ast
22 (Printf.sprintf
"unparse_hrule: line: %d, %s" (Ast.get_line x
) s
)
24 let names = ref ([] : (string * int ref) list
)
26 let started_files = ref ([] : (string * bool) list
)
27 let typedefs = ref ([] : (string * string list
ref) list
)
28 let current_outfile = ref ""
30 let prefix = "_cocci_"
32 (* ----------------------------------------------------------------------- *)
33 (* Create rule to check for header include *)
35 let print_header_rule pr srcfile
=
36 match Str.split
(Str.regexp
"/") srcfile
with
38 pr
"@header@\n@@\n\n#include \"";
39 pr x
; pr
"\"\n\n"; true
41 let rec loop = function
44 pr
"@header@\n@@\n\n#include \"";
45 pr x
; pr
"\"\n\n"; true
46 | "include"::(x
::xs
) ->
47 pr
"@header@\n@@\n\n#include <";
49 if Str.string_match
(Str.regexp
"asm-") x 0 then "asm" else x in
50 pr
(String.concat
"/" (x::xs
));
55 (* ----------------------------------------------------------------------- *)
56 (* Print check that we are not in the defining function *)
58 let print_check_rule pr function_name function_name_count header_req
=
60 then pr
(Printf.sprintf
"@same_%s depends on header@\n" function_name_count
)
61 else pr
(Printf.sprintf
"@same_%s@\n" function_name_count
));
64 pr function_name
; pr
"@p(...) { ... }\n\n"
66 (* ----------------------------------------------------------------------- *)
67 (* get parameters of the matched function *)
69 let rec env_lookup fn
= function
70 [] -> failwith
"no binding"
71 | (nm
,vl
)::rest
when fn nm
-> vl
72 | _
::rest
-> env_lookup fn rest
75 let argname = ref ("","") in
76 let fn ((_
,nm
) as name
) =
78 then (argname := name
; true)
80 match env_lookup fn env
with
81 Ast_c.MetaParamListVal
(paramst
) -> (paramst
,!argname)
82 | _
-> failwith
"not possible"
84 let get_function_name rule env
=
85 let donothing r k e
= k e
in
86 let option_default = [] in
87 let bind = Common.union_set
in
88 let do_any_list_list r any_list_list
=
91 (function prev
-> function cur
->
92 bind (r
.V.combiner_anything cur
) prev
))
95 match Ast.get_mcodekind mc
with
96 Ast.MINUS
(_
,_
,_
,any_list_list
) ->
97 (match any_list_list
with
98 Ast.NOREPLACEMENT
-> []
99 | Ast.REPLACEMENT
(any_list_list
,_
) ->
100 do_any_list_list r any_list_list
)
101 | Ast.CONTEXT
(_
,any_befaft
) ->
102 (match any_befaft
with
103 Ast.BEFORE
(any_list_list
,_
) | Ast.AFTER
(any_list_list
,_
) ->
104 do_any_list_list r any_list_list
105 | Ast.BEFOREAFTER
(ba
,aa
,_
) ->
106 bind (do_any_list_list r ba
) (do_any_list_list r aa
)
108 | Ast.PLUS _
-> [] in
109 let expression r k e
=
111 (match Ast.unwrap e
with
112 Ast.FunCall
(fn,lp
,args
,rp
) ->
113 (match Ast.undots args
with
115 (match Ast.unwrap e
with
116 Ast.MetaExprList
(nm
,_
,_
,_
) ->
117 (match (Ast.unwrap_mcode nm
,Ast.get_mcodekind nm
) with
118 ((_
,"ARGS"), Ast.PLUS _
) ->
119 (match Ast.unwrap
fn with
121 (match Ast.unwrap id
with
123 | Ast.MetaFunc
(nm
,_
,_
,_
)
124 | Ast.MetaLocalFunc
(nm
,_
,_
,_
) ->
125 [Ast.unwrap_mcode nm
]
133 (V.combiner
bind option_default
134 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
135 donothing donothing donothing donothing donothing
136 donothing expression donothing donothing donothing donothing donothing
137 donothing donothing donothing donothing donothing).V.combiner_top_level
141 (match env_lookup (function nm
-> nm
= name
) env
with
142 Ast_c.MetaIdVal
(s
,_
) | Ast_c.MetaFuncVal
(s
)
143 | Ast_c.MetaLocalFuncVal
(s
) -> s
144 | _
-> error rule
"not possible")
145 | _
-> error rule
"inconsistent rule generation"
147 (* ----------------------------------------------------------------------- *)
148 (* Print metavariable declarations *)
150 let rec print_typedef pr
= function
151 (Ast_c.TypeName
(name
,_
),_
) ->
152 let s = Ast_c.str_of_name name
in
154 try List.assoc
!current_outfile !typedefs
157 typedefs := (!current_outfile,td)::!typedefs;
159 if not
(List.mem
s !typedefs)
160 then (typedefs := s::!typedefs; pr
"typedef "; pr
s; pr
";\n")
161 | (Ast_c.Pointer
(_
,ty
),_
) -> print_typedef pr ty
164 let rewrap_str s ii
=
165 {ii
with Ast_c.pinfo
=
166 (match ii
.Ast_c.pinfo
with
167 Ast_c.OriginTok pi
->
168 Ast_c.OriginTok
{ pi
with Common.str
= s;}
169 | Ast_c.ExpandedTok
(pi
,vpi
) ->
170 Ast_c.ExpandedTok
({ pi
with Common.str
= s;},vpi
)
171 | Ast_c.FakeTok
(_
,vpi
) -> Ast_c.FakeTok
(s,vpi
)
172 | Ast_c.AbstractLineTok pi
->
173 Ast_c.AbstractLineTok
{ pi
with Common.str
= s;})}
175 let rewrap_prefix_name prefix name
=
177 | Ast_c.RegularName
(s, iiname
) ->
178 let iis = Common.tuple_of_list1 iiname
in
179 let iis'
= rewrap_str (prefix^
s) iis in
180 Ast_c.RegularName
(prefix ^
s, [iis'
])
181 | Ast_c.CppConcatenatedName _
| Ast_c.CppVariadicName _
182 | Ast_c.CppIdentBuilder _
186 let print_metavar pr
= function
187 | {Ast_c.p_namei
= Some name
;
188 p_type
= (_
,(Ast_c.Pointer
(_
,(Ast_c.BaseType
(Ast_c.Void
),_
)),_
));
191 let param = Ast_c.str_of_name name
in
192 pr
("expression "^
prefix); pr
param
193 | ({Ast_c.p_namei
= Some name
; p_type
= (_
,ty
)} : Ast_c.parameterType
) ->
195 let name'
= rewrap_prefix_name prefix name in
199 Pretty_print_c.pp_param_gen
201 let str = Ast_c.str_of_info
x in
202 if not
(List.mem
str ["const";"volatile"])
204 (function _
-> pr
" ")
205 {Ast_c.p_register
= (false,[]);
206 p_namei
= Some
name'
;
207 p_type
= (({Ast_c.const
= false; Ast_c.volatile
= false},[]),ty
)
209 | _
-> failwith
"function must have named parameters"
211 let make_exp = function
212 ({Ast_c.p_namei
= Some
name; p_type
= ty
}, comma_ii
) ->
213 let no_info = (None
,Ast_c.NotTest
) in
215 let name'
= rewrap_prefix_name prefix name in
218 ((Ast_c.Ident
(name'
),ref no_info),Ast_c.noii
) in
219 (name,(Common.Left
exp,comma_ii
))
220 | _
-> failwith
"bad parameter"
222 let print_extra_typedefs pr env
=
224 { Visitor_c.default_visitor_c
with
225 Visitor_c.ktype
= (fun (k
, bigf) ty
->
227 (_
,((Ast_c.TypeName
(_
,_
),_
) as ty
)) -> print_typedef pr ty
232 Ast_c.MetaIdVal
(_
) | Ast_c.MetaFuncVal
(_
)
233 | Ast_c.MetaLocalFuncVal
(_
) -> ()
234 | Ast_c.MetaExprVal
(exp,_
) -> Visitor_c.vk_expr
bigf exp
235 | Ast_c.MetaExprListVal
(args
) -> Visitor_c.vk_argument_list
bigf args
236 | Ast_c.MetaParamVal
(param) -> Visitor_c.vk_param
bigf param
237 | Ast_c.MetaParamListVal
(params
) -> Visitor_c.vk_param_list
bigf params
239 | Ast_c.MetaTypeVal
(ty
) -> Visitor_c.vk_type
bigf ty
240 | Ast_c.MetaInitVal
(ty
) -> Visitor_c.vk_ini
bigf ty
241 | Ast_c.MetaInitListVal
(ty
) -> Visitor_c.vk_ini_list
bigf ty
242 | Ast_c.MetaDeclVal
(decl
) -> Visitor_c.vk_decl
bigf decl
243 | Ast_c.MetaFieldVal
(field
) -> Visitor_c.vk_struct_field
bigf field
244 | Ast_c.MetaFieldListVal
(fields
) -> Visitor_c.vk_struct_fields
bigf fields
245 | Ast_c.MetaStmtVal
(stm
) -> Visitor_c.vk_statement
bigf stm
246 | Ast_c.MetaPosVal _
| Ast_c.MetaPosValList _
247 | Ast_c.MetaListlenVal _
-> ())
250 let rename argids env
=
251 let argenv = List.map
(function name ->
252 let arg = Ast_c.str_of_name
name in
255 let lookup x = try List.assoc
x argenv with Not_found
-> x in
257 { Visitor_c.default_visitor_c_s
with
258 Visitor_c.kexpr_s
= (fun (k
,bigf) e
->
260 ((Ast_c.Ident
(name), info
), []) ->
262 (* pad: assert is_regular_ident ? *)
263 let s = Ast_c.str_of_name
name in
264 let ii = Ast_c.info_of_name
name in
265 let new_name = lookup s in
266 let new_id = Ast_c.RegularName
(new_name, [rewrap_str new_name ii]) in
267 ((Ast_c.Ident
(new_id), info
), Ast_c.noii
)
273 Ast_c.MetaIdVal
(_
) | Ast_c.MetaFuncVal
(_
)
274 | Ast_c.MetaLocalFuncVal
(_
) -> vl
275 | Ast_c.MetaExprVal
(exp,c
) ->
276 Ast_c.MetaExprVal
(Visitor_c.vk_expr_s
bigf exp,c
)
277 | Ast_c.MetaExprListVal
(args
) ->
278 Ast_c.MetaExprListVal
(Visitor_c.vk_arguments_s
bigf args
)
279 | Ast_c.MetaParamVal
(param) ->
280 Ast_c.MetaParamVal
(Visitor_c.vk_param_s
bigf param)
281 | Ast_c.MetaParamListVal
(params
) ->
282 Ast_c.MetaParamListVal
(Visitor_c.vk_params_s
bigf params
)
284 | Ast_c.MetaTypeVal
(ty
) ->
285 Ast_c.MetaTypeVal
(Visitor_c.vk_type_s
bigf ty
)
286 | Ast_c.MetaInitVal
(ini
) ->
287 Ast_c.MetaInitVal
(Visitor_c.vk_ini_s
bigf ini
)
288 | Ast_c.MetaInitListVal
(ini
) ->
289 Ast_c.MetaInitListVal
(Visitor_c.vk_inis_s
bigf ini
)
290 | Ast_c.MetaDeclVal
(stm
) ->
291 Ast_c.MetaDeclVal
(Visitor_c.vk_decl_s
bigf stm
)
292 | Ast_c.MetaFieldVal
(stm
) ->
293 Ast_c.MetaFieldVal
(Visitor_c.vk_struct_field_s
bigf stm
)
294 | Ast_c.MetaFieldListVal
(stm
) ->
295 Ast_c.MetaFieldListVal
(Visitor_c.vk_struct_fields_s
bigf stm
)
296 | Ast_c.MetaStmtVal
(stm
) ->
297 Ast_c.MetaStmtVal
(Visitor_c.vk_statement_s
bigf stm
)
298 | Ast_c.MetaPosVal _
| Ast_c.MetaPosValList _
299 | Ast_c.MetaListlenVal _
-> vl
))
302 let print_one_type pr env
= function
303 (Type_cocci.MetaType
(name,keep
,inherited
)) as ty
->
305 match List.assoc
name env
with
306 Ast_c.MetaTypeVal ty
->
307 Pretty_print_c.pp_type_gen
308 (function x -> pr
(Ast_c.str_of_info
x))
309 (function _
-> pr
" ")
311 | _
-> failwith
"impossible"
312 with Not_found
-> pr
(Type_cocci.type2c ty
))
313 | ty
-> pr
(Type_cocci.type2c ty
)
315 let print_types pr env
= function
317 | Some
[ty
] -> print_one_type pr env ty
320 Common.print_between
(function _
-> pr
", ") (print_one_type pr env
)
325 let pp_name (_
,n
) = pr n
in
328 | Ast.MetaLen len
-> pr
"["; pp_name len
; pr
"]"
329 | Ast.CstLen len
-> pr
"["; pr
(string_of_int len
); pr
"]"
331 let pp_meta_decl pr env decl
=
332 let no_arity = function Ast.NONE
-> () | _
-> failwith
"no arity allowed" in
333 let pp_name (_
,n
) = pr n
in
335 Ast.MetaMetaDecl
(ar
, name) ->
337 no_arity ar
; pr
"metavariable "; pp_name name; pr
";\n"
338 | Ast.MetaIdDecl
(ar
, name) ->
340 no_arity ar
; pr
"identifier "; pp_name name; pr
";\n"
341 | Ast.MetaFreshIdDecl
(name, Ast.NoVal
) ->
342 pr
"fresh identifier "; pp_name name; pr
";\n"
343 | Ast.MetaFreshIdDecl
(name, Ast.StringSeed
x) ->
344 pr
"fresh identifier "; pp_name name; pr
" = \""; pr
x; pr
"\";\n"
345 | Ast.MetaFreshIdDecl
(name, Ast.ListSeed
x) ->
346 failwith
"unparse_hrule: not supported"
347 | Ast.MetaTypeDecl
(ar
, name) ->
348 no_arity ar
; pr
"type "; pp_name name; pr
";\n"
349 | Ast.MetaInitDecl
(ar
, name) ->
350 no_arity ar
; pr
"initialiser "; pp_name name; pr
";\n"
351 | Ast.MetaInitListDecl
(ar
, name, len
) ->
352 no_arity ar
; pr
"initialiser list "; pp_name name; pp_len pr len
; pr
";\n"
353 | Ast.MetaListlenDecl
(name) -> ()
354 | Ast.MetaParamDecl
(ar
, name) ->
355 no_arity ar
; pr
"parameter "; pp_name name; pr
";\n"
356 | Ast.MetaParamListDecl
(ar
, name, len
) ->
357 no_arity ar
; pr
"parameter list "; pp_name name; pp_len pr len
; pr
";\n"
358 | Ast.MetaConstDecl
(ar
, name, types
) ->
359 no_arity ar
; pr
"constant "; print_types pr env types
;
360 pp_name name; pr
";\n"
361 | Ast.MetaErrDecl
(ar
, name) ->
362 no_arity ar
; pr
"error "; pp_name name; pr
";\n"
363 | Ast.MetaExpDecl
(ar
, name, None
) ->
364 no_arity ar
; pr
"expression "; pp_name name; pr
";\n"
365 | Ast.MetaExpDecl
(ar
, name, types
) ->
366 no_arity ar
; print_types pr env types
; pp_name name; pr
";\n"
367 | Ast.MetaIdExpDecl
(ar
, name, types
) ->
368 no_arity ar
; pr
"idexpression ";
369 print_types pr env types
; pp_name name; pr
";\n"
370 | Ast.MetaLocalIdExpDecl
(ar
, name, types
) ->
371 no_arity ar
; pr
"local idexpression ";
372 print_types pr env types
; pp_name name; pr
";\n"
373 | Ast.MetaExpListDecl
(ar
, name, len
) ->
374 no_arity ar
; pr
"parameter list "; pp_name name; pp_len pr len
; pr
";\n"
375 | Ast.MetaDeclDecl
(ar
, name) ->
376 no_arity ar
; pr
"declaration "; pp_name name; pr
";\n"
377 | Ast.MetaFieldDecl
(ar
, name) ->
378 no_arity ar
; pr
"field "; pp_name name; pr
";\n"
379 | Ast.MetaFieldListDecl
(ar
, name, len
) ->
380 no_arity ar
; pr
"field list "; pp_name name; pp_len pr len
; pr
";\n"
381 | Ast.MetaStmDecl
(ar
, name) ->
382 no_arity ar
; pr
"statement "; pp_name name; pr
";\n"
383 | Ast.MetaStmListDecl
(ar
, name) ->
384 no_arity ar
; pr
"statement list "; pp_name name; pr
";\n"
385 | Ast.MetaFuncDecl
(ar
, name) ->
386 no_arity ar
; pr
"function "; pp_name name; pr
";\n"
387 | Ast.MetaLocalFuncDecl
(ar
, name) ->
388 no_arity ar
; pr
"local function "; pp_name name; pr
";\n"
389 | Ast.MetaPosDecl
(ar
, name) ->
390 no_arity ar
; pr
"position "; pp_name name; pr
";\n"
391 | Ast.MetaAnalysisDecl
(code
, name) ->
392 pr
"analysis"; pr code
; pr
" "; pp_name name; pr
";\n"
393 | Ast.MetaDeclarerDecl
(ar
, name) ->
394 no_arity ar
; pr
"declarer "; pp_name name; pr
";\n"
395 | Ast.MetaIteratorDecl
(ar
, name) ->
396 no_arity ar
; pr
"iterator "; pp_name name; pr
";\n"
398 let print_metavariables pr local_metas paramst env header_req function_name
=
400 then pr
"@depends on header@\n"
402 pr
(Printf.sprintf
"position _p!=same_%s.p;\n" function_name
);
403 pr
"identifier _f;\n";
404 let rec loop = function
405 [] | [{Ast_c.p_type
=(_
,(Ast_c.BaseType
(Ast_c.Void
),_
))},_
] -> []
406 | ((first
,_
) as f
)::rest
->
407 print_metavar pr first
; pr
";\n";
408 (make_exp f
) :: loop rest
in
409 let args = loop paramst
in
410 print_extra_typedefs pr env
;
411 List.iter
(pp_meta_decl pr env
) local_metas
;
415 (* ----------------------------------------------------------------------- *)
416 (* print_start/end *)
419 pr
"_f@_p(...) { <+...\n"
424 (* ----------------------------------------------------------------------- *)
425 (* Print call to the defined function *)
427 let print_param_name pr
= function
428 {Ast_c.p_namei
= Some
name} -> pr
(Ast_c.str_of_name
name)
429 | _
-> failwith
"function must have named parameters"
431 let pp_def_gen pr defn isexp
=
432 let {Ast_c.f_name
= name; f_type
= (_
, (paramst
, (b
, iib
))); } = defn
in
433 pr
(Ast_c.str_of_name
name); pr
"(";
434 (if b
then failwith
"not handling variable argument functions");
436 [] | [{Ast_c.p_type
= (_
,(Ast_c.BaseType
(Ast_c.Void
),_
))},_
] -> ()
438 print_param_name pr first
;
439 List.iter
(function (x,_
) -> pr
", "; print_param_name pr
x) rest
);
440 pr
")"; if not isexp
then pr
";"
442 (* ----------------------------------------------------------------------- *)
445 let pp_rule local_metas ast env srcfile
=
446 let (paramst
,args_name
) = get_paramst env
in
447 (* get rule information *)
448 let (rule
,printable
) =
450 Ast.CocciRule
(_
,_
,[body
],_
,_
) -> (* could extend to use attributes *)
452 match Ast.unwrap body
with
453 Ast.NONDECL
(s) -> [[Ast.StatementTag
s]]
454 | Ast.CODE
(ss
) -> [[Ast.StmtDotsTag ss
]]
455 | _
-> error body
"bad rule body")
456 | _
-> failwith
"bad rule" in
457 (* create the output file *)
459 match !Flag.make_hrule
with
460 Some
outdir -> outdir
461 | None
-> error rule
"not possible" in
462 let function_name = get_function_name rule env
in
463 let function_name_count =
465 let cell = List.assoc
function_name !names in
468 function_name ^
(string_of_int
ct)
471 names := (function_name,cell) :: !names;
473 let outfile = outdir ^
"/" ^
474 (if !Flag.hrule_per_file
475 then Filename.chop_extension
(Filename.basename srcfile
)
476 else function_name_count) in
477 let escape_re = Str.regexp_string
"/" in
478 let dir = if !Flag.dir = "" then Filename.dirname srcfile
else !Flag.dir in
479 let outdirfile = Str.global_replace
escape_re "_"dir in
480 let outfile = outfile ^
outdirfile ^
".cocci" in
481 let saved_header_req =
482 try let res = List.assoc
outfile !started_files in Some
res
483 with Not_found
-> None
in
484 current_outfile := outfile;
485 Common.with_open_outfile_append
outfile (fun (pr
,chan
) ->
487 match saved_header_req with
490 let res = print_header_rule pr srcfile
in
491 started_files := (outfile,res)::!started_files;
493 print_check_rule pr
function_name function_name_count header_req;
495 print_metavariables pr local_metas paramst env
header_req
496 function_name_count in
497 let (argids
,args) = List.split
args in
498 let env = rename argids
env in
499 let env = (args_name
,Ast_c.MetaExprListVal
args)::env in
501 (* for printing C tokens *)
503 match Ast_c.pinfo_of_info info
with
504 Ast_c.AbstractLineTok _
-> pr
(Ast_c.str_of_info info
)
505 | Ast_c.FakeTok
(s,_
) -> pr
s
507 Printf.printf
"line: %s\n" (Dumper.dump info
);
508 error rule
"not an abstract line" in
509 let pr_space _
= pr
" " in
510 Unparse_cocci.pp_list_list_any
511 ([env], (fun s _ _ _ _
-> pr
s), pr_c, pr_space, pr_space, pr
,
512 (fun _ _
-> ()), (function _
-> ()), (function _
-> ()),
514 true printable
Unparse_cocci.InPlace
;