2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
25 (* Arities matter for the minus slice, but not for the plus slice. *)
27 (* + only allowed on code in a nest (in_nest = true). ? only allowed on
28 rule_elems, and on subterms if the context is ? also. *)
30 module Ast0
= Ast0_cocci
31 module Ast
= Ast_cocci
32 module V0
= Visitor_ast0
33 module VT0
= Visitor_ast0_types
35 let unitary = Type_cocci.Unitary
43 (* --------------------------------------------------------------------- *)
44 (* Move plus tokens from the MINUS and CONTEXT structured nodes to the
45 corresponding leftmost and rightmost mcodes *)
49 let option_default = () in
51 let do_nothing r k e
=
53 let einfo = Ast0.get_info e
in
54 match (Ast0.get_mcodekind e
) with
55 Ast0.MINUS
(replacements
) ->
56 (match !replacements
with
59 let minus_try = function
63 Ast0.MINUS
(mreplacements
) -> true | _
-> false)
68 Ast0.MINUS
(mreplacements
) ->
69 mreplacements
:= replacements
75 if not
(minus_try(einfo.Ast0.attachable_start
,
76 einfo.Ast0.mcode_start
)
78 minus_try(einfo.Ast0.attachable_end
,
79 einfo.Ast0.mcode_end
))
81 failwith
"minus tree should not have bad code on both sides")
82 | Ast0.CONTEXT
(befaft
)
83 | Ast0.MIXED
(befaft
) ->
84 let concat starter startinfo ender endinfo
=
86 match (starter
,ender
) with
90 if startinfo
.Ast0.tline_end
= endinfo
.Ast0.tline_start
91 then (* put them in the same inner list *)
92 let last = List.hd
(List.rev starter
) in
93 let butlast = List.rev
(List.tl
(List.rev starter
)) in
94 butlast @ (last@(List.hd ender
)) :: (List.tl ender
)
95 else starter
@ ender
in
97 {endinfo
with Ast0.tline_start
= startinfo
.Ast0.tline_start
}) in
98 let attach_bef bef beforeinfo befit
= function
102 Ast0.MINUS
(mreplacements
) ->
103 let (mrepl
,tokeninfo
) = !mreplacements
in
104 mreplacements
:= concat bef beforeinfo mrepl tokeninfo
105 | Ast0.CONTEXT
(mbefaft
) ->
107 (Ast.BEFORE
(mbef
,it
),mbeforeinfo
,a
) ->
108 let (newbef
,newinfo
) =
109 concat bef beforeinfo mbef mbeforeinfo
in
110 let it = Ast.lub_count befit
it in
111 mbefaft
:= (Ast.BEFORE
(newbef
,it),newinfo
,a
)
112 | (Ast.AFTER
(maft
,it),_
,a
) ->
113 let it = Ast.lub_count befit
it in
115 (Ast.BEFOREAFTER
(bef
,maft
,it),beforeinfo
,a
)
116 | (Ast.BEFOREAFTER
(mbef
,maft
,it),mbeforeinfo
,a
) ->
117 let (newbef
,newinfo
) =
118 concat bef beforeinfo mbef mbeforeinfo
in
119 let it = Ast.lub_count befit
it in
121 (Ast.BEFOREAFTER
(newbef
,maft
,it),newinfo
,a
)
122 | (Ast.NOTHING
,_
,a
) ->
124 (Ast.BEFORE
(bef
,befit
),beforeinfo
,a
))
125 | _
-> failwith
"unexpected annotation")
128 Printf.printf
"before %s\n" (Dumper.dump bef
);
130 "context tree should not have bad code before" in
131 let attach_aft aft afterinfo aftit
= function
135 Ast0.MINUS
(mreplacements
) ->
136 let (mrepl
,tokeninfo
) = !mreplacements
in
137 mreplacements
:= concat mrepl tokeninfo aft afterinfo
138 | Ast0.CONTEXT
(mbefaft
) ->
140 (Ast.BEFORE
(mbef
,it),b
,_
) ->
141 let it = Ast.lub_count aftit
it in
143 (Ast.BEFOREAFTER
(mbef
,aft
,it),b
,afterinfo
)
144 | (Ast.AFTER
(maft
,it),b
,mafterinfo
) ->
145 let (newaft
,newinfo
) =
146 concat maft mafterinfo aft afterinfo
in
147 let it = Ast.lub_count aftit
it in
148 mbefaft
:= (Ast.AFTER
(newaft
,it),b
,newinfo
)
149 | (Ast.BEFOREAFTER
(mbef
,maft
,it),b
,mafterinfo
) ->
150 let (newaft
,newinfo
) =
151 concat maft mafterinfo aft afterinfo
in
152 let it = Ast.lub_count aftit
it in
154 (Ast.BEFOREAFTER
(mbef
,newaft
,it),b
,newinfo
)
155 | (Ast.NOTHING
,b
,_
) ->
156 mbefaft
:= (Ast.AFTER
(aft
,aftit
),b
,afterinfo
))
157 | _
-> failwith
"unexpected annotation")
161 "context tree should not have bad code after" in
163 (Ast.BEFORE
(bef
,it),beforeinfo
,_
) ->
164 attach_bef bef beforeinfo
it
165 (einfo.Ast0.attachable_start
,einfo.Ast0.mcode_start
)
166 | (Ast.AFTER
(aft
,it),_
,afterinfo
) ->
167 attach_aft aft afterinfo
it
168 (einfo.Ast0.attachable_end
,einfo.Ast0.mcode_end
)
169 | (Ast.BEFOREAFTER
(bef
,aft
,it),beforeinfo
,afterinfo
) ->
170 attach_bef bef beforeinfo
it
171 (einfo.Ast0.attachable_start
,einfo.Ast0.mcode_start
);
172 attach_aft aft afterinfo
it
173 (einfo.Ast0.attachable_end
,einfo.Ast0.mcode_end
)
174 | (Ast.NOTHING
,_
,_
) -> ())
175 | Ast0.PLUS _
-> () in
176 V0.flat_combiner
bind option_default
177 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
179 do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
180 do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
181 do_nothing do_nothing do_nothing
183 (* --------------------------------------------------------------------- *)
184 (* For function declarations. Can't use the mcode at the root, because that
185 might be mixed when the function contains ()s, where agglomeration of -s is
189 let donothing r k e
= k e
in
190 let bind x y
= x
&& y
in
191 let option_default = true in
192 let mcode (_
,_
,_
,mc
,_
,_
) =
194 Ast0.MINUS
(r
) -> let (plusses
,_
) = !r
in plusses
= []
197 (* special case for disj *)
198 let expression r k e
=
199 match Ast0.unwrap e
with
200 Ast0.DisjExpr
(starter
,expr_list
,mids
,ender
) ->
201 List.for_all r
.VT0.combiner_rec_expression expr_list
204 let declaration r k e
=
205 match Ast0.unwrap e
with
206 Ast0.DisjDecl
(starter
,decls
,mids
,ender
) ->
207 List.for_all r
.VT0.combiner_rec_declaration decls
211 match Ast0.unwrap e
with
212 Ast0.DisjType
(starter
,decls
,mids
,ender
) ->
213 List.for_all r
.VT0.combiner_rec_typeC decls
216 let statement r k e
=
217 match Ast0.unwrap e
with
218 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
219 List.for_all r
.VT0.combiner_rec_statement_dots statement_dots_list
222 let case_line r k e
=
223 match Ast0.unwrap e
with
224 Ast0.DisjCase
(starter
,case_lines
,mids
,ender
) ->
225 List.for_all r
.VT0.combiner_rec_case_line case_lines
228 V0.flat_combiner
bind option_default
229 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
231 donothing donothing donothing donothing donothing donothing
232 donothing expression typeC donothing donothing declaration
233 statement case_line donothing
235 (* --------------------------------------------------------------------- *)
236 (* --------------------------------------------------------------------- *)
238 let get_option fn
= function
240 | Some x
-> Some
(fn x
)
242 (* --------------------------------------------------------------------- *)
243 (* --------------------------------------------------------------------- *)
246 let convert_info info
=
249 (function (s
,info
) -> (s
,info
.Ast0.line_start
,info
.Ast0.column
))
251 { Ast.line
= info
.Ast0.pos_info
.Ast0.line_start
;
252 Ast.column
= info
.Ast0.pos_info
.Ast0.column
;
253 Ast.strbef
= strings_to_s info
.Ast0.strings_before
;
254 Ast.straft
= strings_to_s info
.Ast0.strings_after
;}
256 let convert_mcodekind adj
= function
257 Ast0.MINUS
(replacements
) ->
258 let (replacements
,_
) = !replacements
in
259 Ast.MINUS
(Ast.NoPos
,[],adj
,replacements
)
260 | Ast0.PLUS count
-> Ast.PLUS count
261 | Ast0.CONTEXT
(befaft
) ->
262 let (befaft
,_
,_
) = !befaft
in Ast.CONTEXT
(Ast.NoPos
,befaft
)
263 | Ast0.MIXED
(_
) -> failwith
"not possible for mcode"
265 let pos_mcode(term
,_
,info
,mcodekind
,pos
,adj
) =
266 (* avoids a recursion problem *)
267 (term
,convert_info info
,convert_mcodekind adj mcodekind
,Ast.NoMetaPos
)
269 let mcode (term
,_
,info
,mcodekind
,pos
,adj
) =
272 Ast0.MetaPos
(pos,constraints
,per
) ->
273 Ast.MetaPos
(pos_mcode pos,constraints
,per
,unitary,false)
274 | _
-> Ast.NoMetaPos
in
275 (term
,convert_info info
,convert_mcodekind adj mcodekind
,pos)
277 (* --------------------------------------------------------------------- *)
279 let wrap ast line isos
=
280 {(Ast.make_term ast
) with Ast.node_line
= line
;
283 let rewrap ast0 isos ast
=
284 wrap ast
((Ast0.get_info ast0
).Ast0.pos_info
.Ast0.line_start
) isos
288 (* no isos on tokens *)
289 let tokenwrap (_
,info
,_
,_
) s ast
= wrap ast info
.Ast.line
no_isos
290 let iso_tokenwrap (_
,info
,_
,_
) s ast iso
= wrap ast info
.Ast.line iso
294 (match Ast0.unwrap d
with
295 Ast0.DOTS
(x
) -> Ast.DOTS
(List.map fn x
)
296 | Ast0.CIRCLES
(x
) -> Ast.CIRCLES
(List.map fn x
)
297 | Ast0.STARS
(x
) -> Ast.STARS
(List.map fn x
))
299 (* commas in dotted lists, here due to polymorphism restrictions *)
301 let add_comma is_comma make_comma itemlist
=
302 match Ast0.unwrap itemlist
with
304 (match List.rev x
with
311 match Ast0.get_mcodekind e
with
312 Ast0.MINUS
(_
) -> (Ast0.make_minus_mcode
",")
313 | _
-> (Ast0.make_mcode
",") in
316 (List.rev
(Ast0.rewrap e
(make_comma
comma) :: (e
::es
)))))
317 | _
-> failwith
"not possible"
321 (function x
-> match Ast0.unwrap x
with Ast0.EComma _
-> true | _
-> false)
322 (function x
-> Ast0.EComma x
)
326 (function x
-> match Ast0.unwrap x
with Ast0.IComma _
-> true | _
-> false)
327 (function x
-> Ast0.IComma x
)
329 (* --------------------------------------------------------------------- *)
332 let rec do_isos l
= List.map
(function (nm
,x
) -> (nm
,anything x
)) l
335 rewrap i
(do_isos (Ast0.get_iso i
))
336 (match Ast0.unwrap i
with
337 Ast0.Id
(name
) -> Ast.Id
(mcode name
)
338 | Ast0.MetaId
(name
,constraints
,_
) ->
339 Ast.MetaId
(mcode name
,constraints
,unitary,false)
340 | Ast0.MetaFunc
(name
,constraints
,_
) ->
341 Ast.MetaFunc
(mcode name
,constraints
,unitary,false)
342 | Ast0.MetaLocalFunc
(name
,constraints
,_
) ->
343 Ast.MetaLocalFunc
(mcode name
,constraints
,unitary,false)
344 | Ast0.OptIdent
(id
) -> Ast.OptIdent
(ident id
)
345 | Ast0.UniqueIdent
(id
) -> Ast.UniqueIdent
(ident id
))
347 (* --------------------------------------------------------------------- *)
352 rewrap e
(do_isos (Ast0.get_iso e
))
353 (match Ast0.unwrap e
with
354 Ast0.Ident
(id
) -> Ast.Ident
(ident id
)
355 | Ast0.Constant
(const
) ->
356 Ast.Constant
(mcode const
)
357 | Ast0.FunCall
(fn
,lp
,args
,rp
) ->
358 let fn = expression fn in
360 let args = dots expression args in
362 Ast.FunCall
(fn,lp,args,rp)
363 | Ast0.Assignment
(left
,op
,right
,simple
) ->
364 Ast.Assignment
(expression left
,mcode op
,expression right
,simple
)
365 | Ast0.CondExpr
(exp1
,why
,exp2
,colon
,exp3
) ->
366 let exp1 = expression exp1 in
367 let why = mcode why in
368 let exp2 = get_option expression exp2 in
369 let colon = mcode colon in
370 let exp3 = expression exp3 in
371 Ast.CondExpr
(exp1,why,exp2,colon,exp3)
372 | Ast0.Postfix
(exp
,op
) ->
373 Ast.Postfix
(expression exp
,mcode op
)
374 | Ast0.Infix
(exp
,op
) ->
375 Ast.Infix
(expression exp
,mcode op
)
376 | Ast0.Unary
(exp
,op
) ->
377 Ast.Unary
(expression exp
,mcode op
)
378 | Ast0.Binary
(left
,op
,right
) ->
379 Ast.Binary
(expression left
,mcode op
,expression right
)
380 | Ast0.Nested
(left
,op
,right
) ->
381 Ast.Nested
(expression left
,mcode op
,expression right
)
382 | Ast0.Paren
(lp,exp
,rp) ->
383 Ast.Paren
(mcode lp,expression exp
,mcode rp)
384 | Ast0.ArrayAccess
(exp1,lb
,exp2,rb
) ->
385 Ast.ArrayAccess
(expression exp1,mcode lb
,expression exp2,mcode rb
)
386 | Ast0.RecordAccess
(exp
,pt
,field
) ->
387 Ast.RecordAccess
(expression exp
,mcode pt
,ident field
)
388 | Ast0.RecordPtAccess
(exp
,ar
,field
) ->
389 Ast.RecordPtAccess
(expression exp
,mcode ar
,ident field
)
390 | Ast0.Cast
(lp,ty
,rp,exp
) ->
391 Ast.Cast
(mcode lp,typeC ty
,mcode rp,expression exp
)
392 | Ast0.SizeOfExpr
(szf
,exp
) ->
393 Ast.SizeOfExpr
(mcode szf
,expression exp
)
394 | Ast0.SizeOfType
(szf
,lp,ty
,rp) ->
395 Ast.SizeOfType
(mcode szf
, mcode lp,typeC ty
,mcode rp)
396 | Ast0.TypeExp
(ty
) -> Ast.TypeExp
(typeC ty
)
397 | Ast0.MetaErr
(name
,cstrts
,_
) ->
398 Ast.MetaErr
(mcode name
,constraints cstrts
,unitary,false)
399 | Ast0.MetaExpr
(name
,cstrts
,ty
,form
,_
) ->
400 Ast.MetaExpr
(mcode name
,constraints cstrts
,unitary,ty
,form
,false)
401 | Ast0.MetaExprList
(name
,lenname
,_
) ->
402 Ast.MetaExprList
(mcode name
,do_lenname lenname
,unitary,false)
403 | Ast0.EComma
(cm
) -> Ast.EComma
(mcode cm
)
404 | Ast0.DisjExpr
(_
,exps
,_
,_
) ->
405 Ast.DisjExpr
(List.map
expression exps
)
406 | Ast0.NestExpr
(starter
,exp_dots
,ender
,whencode
,multi
) ->
407 let starter = mcode starter in
408 let whencode = get_option expression whencode in
409 let ender = mcode ender in
410 Ast.NestExpr
(starter,dots expression exp_dots
,ender,whencode,multi
)
411 | Ast0.Edots
(dots,whencode) ->
412 let dots = mcode dots in
413 let whencode = get_option expression whencode in
414 Ast.Edots
(dots,whencode)
415 | Ast0.Ecircles
(dots,whencode) ->
416 let dots = mcode dots in
417 let whencode = get_option expression whencode in
418 Ast.Ecircles
(dots,whencode)
419 | Ast0.Estars
(dots,whencode) ->
420 let dots = mcode dots in
421 let whencode = get_option expression whencode in
422 Ast.Estars
(dots,whencode)
423 | Ast0.OptExp
(exp
) -> Ast.OptExp
(expression exp
)
424 | Ast0.UniqueExp
(exp
) -> Ast.UniqueExp
(expression exp
)) in
425 if Ast0.get_test_exp e
then Ast.set_test_exp
e1 else e1
427 and expression_dots ed
= dots expression ed
431 Ast0.NoConstraint
-> Ast.NoConstraint
432 | Ast0.NotIdCstrt idctrt
-> Ast.NotIdCstrt idctrt
433 | Ast0.NotExpCstrt exps
-> Ast.NotExpCstrt
(List.map
expression exps
)
434 | Ast0.SubExpCstrt ids
-> Ast.SubExpCstrt ids
436 and do_lenname
= function
437 Ast0.MetaListLen
(nm
) -> Ast.MetaListLen
(mcode nm
,unitary,false)
438 | Ast0.CstListLen n
-> Ast.CstListLen n
439 | Ast0.AnyListLen
-> Ast.AnyListLen
441 (* --------------------------------------------------------------------- *)
444 and rewrap_iso t t1
= rewrap t
(do_isos (Ast0.get_iso t
)) t1
447 rewrap t
(do_isos (Ast0.get_iso t
))
448 (match Ast0.unwrap t
with
449 Ast0.ConstVol
(cv
,ty
) ->
450 let rec collect_disjs t
=
451 match Ast0.unwrap t
with
452 Ast0.DisjType
(_
,types
,_
,_
) ->
453 if Ast0.get_iso t
= []
454 then List.concat (List.map
collect_disjs types
)
455 else failwith
"unexpected iso on a disjtype"
461 (Some
(mcode cv
),rewrap_iso ty
(base_typeC ty
)))
462 (collect_disjs ty
) in
463 (* one could worry that isos are lost because we flatten the
464 disjunctions. but there should not be isos on the disjunctions
468 | types
-> Ast.DisjType
(List.map
(rewrap t
no_isos) types
))
469 | Ast0.BaseType
(_
) | Ast0.Signed
(_
,_
) | Ast0.Pointer
(_
,_
)
470 | Ast0.FunctionPointer
(_
,_
,_
,_
,_
,_
,_
) | Ast0.FunctionType
(_
,_
,_
,_
)
471 | Ast0.Array
(_
,_
,_
,_
) | Ast0.EnumName
(_
,_
) | Ast0.StructUnionName
(_
,_
)
472 | Ast0.StructUnionDef
(_
,_
,_
,_
) | Ast0.EnumDef
(_
,_
,_
,_
)
473 | Ast0.TypeName
(_
) | Ast0.MetaType
(_
,_
) ->
474 Ast.Type
(None
,rewrap t
no_isos (base_typeC t
))
475 | Ast0.DisjType
(_
,types
,_
,_
) -> Ast.DisjType
(List.map
typeC types
)
476 | Ast0.OptType
(ty
) -> Ast.OptType
(typeC ty
)
477 | Ast0.UniqueType
(ty
) -> Ast.UniqueType
(typeC ty
))
480 match Ast0.unwrap t
with
481 Ast0.BaseType
(ty
,strings
) -> Ast.BaseType
(ty
,List.map
mcode strings
)
482 | Ast0.Signed
(sgn
,ty
) ->
483 Ast.SignedT
(mcode sgn
,
484 get_option (function x
-> rewrap_iso x
(base_typeC x
)) ty
)
485 | Ast0.Pointer
(ty
,star
) -> Ast.Pointer
(typeC ty
,mcode star
)
486 | Ast0.FunctionPointer
(ty
,lp1
,star
,rp1
,lp2
,params
,rp2
) ->
488 (typeC ty
,mcode lp1
,mcode star
,mcode rp1
,
489 mcode lp2
,parameter_list params
,mcode rp2
)
490 | Ast0.FunctionType
(ret
,lp,params
,rp) ->
491 let allminus = check_allminus.VT0.combiner_rec_typeC t
in
493 (allminus,get_option typeC ret
,mcode lp,
494 parameter_list params
,mcode rp)
495 | Ast0.Array
(ty
,lb
,size
,rb
) ->
496 Ast.Array
(typeC ty
,mcode lb
,get_option expression size
,mcode rb
)
497 | Ast0.EnumName
(kind
,name
) ->
498 Ast.EnumName
(mcode kind
,get_option ident name
)
499 | Ast0.EnumDef
(ty
,lb
,ids
,rb
) ->
500 let ids = add_exp_comma ids in
501 Ast.EnumDef
(typeC ty
,mcode lb
,dots expression ids,mcode rb
)
502 | Ast0.StructUnionName
(kind
,name
) ->
503 Ast.StructUnionName
(mcode kind
,get_option ident name
)
504 | Ast0.StructUnionDef
(ty
,lb
,decls
,rb
) ->
505 Ast.StructUnionDef
(typeC ty
,mcode lb
,
506 dots declaration decls
,
508 | Ast0.TypeName
(name
) -> Ast.TypeName
(mcode name
)
509 | Ast0.MetaType
(name
,_
) ->
510 Ast.MetaType
(mcode name
,unitary,false)
511 | _
-> failwith
"ast0toast: unexpected type"
513 (* --------------------------------------------------------------------- *)
514 (* Variable declaration *)
515 (* Even if the Cocci program specifies a list of declarations, they are
516 split out into multiple declarations of a single variable each. *)
519 rewrap d
(do_isos (Ast0.get_iso d
))
520 (match Ast0.unwrap d
with
521 Ast0.MetaDecl
(name
,_
) -> Ast.MetaDecl
(mcode name
,unitary,false)
522 | Ast0.MetaField
(name
,_
) -> Ast.MetaField
(mcode name
,unitary,false)
523 | Ast0.Init
(stg
,ty
,id
,eq
,ini
,sem
) ->
524 let stg = get_option mcode stg in
528 let ini = initialiser
ini in
529 let sem = mcode sem in
530 Ast.Init
(stg,ty,id,eq,ini,sem)
531 | Ast0.UnInit
(stg,ty,id,sem) ->
532 (match Ast0.unwrap
ty with
533 Ast0.FunctionType
(tyx
,lp1
,params
,rp1
) ->
534 let allminus = check_allminus.VT0.combiner_rec_declaration d
in
535 Ast.UnInit
(get_option mcode stg,
536 rewrap ty (do_isos (Ast0.get_iso
ty))
541 (allminus,get_option typeC tyx
,mcode lp1
,
542 parameter_list params
,mcode rp1
)))),
544 | _
-> Ast.UnInit
(get_option mcode stg,typeC ty,ident
id,mcode sem))
545 | Ast0.MacroDecl
(name
,lp,args,rp,sem) ->
546 let name = ident
name in
548 let args = dots expression args in
550 let sem = mcode sem in
551 Ast.MacroDecl
(name,lp,args,rp,sem)
552 | Ast0.TyDecl
(ty,sem) -> Ast.TyDecl
(typeC ty,mcode sem)
553 | Ast0.Typedef
(stg,ty,id,sem) ->
555 (match Ast.unwrap
id with
556 Ast.Type
(None
,id) -> (* only MetaType or Id *)
557 Ast.Typedef
(mcode stg,typeC ty,id,mcode sem)
558 | _
-> failwith
"bad typedef")
559 | Ast0.DisjDecl
(_
,decls
,_
,_
) -> Ast.DisjDecl
(List.map
declaration decls
)
560 | Ast0.Ddots
(dots,whencode) ->
561 let dots = mcode dots in
562 let whencode = get_option declaration whencode in
563 Ast.Ddots
(dots,whencode)
564 | Ast0.OptDecl
(decl
) -> Ast.OptDecl
(declaration decl
)
565 | Ast0.UniqueDecl
(decl
) -> Ast.UniqueDecl
(declaration decl
))
567 and declaration_dots l
= dots declaration l
569 (* --------------------------------------------------------------------- *)
572 and strip_idots initlist
=
574 match Ast0.get_mcode_mcodekind mc
with
577 match Ast0.unwrap initlist
with
580 match List.rev
l with
583 (match (Ast0.unwrap x
,Ast0.unwrap y
) with
584 (Ast0.IComma _
,Ast0.Idots _
) ->
585 (* drop comma that was added by add_comma *)
588 let (whencode,init
,dotinfo
) =
589 let rec loop = function
592 (match Ast0.unwrap x
with
593 Ast0.Idots
(dots,Some
whencode) ->
594 let (restwhen
,restinit
,dotinfo
) = loop rest
in
595 (whencode :: restwhen
, restinit
,
596 (isminus dots)::dotinfo
)
597 | Ast0.Idots
(dots,None
) ->
598 let (restwhen
,restinit
,dotinfo
) = loop rest
in
599 (restwhen
, restinit
, (isminus dots)::dotinfo
)
601 let (restwhen
,restinit
,dotinfo
) = loop rest
in
602 (restwhen
,x
::restinit
,dotinfo
)) in
605 if List.for_all
(function x
-> not x
) dotinfo
606 then false (* false if no dots *)
608 if List.for_all
(function x
-> x
) dotinfo
610 else failwith
"inconsistent annotations on initialiser list dots" in
611 (whencode, init
, allminus)
612 | Ast0.CIRCLES
(x
) | Ast0.STARS
(x
) -> failwith
"not possible for an initlist"
616 (match Ast0.unwrap i
with
617 Ast0.MetaInit
(name,_
) -> Ast.MetaInit
(mcode name,unitary,false)
618 | Ast0.InitExpr
(exp
) -> Ast.InitExpr
(expression exp
)
619 | Ast0.InitList
(lb
,initlist
,rb
,true) ->
620 let initlist = add_init_comma
initlist in
621 Ast.ArInitList
(mcode lb
,dots initialiser
initlist,mcode rb
)
622 | Ast0.InitList
(lb
,initlist,rb
,false) ->
623 let initlist = add_init_comma
initlist in
624 let (whencode,initlist,allminus) = strip_idots
initlist in
626 (allminus,mcode lb
,List.map initialiser
initlist,mcode rb
,
627 List.map initialiser
whencode)
628 | Ast0.InitGccExt
(designators
,eq,ini) ->
629 Ast.InitGccExt
(List.map designator designators
,mcode eq,
631 | Ast0.InitGccName
(name,eq,ini) ->
632 Ast.InitGccName
(ident
name,mcode eq,initialiser
ini)
633 | Ast0.IComma
(comma) -> Ast.IComma
(mcode comma)
634 | Ast0.Idots
(dots,whencode) ->
635 let dots = mcode dots in
636 let whencode = get_option initialiser
whencode in
637 Ast.Idots
(dots,whencode)
638 | Ast0.OptIni
(ini) -> Ast.OptIni
(initialiser
ini)
639 | Ast0.UniqueIni
(ini) -> Ast.UniqueIni
(initialiser
ini))
641 and designator
= function
642 Ast0.DesignatorField
(dot
,id) -> Ast.DesignatorField
(mcode dot
,ident
id)
643 | Ast0.DesignatorIndex
(lb
,exp
,rb
) ->
644 Ast.DesignatorIndex
(mcode lb
, expression exp
, mcode rb
)
645 | Ast0.DesignatorRange
(lb
,min
,dots,max
,rb
) ->
646 Ast.DesignatorRange
(mcode lb
,expression min
,mcode dots,expression max
,
649 (* --------------------------------------------------------------------- *)
652 and parameterTypeDef p
=
654 (match Ast0.unwrap p
with
655 Ast0.VoidParam
(ty) -> Ast.VoidParam
(typeC ty)
656 | Ast0.Param
(ty,id) -> Ast.Param
(typeC ty,get_option ident
id)
657 | Ast0.MetaParam
(name,_
) ->
658 Ast.MetaParam
(mcode name,unitary,false)
659 | Ast0.MetaParamList
(name,lenname
,_
) ->
660 Ast.MetaParamList
(mcode name,do_lenname lenname
,unitary,false)
661 | Ast0.PComma
(cm
) -> Ast.PComma
(mcode cm
)
662 | Ast0.Pdots
(dots) -> Ast.Pdots
(mcode dots)
663 | Ast0.Pcircles
(dots) -> Ast.Pcircles
(mcode dots)
664 | Ast0.OptParam
(param
) -> Ast.OptParam
(parameterTypeDef param
)
665 | Ast0.UniqueParam
(param
) -> Ast.UniqueParam
(parameterTypeDef param
))
667 and parameter_list
l = dots parameterTypeDef
l
669 (* --------------------------------------------------------------------- *)
673 let rec statement seqible s
=
674 let rewrap_stmt ast0 ast
=
676 match Ast0.get_dots_bef_aft s
with
677 Ast0.NoDots
-> Ast.NoDots
678 | Ast0.DroppingBetweenDots s
->
679 Ast.DroppingBetweenDots
(statement seqible s
,get_ctr())
680 | Ast0.AddingBetweenDots s
->
681 Ast.AddingBetweenDots
(statement seqible s
,get_ctr()) in
682 Ast.set_dots_bef_aft
befaft (rewrap ast0
no_isos ast
) in
683 let rewrap_rule_elem ast0 ast
=
684 rewrap ast0
(do_isos (Ast0.get_iso ast0
)) ast
in
686 (match Ast0.unwrap s
with
687 Ast0.Decl
((_
,bef
),decl
) ->
688 Ast.Atomic
(rewrap_rule_elem s
689 (Ast.Decl
(convert_mcodekind (-1) bef
,
690 check_allminus.VT0.combiner_rec_statement s
,
692 | Ast0.Seq
(lbrace
,body
,rbrace
) ->
693 let lbrace = mcode lbrace in
694 let body = dots (statement seqible
) body in
695 let rbrace = mcode rbrace in
696 Ast.Seq
(iso_tokenwrap lbrace s
(Ast.SeqStart
(lbrace))
697 (do_isos (Ast0.get_iso s
)),
699 tokenwrap rbrace s
(Ast.SeqEnd
(rbrace)))
700 | Ast0.ExprStatement
(exp
,sem) ->
701 Ast.Atomic
(rewrap_rule_elem s
702 (Ast.ExprStatement
(expression exp
,mcode sem)))
703 | Ast0.IfThen
(iff
,lp,exp
,rp,branch
,(_
,aft
)) ->
706 (Ast.IfHeader
(mcode iff
,mcode lp,expression exp
,mcode rp)),
707 statement Ast.NotSequencible branch
,
708 ([],[],[],convert_mcodekind (-1) aft
))
709 | Ast0.IfThenElse
(iff
,lp,exp
,rp,branch1
,els
,branch2
,(_
,aft
)) ->
710 let els = mcode els in
713 (Ast.IfHeader
(mcode iff
,mcode lp,expression exp
,mcode rp)),
714 statement Ast.NotSequencible branch1
,
715 tokenwrap els s
(Ast.Else
(els)),
716 statement Ast.NotSequencible branch2
,
717 ([],[],[],convert_mcodekind (-1) aft
))
718 | Ast0.While
(wh
,lp,exp
,rp,body,(_
,aft
)) ->
719 Ast.While
(rewrap_rule_elem s
721 (mcode wh
,mcode lp,expression exp
,mcode rp)),
722 statement Ast.NotSequencible
body,
723 ([],[],[],convert_mcodekind (-1) aft
))
724 | Ast0.Do
(d
,body,wh
,lp,exp
,rp,sem) ->
726 Ast.Do
(rewrap_rule_elem s
(Ast.DoHeader
(mcode d
)),
727 statement Ast.NotSequencible
body,
729 (Ast.WhileTail
(wh,mcode lp,expression exp
,mcode rp,
731 | Ast0.For
(fr
,lp,exp1,sem1
,exp2,sem2
,exp3,rp,body,(_
,aft
)) ->
734 let exp1 = get_option expression exp1 in
735 let sem1 = mcode sem1 in
736 let exp2 = get_option expression exp2 in
737 let sem2= mcode sem2 in
738 let exp3 = get_option expression exp3 in
740 let body = statement Ast.NotSequencible
body in
741 Ast.For
(rewrap_rule_elem s
742 (Ast.ForHeader
(fr,lp,exp1,sem1,exp2,sem2,exp3,rp)),
743 body,([],[],[],convert_mcodekind (-1) aft
))
744 | Ast0.Iterator
(nm
,lp,args,rp,body,(_
,aft
)) ->
745 Ast.Iterator
(rewrap_rule_elem s
748 dots expression args,
750 statement Ast.NotSequencible
body,
751 ([],[],[],convert_mcodekind (-1) aft
))
752 | Ast0.Switch
(switch
,lp,exp
,rp,lb
,decls
,cases
,rb
) ->
753 let switch = mcode switch in
755 let exp = expression exp in
758 let decls = dots (statement seqible
) decls in
759 let cases = List.map
case_line (Ast0.undots
cases) in
761 Ast.Switch
(rewrap_rule_elem s
(Ast.SwitchHeader
(switch,lp,exp,rp)),
762 tokenwrap lb s
(Ast.SeqStart
(lb)),
764 tokenwrap rb s
(Ast.SeqEnd
(rb)))
765 | Ast0.Break
(br
,sem) ->
766 Ast.Atomic
(rewrap_rule_elem s
(Ast.Break
(mcode br
,mcode sem)))
767 | Ast0.Continue
(cont
,sem) ->
768 Ast.Atomic
(rewrap_rule_elem s
(Ast.Continue
(mcode cont
,mcode sem)))
769 | Ast0.Label
(l,dd
) ->
770 Ast.Atomic
(rewrap_rule_elem s
(Ast.Label
(ident
l,mcode dd
)))
771 | Ast0.Goto
(goto
,l,sem) ->
773 (rewrap_rule_elem s
(Ast.Goto
(mcode goto
,ident
l,mcode sem)))
774 | Ast0.Return
(ret
,sem) ->
775 Ast.Atomic
(rewrap_rule_elem s
(Ast.Return
(mcode ret
,mcode sem)))
776 | Ast0.ReturnExpr
(ret
,exp,sem) ->
779 (Ast.ReturnExpr
(mcode ret
,expression exp,mcode sem)))
780 | Ast0.MetaStmt
(name,_
) ->
781 Ast.Atomic
(rewrap_rule_elem s
782 (Ast.MetaStmt
(mcode name,unitary,seqible
,false)))
783 | Ast0.MetaStmtList
(name,_
) ->
784 Ast.Atomic
(rewrap_rule_elem s
785 (Ast.MetaStmtList
(mcode name,unitary,false)))
786 | Ast0.TopExp
(exp) ->
787 Ast.Atomic
(rewrap_rule_elem s
(Ast.TopExp
(expression exp)))
789 Ast.Atomic
(rewrap_rule_elem s
(Ast.Exp
(expression exp)))
790 | Ast0.TopInit
(init
) ->
791 Ast.Atomic
(rewrap_rule_elem s
(Ast.TopInit
(initialiser init
)))
793 Ast.Atomic
(rewrap_rule_elem s
(Ast.Ty
(typeC ty)))
794 | Ast0.Disj
(_
,rule_elem_dots_list
,_
,_
) ->
795 Ast.Disj
(List.map
(function x
-> statement_dots seqible x
)
797 | Ast0.Nest
(starter,rule_elem_dots
,ender,whn
,multi
) ->
799 (mcode starter,statement_dots
Ast.Sequencible rule_elem_dots
,
802 (whencode (statement_dots
Ast.Sequencible
)
803 (statement Ast.NotSequencible
))
806 | Ast0.Dots
(d
,whn
) ->
810 (whencode (statement_dots
Ast.Sequencible
)
811 (statement Ast.NotSequencible
))
813 Ast.Dots
(d,whn,[],[])
814 | Ast0.Circles
(d,whn) ->
818 (whencode (statement_dots
Ast.Sequencible
)
819 (statement Ast.NotSequencible
))
821 Ast.Circles
(d,whn,[],[])
822 | Ast0.Stars
(d,whn) ->
826 (whencode (statement_dots
Ast.Sequencible
)
827 (statement Ast.NotSequencible
))
829 Ast.Stars
(d,whn,[],[])
830 | Ast0.FunDecl
((_
,bef
),fi
,name,lp,params
,rp,lbrace,body,rbrace) ->
831 let fi = List.map fninfo
fi in
832 let name = ident
name in
834 let params = parameter_list
params in
836 let lbrace = mcode lbrace in
837 let body = dots (statement seqible
) body in
838 let rbrace = mcode rbrace in
839 let allminus = check_allminus.VT0.combiner_rec_statement s
in
840 Ast.FunDecl
(rewrap_rule_elem s
841 (Ast.FunHeader
(convert_mcodekind (-1) bef
,
842 allminus,fi,name,lp,params,rp)),
843 tokenwrap lbrace s
(Ast.SeqStart
(lbrace)),
845 tokenwrap rbrace s
(Ast.SeqEnd
(rbrace)))
846 | Ast0.Include
(inc
,str
) ->
847 Ast.Atomic
(rewrap_rule_elem s
(Ast.Include
(mcode inc
,mcode str
)))
848 | Ast0.Define
(def
,id,params,body) ->
852 (mcode def
,ident
id, define_parameters
params)),
853 statement_dots
Ast.NotSequencible
(*not sure*) body)
854 | Ast0.OptStm
(stm
) -> Ast.OptStm
(statement seqible stm
)
855 | Ast0.UniqueStm
(stm
) -> Ast.UniqueStm
(statement seqible stm
))
857 and define_parameters p
=
859 (match Ast0.unwrap p
with
860 Ast0.NoParams
-> Ast.NoParams
861 | Ast0.DParams
(lp,params,rp) ->
862 Ast.DParams
(mcode lp,
863 dots define_param
params,
868 (match Ast0.unwrap p
with
869 Ast0.DParam
(id) -> Ast.DParam
(ident
id)
870 | Ast0.DPComma
(comma) -> Ast.DPComma
(mcode comma)
871 | Ast0.DPdots
(d) -> Ast.DPdots
(mcode d)
872 | Ast0.DPcircles
(c) -> Ast.DPcircles
(mcode c)
873 | Ast0.OptDParam
(dp
) -> Ast.OptDParam
(define_param dp
)
874 | Ast0.UniqueDParam
(dp
) -> Ast.UniqueDParam
(define_param dp
))
876 and whencode notfn alwaysfn
= function
877 Ast0.WhenNot a
-> Ast.WhenNot
(notfn a
)
878 | Ast0.WhenAlways a
-> Ast.WhenAlways
(alwaysfn a
)
879 | Ast0.WhenModifier
(x
) -> Ast.WhenModifier
(x
)
881 let rewrap_rule_elem ast0 ast
=
882 rewrap ast0
(do_isos (Ast0.get_iso ast0
)) ast
in
884 Ast0.WhenNotTrue
(e
) ->
885 Ast.WhenNotTrue
(rewrap_rule_elem e
(Ast.Exp
(expression e
)))
886 | Ast0.WhenNotFalse
(e
) ->
887 Ast.WhenNotFalse
(rewrap_rule_elem e
(Ast.Exp
(expression e
)))
888 | _
-> failwith
"not possible"
890 and process_list seqible isos
= function
893 let first = statement seqible x
in
895 if !Flag.track_iso_usage
896 then Ast.set_isos
first (isos
@(Ast.get_isos
first))
898 (match Ast0.unwrap x
with
899 Ast0.Dots
(_
,_
) | Ast0.Nest
(_
) ->
900 first::(process_list
(Ast.SequencibleAfterDots
[]) no_isos rest
)
902 first::(process_list
Ast.Sequencible
no_isos rest
))
904 and statement_dots seqible
d =
905 let isos = do_isos (Ast0.get_iso
d) in
907 (match Ast0.unwrap
d with
908 Ast0.DOTS
(x
) -> Ast.DOTS
(process_list seqible
isos x
)
909 | Ast0.CIRCLES
(x
) -> Ast.CIRCLES
(process_list seqible
isos x
)
910 | Ast0.STARS
(x
) -> Ast.STARS
(process_list seqible
isos x
))
912 (* the following is no longer used.
913 the goal was to let one put a statement at the very beginning of a function
914 pattern and have it skip over the declarations in the C code.
915 that feature was removed a long time ago, however, in favor of
916 ... when != S, which also causes whatever comes after it to match the
917 first real statement.
918 the separation of declarations from the rest of the body means that the
919 quantifier of any variable shared between them comes out too high, posing
920 problems when there is ... decl ... stmt, as the quantifier of any shared
921 variable will be around the whole thing, making variables not free enough
922 in the first ..., and thus not implementing the expected shortest path
923 condition. example: f() { ... int A; ... foo(A); }.
924 the quantifier for A should start just before int A, not at the top of the
926 and separate_decls seqible d =
927 let rec collect_decls = function
930 (match Ast0.unwrap x with
932 let (decls,other) = collect_decls xs in
934 | Ast0.Dots(_,_) | Ast0.Nest(_,_,_,_,_) ->
935 let (decls,other) = collect_decls xs in
938 | _ -> (x :: decls,other))
939 | Ast0.Disj(starter,stmt_dots_list,mids,ender) ->
940 let disjs = List.map collect_dot_decls stmt_dots_list in
941 let all_decls = List.for_all (function (_,s) -> s=[]) disjs in
944 let (decls,other) = collect_decls xs in
949 and collect_dot_decls d =
950 match Ast0.unwrap d with
951 Ast0.DOTS(x) -> collect_decls x
952 | Ast0.CIRCLES(x) -> collect_decls x
953 | Ast0.STARS(x) -> collect_decls x in
956 let (decls,other) = collect_decls l in
957 (rewrap d no_isos (fn (List.map (statement seqible) decls)),
959 (fn (process_list seqible (do_isos (Ast0.get_iso d)) other))) in
960 match Ast0.unwrap d with
961 Ast0.DOTS(x) -> process x d (function x -> Ast.DOTS x)
962 | Ast0.CIRCLES(x) -> process x d (function x -> Ast.CIRCLES x)
963 | Ast0.STARS(x) -> process x d (function x -> Ast.STARS x) *) in
965 statement Ast.Sequencible s
967 and fninfo
= function
968 Ast0.FStorage
(stg) -> Ast.FStorage
(mcode stg)
969 | Ast0.FType
(ty) -> Ast.FType
(typeC ty)
970 | Ast0.FInline
(inline
) -> Ast.FInline
(mcode inline
)
971 | Ast0.FAttr
(attr
) -> Ast.FAttr
(mcode attr
)
973 and option_to_list
= function
979 (match Ast0.unwrap
c with
980 Ast0.Default
(def
,colon,code
) ->
981 let def = mcode def in
982 let colon = mcode colon in
983 let code = dots statement code in
984 Ast.CaseLine
(rewrap c no_isos (Ast.Default
(def,colon)),code)
985 | Ast0.Case
(case
,exp,colon,code) ->
986 let case = mcode case in
987 let exp = expression exp in
988 let colon = mcode colon in
989 let code = dots statement code in
990 Ast.CaseLine
(rewrap c no_isos (Ast.Case
(case,exp,colon)),code)
991 | Ast0.DisjCase
(_
,case_lines
,_
,_
) ->
992 failwith
"not supported"
993 (*Ast.CaseLine(Ast.DisjRuleElem(List.map case_line case_lines))*)
995 | Ast0.OptCase
(case) -> Ast.OptCase
(case_line case))
997 and statement_dots
l = dots statement l
999 (* --------------------------------------------------------------------- *)
1001 (* what is possible is only what is at the top level in an iso *)
1002 and anything
= function
1003 Ast0.DotsExprTag
(d) -> Ast.ExprDotsTag
(expression_dots
d)
1004 | Ast0.DotsParamTag
(d) -> Ast.ParamDotsTag
(parameter_list
d)
1005 | Ast0.DotsInitTag
(d) -> failwith
"not possible"
1006 | Ast0.DotsStmtTag
(d) -> Ast.StmtDotsTag
(statement_dots
d)
1007 | Ast0.DotsDeclTag
(d) -> Ast.DeclDotsTag
(declaration_dots
d)
1008 | Ast0.DotsCaseTag
(d) -> failwith
"not possible"
1009 | Ast0.IdentTag
(d) -> Ast.IdentTag
(ident
d)
1010 | Ast0.ExprTag
(d) -> Ast.ExpressionTag
(expression d)
1011 | Ast0.ArgExprTag
(d) | Ast0.TestExprTag
(d) ->
1012 failwith
"only in isos, not converted to ast"
1013 | Ast0.TypeCTag
(d) -> Ast.FullTypeTag
(typeC d)
1014 | Ast0.ParamTag
(d) -> Ast.ParamTag
(parameterTypeDef
d)
1015 | Ast0.InitTag
(d) -> Ast.InitTag
(initialiser
d)
1016 | Ast0.DeclTag
(d) -> Ast.DeclarationTag
(declaration d)
1017 | Ast0.StmtTag
(d) -> Ast.StatementTag
(statement d)
1018 | Ast0.CaseLineTag
(d) -> Ast.CaseLineTag
(case_line d)
1019 | Ast0.TopTag
(d) -> Ast.Code
(top_level
d)
1020 | Ast0.IsoWhenTag
(_
) -> failwith
"not possible"
1021 | Ast0.IsoWhenTTag
(_
) -> failwith
"not possible"
1022 | Ast0.IsoWhenFTag
(_
) -> failwith
"not possible"
1023 | Ast0.MetaPosTag _
-> failwith
"not possible"
1025 (* --------------------------------------------------------------------- *)
1026 (* Function declaration *)
1027 (* top level isos are probably lost to tracking *)
1031 (match Ast0.unwrap t
with
1032 Ast0.FILEINFO
(old_file
,new_file
) ->
1033 Ast.FILEINFO
(mcode old_file
,mcode new_file
)
1034 | Ast0.DECL
(stmt
) -> Ast.DECL
(statement stmt
)
1035 | Ast0.CODE
(rule_elem_dots
) ->
1036 Ast.CODE
(statement_dots rule_elem_dots
)
1037 | Ast0.ERRORWORDS
(exps
) -> Ast.ERRORWORDS
(List.map
expression exps
)
1038 | Ast0.OTHER
(_
) -> failwith
"eliminated by top_level")
1040 (* --------------------------------------------------------------------- *)
1041 (* Entry point for minus code *)
1043 (* Inline_mcodes is very important - sends + code attached to the - code
1044 down to the mcodes. The functions above can only be used when there is no
1045 attached + code, eg in + code itself. *)
1046 let ast0toast_toplevel x
=
1047 inline_mcodes.VT0.combiner_rec_top_level x
;
1050 let ast0toast name deps dropped exists x is_exp ruletype
=
1051 List.iter
inline_mcodes.VT0.combiner_rec_top_level x
;
1053 (name,(deps
,dropped
,exists
),List.map top_level x
,is_exp
,ruletype
)