2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
23 module Ast0
= Ast0_cocci
24 module Ast
= Ast_cocci
25 module V0
= Visitor_ast0
26 module VT0
= Visitor_ast0_types
28 type id
= Id
of string | Meta
of (string * string)
30 let rec get_name name
=
31 match Ast0.unwrap name
with
32 Ast0.Id
(nm
) -> Id
(Ast0.unwrap_mcode nm
)
33 | Ast0.MetaId
(nm
,_
,_
) | Ast0.MetaFunc
(nm
,_
,_
)
34 | Ast0.MetaLocalFunc
(nm
,_
,_
) -> Meta
(Ast0.unwrap_mcode nm
)
35 | Ast0.OptIdent
(id
) | Ast0.UniqueIdent
(id
) ->
38 (* --------------------------------------------------------------------- *)
39 (* collect all of the functions *)
41 let brace_to_semi (_
,arity
,info
,mcodekind
,pos
,adj
) =
43 (* drop column information, so that with -smpl_spacing the semicolon
44 will come out right after the close parenthesis *)
45 {info with Ast0.pos_info
= {info.Ast0.pos_info
with Ast0.column
= -1}} in
46 (";",Ast0.NONE
,info,mcodekind
,pos
,adj
)
48 let collect_function (stm
: Ast0.statement
) =
49 match Ast0.unwrap stm
with
50 Ast0.FunDecl
(_
,fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
53 List.filter
(function Ast0.FStorage
(_
) -> true | _
-> false)
54 fninfo
with [Ast0.FStorage
(s
)] -> Some s
| _
-> None
in
57 List.filter
(function Ast0.FType
(_
) -> true | _
-> false)
58 fninfo
with [Ast0.FType
(t
)] -> Some t
| _
-> None
in
61 (Ast0.Decl
((Ast0.default_info
(),Ast0.context_befaft
()),
66 (Ast0.FunctionType
(ty,lp
,params
,rp
)),
67 name
,brace_to_semi lbrace
)))))]
70 let collect_functions stmt_dots
=
71 List.concat
(List.map
collect_function (Ast0.undots stmt_dots
))
73 let get_all_functions rule
=
75 match Ast0.unwrap rule
with
76 Ast0.DECL
(stmt
) -> collect_function stmt
77 | Ast0.CODE
(rule_elem_dots
) -> collect_functions rule_elem_dots
80 (function (nm
,def
,vl
) ->
82 (def
,(Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_statement vl
)))
85 (* --------------------------------------------------------------------- *)
86 (* try to match up the functions *)
88 (* pass through the - and + functions in lockstep, until one runs out.
89 Then process the remaining minuses, if any. If we can find another
90 function of the same name for either the current - or + function, take that
91 one. Otherwise, align the two current ones. *)
93 let rec align all_minus all_plus
=
94 let rec loop = function
96 | ((mname
,(mdef
,mproto
))::minus
,[]) ->
98 let (_
,pproto
) = List.assoc mname all_plus
in
99 (mname
,mdef
,mproto
,Some pproto
)::(loop (minus
,[]))
100 with Not_found
-> (mname
,mdef
,mproto
,None
)::(loop (minus
, [])))
101 | ((mname
,(mdef
,mproto
))::minus
,(pname
,(pdef
,pproto
))::plus
) ->
103 then (mname
,mdef
,mproto
,Some pproto
)::(loop (minus
, []))
106 let (_
,pproto_for_minus
) = List.assoc mname all_plus
in
108 let _ = List.assoc mname all_plus
in
109 (* protos that match both *)
110 (mname
,mdef
,mproto
,Some pproto_for_minus
)::(loop (minus
, plus
))
112 (* proto that matches only minus *)
113 (mname
,mdef
,mproto
,Some pproto_for_minus
)::
114 (loop (minus
, ((pname
,(pdef
,pproto
))::plus
))))
117 let _ = List.assoc mname all_plus
in
118 (* proto only for plus *)
119 (mname
,mdef
,mproto
,None
)::(loop (minus
, plus
))
121 (* protos for no one *)
122 (mname
,mdef
,mproto
,Some pproto
)::(loop (minus
, plus
)))) in
123 List.filter changed_proto
(loop (all_minus
, all_plus
))
125 (* --------------------------------------------------------------------- *)
128 let donothing r k e
=
129 {(Ast0.wrap
(Ast0.unwrap
(k e
))) with Ast0.mcodekind
= ref Ast0.PLUS
} in
130 let mcode (mc
,_,_,_,_,_) =
131 (mc
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
,ref Ast0.NoMetaPos
,-1) in
133 (* need a case for everything that has an unvisited component and can be in
134 a function prototype *)
139 (match Ast0.unwrap e
with
140 Ast0.MetaId
(nm
,constraints
,pure
) ->
141 Ast0.MetaId
(nm
,constraints
,Ast0.Pure
)
142 | Ast0.MetaFunc
(nm
,constraints
,pure
) ->
143 Ast0.MetaFunc
(nm
,constraints
,Ast0.Pure
)
144 | Ast0.MetaLocalFunc
(nm
,constraints
,pure
) ->
145 Ast0.MetaLocalFunc
(nm
,constraints
,Ast0.Pure
)
151 (match Ast0.unwrap e
with
152 Ast0.MetaType
(nm
,pure
) -> Ast0.MetaType
(nm
,Ast0.Pure
)
158 (match Ast0.unwrap e
with
159 Ast0.MetaParam
(nm
,pure
) ->
160 Ast0.MetaParam
(nm
,Ast0.Pure
)
161 | Ast0.MetaParamList
(nm
,lenname
,pure
) ->
162 Ast0.MetaParamList
(nm
,lenname
,Ast0.Pure
)
166 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
167 donothing donothing donothing donothing donothing donothing
168 ident donothing typeC donothing param donothing donothing
171 and changed_proto
= function
172 (mname
,mdef
,mproto
,None
) -> true
173 | (mname
,mdef
,mproto
,Some pproto
) ->
174 not
((strip
.VT0.rebuilder_rec_statement mproto
) =
175 (strip
.VT0.rebuilder_rec_statement pproto
))
177 (* --------------------------------------------------------------------- *)
180 let rec drop_param_name p
=
182 (match Ast0.unwrap p
with
183 Ast0.Param
(p
,_) -> Ast0.Param
(p
,None
)
184 | Ast0.OptParam
(p
) -> Ast0.OptParam
(drop_param_name p
)
185 | Ast0.UniqueParam
(p
) -> Ast0.UniqueParam
(p
)
189 let dec = (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_statement
dec in
190 match Ast0.unwrap
dec with
191 Ast0.Decl
(info,uninit
) ->
192 (match Ast0.unwrap uninit
with
193 Ast0.UnInit
(stg,typ
,name
,sem
) ->
194 (match Ast0.unwrap typ
with
195 Ast0.FunctionType
(ty,lp
,params
,rp
) ->
197 match Ast0.unwrap
params with
199 Ast0.rewrap
params (Ast0.DOTS
(List.map
drop_param_name l
))
202 (Ast0.CIRCLES
(List.map
drop_param_name l
))
203 | Ast0.STARS
(l
) -> failwith
"unexpected stars" in
211 (Ast0.FunctionType
(ty,lp
,params,rp
)),
213 | _ -> failwith
"function prototypes: unexpected type")
214 | _ -> failwith
"unexpected declaration")
215 | _ -> failwith
"unexpected term"
222 name^
"__"^
(string_of_int
n)
224 let rec rename_param old_name all
param =
225 match Ast0.unwrap
param with
226 Ast0.Param
(ty,Some id
) when all
->
227 (match Ast0.unwrap id
with
229 (((_,name
),arity
,info,mcodekind
,pos
,adj
),constraints
,pure
) ->
230 let nm = ("__no_name__",new_name name
) in
234 ((nm,arity
,info,mcodekind
,pos
,adj
),constraints
,Ast0.Pure
)) in
235 ([Ast.MetaIdDecl
(Ast.NONE
,nm)],
236 Ast0.rewrap
param (Ast0.Param
(ty,Some
new_id)))
239 let nm = (old_name
,new_name "__P") in
240 let nml = (old_name
,new_name "__n") in
243 (Ast0.MetaParamList
(Ast0.rewrap_mcode d
nm,
244 Some
(Ast0.rewrap_mcode d
nml),
246 ([Ast.MetaParamListDecl
(Ast.NONE
,nm,Some
nml);Ast.MetaListlenDecl
(nml)],
248 | Ast0.OptParam
(p
) ->
249 let (metavars
,p
) = rename_param old_name all p
in
250 (metavars
,Ast0.rewrap
param (Ast0.OptParam
(p
)))
251 | Ast0.UniqueParam
(p
) ->
252 let (metavars
,p
) = rename_param old_name all p
in
253 (metavars
,Ast0.rewrap
param (Ast0.UniqueParam
(p
)))
256 (* try to convert names in the - parameter list to new metavariables, to
257 account for spelling mistakes on the part of the programmer *)
258 let fresh_names old_name mdef
dec =
259 let res = ([],[],dec,mdef
) in
260 match Ast0.unwrap
dec with
261 Ast0.Decl
(info,uninit
) ->
262 (match Ast0.unwrap uninit
with
263 Ast0.UnInit
(stg,typ
,name
,sem
) ->
264 (match Ast0.unwrap typ
with
265 Ast0.FunctionType
(ty,lp
,params,rp
) ->
266 let (metavars
,newdec
) =
269 (List.map
(rename_param old_name
true)
270 (Ast0.undots
params)) in
271 (List.concat metavars
,
280 (ty,lp
,Ast0.rewrap
params (Ast0.DOTS
(l
)),
283 let (def_metavars
,newdef
) =
284 match Ast0.unwrap mdef
with
285 Ast0.FunDecl
(x
,fninfo
,name
,lp
,params,rp
,lb
,body
,rb
) ->
286 let (def_metavars
,def_l
) =
288 (List.map
(rename_param old_name
false)
289 (Ast0.undots
params)) in
290 (List.concat def_metavars
,
292 (Ast0.FunDecl
(x
,fninfo
,name
,lp
,
293 Ast0.rewrap
params (Ast0.DOTS
(def_l
)),
295 | _ -> failwith
"unexpected function definition" in
296 (metavars
,def_metavars
,newdec
,newdef
)
301 (* since there is no + counterpart, the function must be completely deleted *)
303 match Ast0.unwrap
dec with
304 Ast0.Decl
(info,uninit
) ->
305 (match Ast0.unwrap uninit
with
306 Ast0.UnInit
(stg,typ
,name
,sem
) ->
307 (match Ast0.unwrap typ
with
308 Ast0.FunctionType
(ty,lp
,params,rp
) ->
319 (let info = Ast0.get_info
params in
321 (* use the mcodekind of an atomic minused
323 Ast0.get_mcode_mcodekind lp
in
325 ("...",Ast0.NONE
,info,mcodekind,
326 ref Ast0.NoMetaPos
,-1) in
329 (Ast0.Pdots
(pdots))])),
336 let merge mproto pproto
=
338 Compute_lines.compute_lines
[Ast0.copywrap
mproto (Ast0.DECL
mproto)] in
340 Compute_lines.compute_lines
[Ast0.copywrap
pproto (Ast0.DECL
pproto)] in
341 let (m
,p
) = List.split
(Context_neg.context_neg
mproto pproto) in
342 Insert_plus.insert_plus m p
true (* no isos for protos *);
343 (* convert to ast so that the + code will fall down to the tokens
344 and off the artificially added Ast0.DECL *)
345 let mproto = Ast0toast.ast0toast_toplevel
(List.hd
mproto) in
346 (* clean up the wrapping added above *)
347 match Ast.unwrap
mproto with
348 Ast.DECL
mproto -> mproto
349 | _ -> failwith
"not possible"
351 let make_rule rule_name
= function
352 (mname
,mdef
,mproto,Some
pproto) ->
353 let (metavars
,mdef_metavars
,mproto,mdef
) =
354 fresh_names rule_name mdef
mproto in
355 let no_name_mproto = drop_names mproto in
356 let no_name_pproto = drop_names pproto in
357 (metavars
,mdef_metavars
,
358 [merge mproto pproto; merge no_name_mproto no_name_pproto],mdef
)
359 | (mname
,mdef
,mproto,None
) ->
360 ([],[],[Ast0toast.statement
(no_names mproto)],mdef
)
362 (* --------------------------------------------------------------------- *)
364 let reinsert mdefs minus
=
368 match Ast0.unwrap x
with
369 Ast0.FunDecl
(_,fninfo
,name
,lp
,params,rp
,lbrace
,body
,rbrace
) ->
371 | _ -> failwith
"bad mdef")
375 match Ast0.unwrap x
with
377 (match Ast0.unwrap stmt
with
378 Ast0.FunDecl
(_,fninfo
,name
,lp
,params,rp
,lbrace
,body
,rbrace
) ->
379 (try Ast0.rewrap x
(Ast0.DECL
(List.assoc name
table))
382 | Ast0.CODE
(rule_elem_dots
) ->
383 (* let's hope there are no functions in here... *)
388 (* --------------------------------------------------------------------- *)
391 let rec split4 = function
394 let (ax
,bx
,cx
,dx
) = split4 rest
in (a
::ax
,b
::bx
,c
::cx
,d
::dx
)
396 let process rule_name rule_metavars dropped_isos minus plus ruletype
=
397 let minus_functions = List.concat
(List.map
get_all_functions minus
) in
398 match minus_functions with
399 [] -> ((rule_metavars
,minus
),None
)
402 List.concat
(List.map
get_all_functions plus
) in
403 let protos = align minus_functions plus_functions in
404 let (metavars
,mdef_metavars
,rules
,mdefs
) =
405 split4(List.map
(make_rule rule_name
) protos) in
406 let metavars = List.concat
metavars in
407 let mdef_metavars = (List.concat
mdef_metavars) @ rule_metavars
in
408 let rules = List.concat
rules in
409 let minus = reinsert mdefs
minus in
411 [] -> ((rule_metavars
,minus),None
)
413 (* probably not possible, since there is always the version with
414 variables and the version without *)
415 ((mdef_metavars,minus),
419 ("proto for "^rule_name
,
420 (Ast.Dep rule_name
,dropped_isos
,Ast.Forall
),
421 [Ast.rewrap x
(Ast.DECL x
)],
425 List.map
(function x
-> Ast.rewrap x
(Ast.DOTS
[x
])) rules in
428 ("proto for "^rule_name
,
429 (Ast.Dep rule_name
,dropped_isos
,Ast.Forall
),
430 [Ast.rewrap x
(Ast.DECL
(Ast.rewrap x
(Ast.Disj
drules)))],
432 ((mdef_metavars,minus),Some
(metavars,res))