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 (* Arities matter for the minus slice, but not for the plus slice. *)
25 (* + only allowed on code in a nest (in_nest = true). ? only allowed on
26 rule_elems, and on subterms if the context is ? also. *)
28 module Ast0
= Ast0_cocci
29 module Ast
= Ast_cocci
30 module V0
= Visitor_ast0
31 module V
= Visitor_ast
33 let unitary = Type_cocci.Unitary
41 (* --------------------------------------------------------------------- *)
42 (* Move plus tokens from the MINUS and CONTEXT structured nodes to the
43 corresponding leftmost and rightmost mcodes *)
47 let option_default = () in
49 let do_nothing r k e
=
51 let einfo = Ast0.get_info e
in
52 match (Ast0.get_mcodekind e
) with
53 Ast0.MINUS
(replacements
) ->
54 (match !replacements
with
57 let minus_try = function
61 Ast0.MINUS
(mreplacements
) -> true | _
-> false)
66 Ast0.MINUS
(mreplacements
) ->
67 mreplacements
:= replacements
73 if not
(minus_try(einfo.Ast0.attachable_start
,
74 einfo.Ast0.mcode_start
)
76 minus_try(einfo.Ast0.attachable_end
,
77 einfo.Ast0.mcode_end
))
79 failwith
"minus tree should not have bad code on both sides")
80 | Ast0.CONTEXT
(befaft
)
81 | Ast0.MIXED
(befaft
) ->
82 let concat starter startinfo ender endinfo
=
84 match (starter
,ender
) with
88 if startinfo
.Ast0.tline_end
= endinfo
.Ast0.tline_start
89 then (* put them in the same inner list *)
90 let last = List.hd
(List.rev starter
) in
91 let butlast = List.rev
(List.tl
(List.rev starter
)) in
92 butlast @ (last@(List.hd ender
)) :: (List.tl ender
)
93 else starter
@ ender
in
95 {endinfo
with Ast0.tline_start
= startinfo
.Ast0.tline_start
}) in
96 let attach_bef bef beforeinfo
= function
100 Ast0.MINUS
(mreplacements
) ->
101 let (mrepl
,tokeninfo
) = !mreplacements
in
102 mreplacements
:= concat bef beforeinfo mrepl tokeninfo
103 | Ast0.CONTEXT
(mbefaft
) ->
105 (Ast.BEFORE
(mbef
),mbeforeinfo
,a
) ->
106 let (newbef
,newinfo
) =
107 concat bef beforeinfo mbef mbeforeinfo
in
108 mbefaft
:= (Ast.BEFORE
(newbef
),newinfo
,a
)
109 | (Ast.AFTER
(maft
),_
,a
) ->
111 (Ast.BEFOREAFTER
(bef
,maft
),beforeinfo
,a
)
112 | (Ast.BEFOREAFTER
(mbef
,maft
),mbeforeinfo
,a
) ->
113 let (newbef
,newinfo
) =
114 concat bef beforeinfo mbef mbeforeinfo
in
116 (Ast.BEFOREAFTER
(newbef
,maft
),newinfo
,a
)
117 | (Ast.NOTHING
,_
,a
) ->
118 mbefaft
:= (Ast.BEFORE
(bef
),beforeinfo
,a
))
119 | _
-> failwith
"unexpected annotation")
123 "context tree should not have bad code on both sides" in
124 let attach_aft aft afterinfo
= function
128 Ast0.MINUS
(mreplacements
) ->
129 let (mrepl
,tokeninfo
) = !mreplacements
in
130 mreplacements
:= concat mrepl tokeninfo aft afterinfo
131 | Ast0.CONTEXT
(mbefaft
) ->
133 (Ast.BEFORE
(mbef
),b
,_
) ->
135 (Ast.BEFOREAFTER
(mbef
,aft
),b
,afterinfo
)
136 | (Ast.AFTER
(maft
),b
,mafterinfo
) ->
137 let (newaft
,newinfo
) =
138 concat maft mafterinfo aft afterinfo
in
139 mbefaft
:= (Ast.AFTER
(newaft
),b
,newinfo
)
140 | (Ast.BEFOREAFTER
(mbef
,maft
),b
,mafterinfo
) ->
141 let (newaft
,newinfo
) =
142 concat maft mafterinfo aft afterinfo
in
144 (Ast.BEFOREAFTER
(mbef
,newaft
),b
,newinfo
)
145 | (Ast.NOTHING
,b
,_
) ->
146 mbefaft
:= (Ast.AFTER
(aft
),b
,afterinfo
))
147 | _
-> failwith
"unexpected annotation")
151 "context tree should not have bad code on both sides" in
153 (Ast.BEFORE
(bef
),beforeinfo
,_
) ->
154 attach_bef bef beforeinfo
155 (einfo.Ast0.attachable_start
,einfo.Ast0.mcode_start
)
156 | (Ast.AFTER
(aft
),_
,afterinfo
) ->
157 attach_aft aft afterinfo
158 (einfo.Ast0.attachable_end
,einfo.Ast0.mcode_end
)
159 | (Ast.BEFOREAFTER
(bef
,aft
),beforeinfo
,afterinfo
) ->
160 attach_bef bef beforeinfo
161 (einfo.Ast0.attachable_start
,einfo.Ast0.mcode_start
);
162 attach_aft aft afterinfo
163 (einfo.Ast0.attachable_end
,einfo.Ast0.mcode_end
)
164 | (Ast.NOTHING
,_
,_
) -> ())
166 V0.combiner
bind option_default
167 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
169 do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
170 do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
171 do_nothing do_nothing do_nothing
173 (* --------------------------------------------------------------------- *)
174 (* For function declarations. Can't use the mcode at the root, because that
175 might be mixed when the function contains ()s, where agglomeration of -s is
179 let donothing r k e
= k e
in
180 let bind x y
= x
&& y
in
181 let option_default = true in
182 let mcode (_
,_
,_
,mc
,_
) =
184 Ast0.MINUS
(r
) -> let (plusses
,_
) = !r
in plusses
= []
187 (* special case for disj *)
188 let expression r k e
=
189 match Ast0.unwrap e
with
190 Ast0.DisjExpr
(starter
,expr_list
,mids
,ender
) ->
191 List.for_all r
.V0.combiner_expression expr_list
194 let declaration r k e
=
195 match Ast0.unwrap e
with
196 Ast0.DisjDecl
(starter
,decls
,mids
,ender
) ->
197 List.for_all r
.V0.combiner_declaration decls
201 match Ast0.unwrap e
with
202 Ast0.DisjType
(starter
,decls
,mids
,ender
) ->
203 List.for_all r
.V0.combiner_typeC decls
206 let statement r k e
=
207 match Ast0.unwrap e
with
208 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
209 List.for_all r
.V0.combiner_statement_dots statement_dots_list
212 V0.combiner
bind option_default
213 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
215 donothing donothing donothing donothing donothing donothing
216 donothing expression typeC donothing donothing declaration
217 statement donothing donothing
219 (* --------------------------------------------------------------------- *)
220 (* --------------------------------------------------------------------- *)
222 let get_option fn
= function
224 | Some x
-> Some
(fn x
)
226 (* --------------------------------------------------------------------- *)
227 (* --------------------------------------------------------------------- *)
230 let convert_info info
=
231 { Ast.line
= info
.Ast0.line_start
; Ast.column
= info
.Ast0.column
;
232 Ast.strbef
= info
.Ast0.strings_before
;
233 Ast.straft
= info
.Ast0.strings_after
; }
235 let convert_mcodekind = function
236 Ast0.MINUS
(replacements
) ->
237 let (replacements
,_
) = !replacements
in
238 Ast.MINUS
(Ast.NoPos
,replacements
)
239 | Ast0.PLUS
-> Ast.PLUS
240 | Ast0.CONTEXT
(befaft
) ->
241 let (befaft
,_
,_
) = !befaft
in Ast.CONTEXT
(Ast.NoPos
,befaft
)
242 | Ast0.MIXED
(_
) -> failwith
"not possible for mcode"
244 let pos_mcode(term
,_
,info
,mcodekind
,pos
) =
245 (* avoids a recursion problem *)
246 (term
,convert_info info
,convert_mcodekind mcodekind
,Ast.NoMetaPos
)
248 let mcode(term
,_
,info
,mcodekind
,pos
) =
251 Ast0.MetaPos
(pos,constraints
,per
) ->
252 Ast.MetaPos
(pos_mcode pos,constraints
,per
,unitary,false)
253 | _
-> Ast.NoMetaPos
in
254 (term
,convert_info info
,convert_mcodekind mcodekind
,pos)
256 (* --------------------------------------------------------------------- *)
258 let wrap ast line isos
=
259 {(Ast.make_term ast
) with Ast.node_line
= line
;
262 let rewrap ast0 isos ast
=
263 wrap ast
((Ast0.get_info ast0
).Ast0.line_start
) isos
267 (* no isos on tokens *)
268 let tokenwrap (_
,info
,_
,_
) s ast
= wrap ast info
.Ast.line
no_isos
269 let iso_tokenwrap (_
,info
,_
,_
) s ast iso
= wrap ast info
.Ast.line iso
273 (match Ast0.unwrap d
with
274 Ast0.DOTS
(x
) -> Ast.DOTS
(List.map fn x
)
275 | Ast0.CIRCLES
(x
) -> Ast.CIRCLES
(List.map fn x
)
276 | Ast0.STARS
(x
) -> Ast.STARS
(List.map fn x
))
278 (* --------------------------------------------------------------------- *)
281 let rec do_isos l
= List.map
(function (nm
,x
) -> (nm
,anything x
)) l
284 rewrap i
(do_isos (Ast0.get_iso i
))
285 (match Ast0.unwrap i
with
286 Ast0.Id
(name
) -> Ast.Id
(mcode name
)
287 | Ast0.MetaId
(name
,constraints
,_
) ->
288 let constraints = List.map ident
constraints in
289 Ast.MetaId
(mcode name
,constraints,unitary,false)
290 | Ast0.MetaFunc
(name
,constraints,_
) ->
291 let constraints = List.map ident
constraints in
292 Ast.MetaFunc
(mcode name
,constraints,unitary,false)
293 | Ast0.MetaLocalFunc
(name
,constraints,_
) ->
294 let constraints = List.map ident
constraints in
295 Ast.MetaLocalFunc
(mcode name
,constraints,unitary,false)
296 | Ast0.OptIdent
(id
) -> Ast.OptIdent
(ident id
)
297 | Ast0.UniqueIdent
(id
) -> Ast.UniqueIdent
(ident id
))
299 (* --------------------------------------------------------------------- *)
304 rewrap e
(do_isos (Ast0.get_iso e
))
305 (match Ast0.unwrap e
with
306 Ast0.Ident
(id
) -> Ast.Ident
(ident id
)
307 | Ast0.Constant
(const
) ->
308 Ast.Constant
(mcode const
)
309 | Ast0.FunCall
(fn
,lp
,args
,rp
) ->
310 let fn = expression fn in
312 let args = dots expression args in
314 Ast.FunCall
(fn,lp,args,rp)
315 | Ast0.Assignment
(left
,op
,right
,simple
) ->
316 Ast.Assignment
(expression left
,mcode op
,expression right
,simple
)
317 | Ast0.CondExpr
(exp1
,why
,exp2
,colon
,exp3
) ->
318 let exp1 = expression exp1 in
319 let why = mcode why in
320 let exp2 = get_option expression exp2 in
321 let colon = mcode colon in
322 let exp3 = expression exp3 in
323 Ast.CondExpr
(exp1,why,exp2,colon,exp3)
324 | Ast0.Postfix
(exp
,op
) ->
325 Ast.Postfix
(expression exp
,mcode op
)
326 | Ast0.Infix
(exp
,op
) ->
327 Ast.Infix
(expression exp
,mcode op
)
328 | Ast0.Unary
(exp
,op
) ->
329 Ast.Unary
(expression exp
,mcode op
)
330 | Ast0.Binary
(left
,op
,right
) ->
331 Ast.Binary
(expression left
,mcode op
,expression right
)
332 | Ast0.Nested
(left
,op
,right
) ->
333 Ast.Nested
(expression left
,mcode op
,expression right
)
334 | Ast0.Paren
(lp,exp
,rp) ->
335 Ast.Paren
(mcode lp,expression exp
,mcode rp)
336 | Ast0.ArrayAccess
(exp1,lb
,exp2,rb
) ->
337 Ast.ArrayAccess
(expression exp1,mcode lb
,expression exp2,mcode rb
)
338 | Ast0.RecordAccess
(exp
,pt
,field
) ->
339 Ast.RecordAccess
(expression exp
,mcode pt
,ident field
)
340 | Ast0.RecordPtAccess
(exp
,ar
,field
) ->
341 Ast.RecordPtAccess
(expression exp
,mcode ar
,ident field
)
342 | Ast0.Cast
(lp,ty
,rp,exp
) ->
343 Ast.Cast
(mcode lp,typeC ty
,mcode rp,expression exp
)
344 | Ast0.SizeOfExpr
(szf
,exp
) ->
345 Ast.SizeOfExpr
(mcode szf
,expression exp
)
346 | Ast0.SizeOfType
(szf
,lp,ty
,rp) ->
347 Ast.SizeOfType
(mcode szf
, mcode lp,typeC ty
,mcode rp)
348 | Ast0.TypeExp
(ty
) -> Ast.TypeExp
(typeC ty
)
349 | Ast0.MetaErr
(name
,constraints,_
) ->
350 let constraints = List.map
expression constraints in
351 Ast.MetaErr
(mcode name
,constraints,unitary,false)
352 | Ast0.MetaExpr
(name
,constraints,ty
,form
,_
) ->
353 let constraints = List.map
expression constraints in
354 Ast.MetaExpr
(mcode name
,constraints,unitary,ty
,form
,false)
355 | Ast0.MetaExprList
(name
,Some lenname
,_
) ->
356 Ast.MetaExprList
(mcode name
,Some
(mcode lenname
,unitary,false),
358 | Ast0.MetaExprList
(name
,None
,_
) ->
359 Ast.MetaExprList
(mcode name
,None
,unitary,false)
360 | Ast0.EComma
(cm
) -> Ast.EComma
(mcode cm
)
361 | Ast0.DisjExpr
(_
,exps
,_
,_
) -> Ast.DisjExpr
(List.map
expression exps
)
362 | Ast0.NestExpr
(_
,exp_dots
,_
,whencode
,multi
) ->
363 let whencode = get_option expression whencode in
364 Ast.NestExpr
(dots expression exp_dots
,whencode,multi
)
365 | Ast0.Edots
(dots,whencode) ->
366 let dots = mcode dots in
367 let whencode = get_option expression whencode in
368 Ast.Edots
(dots,whencode)
369 | Ast0.Ecircles
(dots,whencode) ->
370 let dots = mcode dots in
371 let whencode = get_option expression whencode in
372 Ast.Ecircles
(dots,whencode)
373 | Ast0.Estars
(dots,whencode) ->
374 let dots = mcode dots in
375 let whencode = get_option expression whencode in
376 Ast.Estars
(dots,whencode)
377 | Ast0.OptExp
(exp
) -> Ast.OptExp
(expression exp
)
378 | Ast0.UniqueExp
(exp
) -> Ast.UniqueExp
(expression exp
)) in
379 if Ast0.get_test_exp e
then Ast.set_test_exp
e1 else e1
381 and expression_dots ed
= dots expression ed
383 (* --------------------------------------------------------------------- *)
386 and rewrap_iso t t1
= rewrap t
(do_isos (Ast0.get_iso t
)) t1
389 rewrap t
(do_isos (Ast0.get_iso t
))
390 (match Ast0.unwrap t
with
391 Ast0.ConstVol
(cv
,ty
) ->
392 let rec collect_disjs t
=
393 match Ast0.unwrap t
with
394 Ast0.DisjType
(_
,types
,_
,_
) ->
395 if Ast0.get_iso t
= []
396 then List.concat (List.map
collect_disjs types
)
397 else failwith
"unexpected iso on a disjtype"
403 (Some
(mcode cv
),rewrap_iso ty
(base_typeC ty
)))
404 (collect_disjs ty
) in
405 (* one could worry that isos are lost because we flatten the
406 disjunctions. but there should not be isos on the disjunctions
410 | types
-> Ast.DisjType
(List.map
(rewrap t
no_isos) types
))
411 | Ast0.BaseType
(_
) | Ast0.Signed
(_
,_
) | Ast0.Pointer
(_
,_
)
412 | Ast0.FunctionPointer
(_
,_
,_
,_
,_
,_
,_
) | Ast0.FunctionType
(_
,_
,_
,_
)
413 | Ast0.Array
(_
,_
,_
,_
) | Ast0.EnumName
(_
,_
) | Ast0.StructUnionName
(_
,_
)
414 | Ast0.StructUnionDef
(_
,_
,_
,_
) | Ast0.TypeName
(_
) | Ast0.MetaType
(_
,_
) ->
415 Ast.Type
(None
,rewrap t
no_isos (base_typeC t
))
416 | Ast0.DisjType
(_
,types
,_
,_
) -> Ast.DisjType
(List.map
typeC types
)
417 | Ast0.OptType
(ty
) -> Ast.OptType
(typeC ty
)
418 | Ast0.UniqueType
(ty
) -> Ast.UniqueType
(typeC ty
))
421 match Ast0.unwrap t
with
422 Ast0.BaseType
(ty
,strings
) -> Ast.BaseType
(ty
,List.map
mcode strings
)
423 | Ast0.Signed
(sgn
,ty
) ->
424 Ast.SignedT
(mcode sgn
,
425 get_option (function x
-> rewrap_iso x
(base_typeC x
)) ty
)
426 | Ast0.Pointer
(ty
,star
) -> Ast.Pointer
(typeC ty
,mcode star
)
427 | Ast0.FunctionPointer
(ty
,lp1
,star
,rp1
,lp2
,params
,rp2
) ->
429 (typeC ty
,mcode lp1
,mcode star
,mcode rp1
,
430 mcode lp2
,parameter_list params
,mcode rp2
)
431 | Ast0.FunctionType
(ret
,lp,params
,rp) ->
432 let allminus = check_allminus.V0.combiner_typeC t
in
434 (allminus,get_option typeC ret
,mcode lp,
435 parameter_list params
,mcode rp)
436 | Ast0.Array
(ty
,lb
,size
,rb
) ->
437 Ast.Array
(typeC ty
,mcode lb
,get_option expression size
,mcode rb
)
438 | Ast0.EnumName
(kind
,name
) ->
439 Ast.EnumName
(mcode kind
,ident name
)
440 | Ast0.StructUnionName
(kind
,name
) ->
441 Ast.StructUnionName
(mcode kind
,get_option ident name
)
442 | Ast0.StructUnionDef
(ty
,lb
,decls
,rb
) ->
443 Ast.StructUnionDef
(typeC ty
,mcode lb
,
444 dots declaration decls
,
446 | Ast0.TypeName
(name
) -> Ast.TypeName
(mcode name
)
447 | Ast0.MetaType
(name
,_
) ->
448 Ast.MetaType
(mcode name
,unitary,false)
449 | _
-> failwith
"ast0toast: unexpected type"
451 (* --------------------------------------------------------------------- *)
452 (* Variable declaration *)
453 (* Even if the Cocci program specifies a list of declarations, they are
454 split out into multiple declarations of a single variable each. *)
457 rewrap d
(do_isos (Ast0.get_iso d
))
458 (match Ast0.unwrap d
with
459 Ast0.Init
(stg
,ty
,id
,eq
,ini
,sem
) ->
460 let stg = get_option mcode stg in
464 let ini = initialiser
ini in
465 let sem = mcode sem in
466 Ast.Init
(stg,ty,id,eq,ini,sem)
467 | Ast0.UnInit
(stg,ty,id,sem) ->
468 (match Ast0.unwrap
ty with
469 Ast0.FunctionType
(tyx
,lp1
,params
,rp1
) ->
470 let allminus = check_allminus.V0.combiner_declaration d
in
471 Ast.UnInit
(get_option mcode stg,
472 rewrap ty (do_isos (Ast0.get_iso
ty))
477 (allminus,get_option typeC tyx
,mcode lp1
,
478 parameter_list params
,mcode rp1
)))),
480 | _
-> Ast.UnInit
(get_option mcode stg,typeC ty,ident
id,mcode sem))
481 | Ast0.MacroDecl
(name
,lp,args,rp,sem) ->
482 let name = ident
name in
484 let args = dots expression args in
486 let sem = mcode sem in
487 Ast.MacroDecl
(name,lp,args,rp,sem)
488 | Ast0.TyDecl
(ty,sem) -> Ast.TyDecl
(typeC ty,mcode sem)
489 | Ast0.Typedef
(stg,ty,id,sem) ->
491 (match Ast.unwrap
id with
492 Ast.Type
(None
,id) -> (* only MetaType or Id *)
493 Ast.Typedef
(mcode stg,typeC ty,id,mcode sem)
494 | _
-> failwith
"bad typedef")
495 | Ast0.DisjDecl
(_
,decls
,_
,_
) -> Ast.DisjDecl
(List.map
declaration decls
)
496 | Ast0.Ddots
(dots,whencode) ->
497 let dots = mcode dots in
498 let whencode = get_option declaration whencode in
499 Ast.Ddots
(dots,whencode)
500 | Ast0.OptDecl
(decl
) -> Ast.OptDecl
(declaration decl
)
501 | Ast0.UniqueDecl
(decl
) -> Ast.UniqueDecl
(declaration decl
))
503 and declaration_dots l
= dots declaration l
505 (* --------------------------------------------------------------------- *)
508 and strip_idots initlist
=
509 match Ast0.unwrap initlist
with
511 let (whencode,init
) =
513 (function (prevwhen
,previnit
) ->
515 match Ast0.unwrap cur
with
516 Ast0.Idots
(dots,Some
whencode) ->
517 (whencode :: prevwhen
, previnit
)
518 | Ast0.Idots
(dots,None
) -> (prevwhen
,previnit
)
519 | _
-> (prevwhen
, cur
:: previnit
))
521 (List.rev
whencode, List.rev init
)
522 | Ast0.CIRCLES
(x
) | Ast0.STARS
(x
) -> failwith
"not possible for an initlist"
526 (match Ast0.unwrap i
with
527 Ast0.MetaInit
(name,_
) -> Ast.MetaInit
(mcode name,unitary,false)
528 | Ast0.InitExpr
(exp
) -> Ast.InitExpr
(expression exp
)
529 | Ast0.InitList
(lb
,initlist
,rb
) ->
530 let (whencode,initlist
) = strip_idots initlist
in
531 Ast.InitList
(mcode lb
,List.map initialiser initlist
,mcode rb
,
532 List.map initialiser
whencode)
533 | Ast0.InitGccExt
(designators
,eq,ini) ->
534 Ast.InitGccExt
(List.map designator designators
,mcode eq,
536 | Ast0.InitGccName
(name,eq,ini) ->
537 Ast.InitGccName
(ident
name,mcode eq,initialiser
ini)
538 | Ast0.IComma
(comma
) -> Ast.IComma
(mcode comma
)
539 | Ast0.Idots
(_
,_
) -> failwith
"Idots should have been removed"
540 | Ast0.OptIni
(ini) -> Ast.OptIni
(initialiser
ini)
541 | Ast0.UniqueIni
(ini) -> Ast.UniqueIni
(initialiser
ini))
543 and designator
= function
544 Ast0.DesignatorField
(dot
,id) -> Ast.DesignatorField
(mcode dot
,ident
id)
545 | Ast0.DesignatorIndex
(lb
,exp
,rb
) ->
546 Ast.DesignatorIndex
(mcode lb
, expression exp
, mcode rb
)
547 | Ast0.DesignatorRange
(lb
,min
,dots,max
,rb
) ->
548 Ast.DesignatorRange
(mcode lb
,expression min
,mcode dots,expression max
,
551 (* --------------------------------------------------------------------- *)
554 and parameterTypeDef p
=
556 (match Ast0.unwrap p
with
557 Ast0.VoidParam
(ty) -> Ast.VoidParam
(typeC ty)
558 | Ast0.Param
(ty,id) -> Ast.Param
(typeC ty,get_option ident
id)
559 | Ast0.MetaParam
(name,_
) ->
560 Ast.MetaParam
(mcode name,unitary,false)
561 | Ast0.MetaParamList
(name,Some lenname
,_
) ->
562 Ast.MetaParamList
(mcode name,Some
(mcode lenname
,unitary,false),
564 | Ast0.MetaParamList
(name,None
,_
) ->
565 Ast.MetaParamList
(mcode name,None
,unitary,false)
566 | Ast0.PComma
(cm
) -> Ast.PComma
(mcode cm
)
567 | Ast0.Pdots
(dots) -> Ast.Pdots
(mcode dots)
568 | Ast0.Pcircles
(dots) -> Ast.Pcircles
(mcode dots)
569 | Ast0.OptParam
(param
) -> Ast.OptParam
(parameterTypeDef param
)
570 | Ast0.UniqueParam
(param
) -> Ast.UniqueParam
(parameterTypeDef param
))
572 and parameter_list l
= dots parameterTypeDef l
574 (* --------------------------------------------------------------------- *)
578 let rec statement seqible s
=
579 let rewrap_stmt ast0 ast
=
581 match Ast0.get_dots_bef_aft s
with
582 Ast0.NoDots
-> Ast.NoDots
583 | Ast0.DroppingBetweenDots s
->
584 Ast.DroppingBetweenDots
(statement seqible s
,get_ctr())
585 | Ast0.AddingBetweenDots s
->
586 Ast.AddingBetweenDots
(statement seqible s
,get_ctr()) in
587 Ast.set_dots_bef_aft
befaft (rewrap ast0
no_isos ast
) in
588 let rewrap_rule_elem ast0 ast
=
589 rewrap ast0
(do_isos (Ast0.get_iso ast0
)) ast
in
591 (match Ast0.unwrap s
with
592 Ast0.Decl
((_
,bef
),decl
) ->
593 Ast.Atomic
(rewrap_rule_elem s
594 (Ast.Decl
(convert_mcodekind bef
,
595 check_allminus.V0.combiner_statement s
,
597 | Ast0.Seq
(lbrace
,body
,rbrace
) ->
598 let lbrace = mcode lbrace in
599 let (decls
,body
) = separate_decls seqible body
in
600 let rbrace = mcode rbrace in
601 Ast.Seq
(iso_tokenwrap lbrace s
(Ast.SeqStart
(lbrace))
602 (do_isos (Ast0.get_iso s
)),
604 tokenwrap rbrace s
(Ast.SeqEnd
(rbrace)))
605 | Ast0.ExprStatement
(exp
,sem) ->
606 Ast.Atomic
(rewrap_rule_elem s
607 (Ast.ExprStatement
(expression exp
,mcode sem)))
608 | Ast0.IfThen
(iff
,lp,exp
,rp,branch
,(_
,aft
)) ->
611 (Ast.IfHeader
(mcode iff
,mcode lp,expression exp
,mcode rp)),
612 statement Ast.NotSequencible branch
,
613 ([],[],[],convert_mcodekind aft
))
614 | Ast0.IfThenElse
(iff
,lp,exp
,rp,branch1
,els
,branch2
,(_
,aft
)) ->
615 let els = mcode els in
618 (Ast.IfHeader
(mcode iff
,mcode lp,expression exp
,mcode rp)),
619 statement Ast.NotSequencible branch1
,
620 tokenwrap els s
(Ast.Else
(els)),
621 statement Ast.NotSequencible branch2
,
622 ([],[],[],convert_mcodekind aft
))
623 | Ast0.While
(wh
,lp,exp
,rp,body
,(_
,aft
)) ->
624 Ast.While
(rewrap_rule_elem s
626 (mcode wh
,mcode lp,expression exp
,mcode rp)),
627 statement Ast.NotSequencible body
,
628 ([],[],[],convert_mcodekind aft
))
629 | Ast0.Do
(d
,body
,wh
,lp,exp
,rp,sem) ->
631 Ast.Do
(rewrap_rule_elem s
(Ast.DoHeader
(mcode d
)),
632 statement Ast.NotSequencible body
,
634 (Ast.WhileTail
(wh,mcode lp,expression exp
,mcode rp,
636 | Ast0.For
(fr
,lp,exp1,sem1
,exp2,sem2
,exp3,rp,body
,(_
,aft
)) ->
639 let exp1 = get_option expression exp1 in
640 let sem1 = mcode sem1 in
641 let exp2 = get_option expression exp2 in
642 let sem2= mcode sem2 in
643 let exp3 = get_option expression exp3 in
645 let body = statement Ast.NotSequencible
body in
646 Ast.For
(rewrap_rule_elem s
647 (Ast.ForHeader
(fr,lp,exp1,sem1,exp2,sem2,exp3,rp)),
648 body,([],[],[],convert_mcodekind aft
))
649 | Ast0.Iterator
(nm
,lp,args,rp,body,(_
,aft
)) ->
650 Ast.Iterator
(rewrap_rule_elem s
653 dots expression args,
655 statement Ast.NotSequencible
body,
656 ([],[],[],convert_mcodekind aft
))
657 | Ast0.Switch
(switch
,lp,exp
,rp,lb
,cases
,rb
) ->
658 let switch = mcode switch in
660 let exp = expression exp in
663 let cases = List.map case_line
(Ast0.undots
cases) in
665 Ast.Switch
(rewrap_rule_elem s
(Ast.SwitchHeader
(switch,lp,exp,rp)),
666 tokenwrap lb s
(Ast.SeqStart
(lb)),
668 tokenwrap rb s
(Ast.SeqEnd
(rb)))
669 | Ast0.Break
(br
,sem) ->
670 Ast.Atomic
(rewrap_rule_elem s
(Ast.Break
(mcode br
,mcode sem)))
671 | Ast0.Continue
(cont
,sem) ->
672 Ast.Atomic
(rewrap_rule_elem s
(Ast.Continue
(mcode cont
,mcode sem)))
673 | Ast0.Label
(l
,dd
) ->
674 Ast.Atomic
(rewrap_rule_elem s
(Ast.Label
(ident l
,mcode dd
)))
675 | Ast0.Goto
(goto
,l
,sem) ->
677 (rewrap_rule_elem s
(Ast.Goto
(mcode goto
,ident l
,mcode sem)))
678 | Ast0.Return
(ret
,sem) ->
679 Ast.Atomic
(rewrap_rule_elem s
(Ast.Return
(mcode ret
,mcode sem)))
680 | Ast0.ReturnExpr
(ret
,exp,sem) ->
683 (Ast.ReturnExpr
(mcode ret
,expression exp,mcode sem)))
684 | Ast0.MetaStmt
(name,_
) ->
685 Ast.Atomic
(rewrap_rule_elem s
686 (Ast.MetaStmt
(mcode name,unitary,seqible
,false)))
687 | Ast0.MetaStmtList
(name,_
) ->
688 Ast.Atomic
(rewrap_rule_elem s
689 (Ast.MetaStmtList
(mcode name,unitary,false)))
690 | Ast0.TopExp
(exp) ->
691 Ast.Atomic
(rewrap_rule_elem s
(Ast.TopExp
(expression exp)))
693 Ast.Atomic
(rewrap_rule_elem s
(Ast.Exp
(expression exp)))
694 | Ast0.TopInit
(init
) ->
695 Ast.Atomic
(rewrap_rule_elem s
(Ast.TopInit
(initialiser init
)))
697 Ast.Atomic
(rewrap_rule_elem s
(Ast.Ty
(typeC ty)))
698 | Ast0.Disj
(_
,rule_elem_dots_list
,_
,_
) ->
699 Ast.Disj
(List.map
(function x
-> statement_dots seqible x
)
701 | Ast0.Nest
(_
,rule_elem_dots
,_
,whn
,multi
) ->
703 (statement_dots
Ast.Sequencible rule_elem_dots
,
705 (whencode (statement_dots
Ast.Sequencible
)
706 (statement Ast.NotSequencible
))
709 | Ast0.Dots
(d
,whn
) ->
713 (whencode (statement_dots
Ast.Sequencible
)
714 (statement Ast.NotSequencible
))
716 Ast.Dots
(d,whn,[],[])
717 | Ast0.Circles
(d,whn) ->
721 (whencode (statement_dots
Ast.Sequencible
)
722 (statement Ast.NotSequencible
))
724 Ast.Circles
(d,whn,[],[])
725 | Ast0.Stars
(d,whn) ->
729 (whencode (statement_dots
Ast.Sequencible
)
730 (statement Ast.NotSequencible
))
732 Ast.Stars
(d,whn,[],[])
733 | Ast0.FunDecl
((_
,bef
),fi
,name,lp,params
,rp,lbrace,body,rbrace) ->
734 let fi = List.map fninfo
fi in
735 let name = ident
name in
737 let params = parameter_list
params in
739 let lbrace = mcode lbrace in
740 let (decls
,body) = separate_decls seqible
body in
741 let rbrace = mcode rbrace in
742 let allminus = check_allminus.V0.combiner_statement s
in
743 Ast.FunDecl
(rewrap_rule_elem s
744 (Ast.FunHeader
(convert_mcodekind bef
,
745 allminus,fi,name,lp,params,rp)),
746 tokenwrap lbrace s
(Ast.SeqStart
(lbrace)),
748 tokenwrap rbrace s
(Ast.SeqEnd
(rbrace)))
749 | Ast0.Include
(inc
,str
) ->
750 Ast.Atomic
(rewrap_rule_elem s
(Ast.Include
(mcode inc
,mcode str
)))
751 | Ast0.Define
(def
,id,params,body) ->
755 (mcode def
,ident
id, define_parameters
params)),
756 statement_dots
Ast.NotSequencible
(*not sure*) body)
757 | Ast0.OptStm
(stm
) -> Ast.OptStm
(statement seqible stm
)
758 | Ast0.UniqueStm
(stm
) -> Ast.UniqueStm
(statement seqible stm
))
760 and define_parameters p
=
762 (match Ast0.unwrap p
with
763 Ast0.NoParams
-> Ast.NoParams
764 | Ast0.DParams
(lp,params,rp) ->
765 Ast.DParams
(mcode lp,
766 dots define_param
params,
771 (match Ast0.unwrap p
with
772 Ast0.DParam
(id) -> Ast.DParam
(ident
id)
773 | Ast0.DPComma
(comma
) -> Ast.DPComma
(mcode comma
)
774 | Ast0.DPdots
(d) -> Ast.DPdots
(mcode d)
775 | Ast0.DPcircles
(c) -> Ast.DPcircles
(mcode c)
776 | Ast0.OptDParam
(dp
) -> Ast.OptDParam
(define_param dp
)
777 | Ast0.UniqueDParam
(dp
) -> Ast.UniqueDParam
(define_param dp
))
779 and whencode notfn alwaysfn
= function
780 Ast0.WhenNot a
-> Ast.WhenNot
(notfn a
)
781 | Ast0.WhenAlways a
-> Ast.WhenAlways
(alwaysfn a
)
782 | Ast0.WhenModifier
(x
) -> Ast.WhenModifier
(x
)
784 let rewrap_rule_elem ast0 ast
=
785 rewrap ast0
(do_isos (Ast0.get_iso ast0
)) ast
in
787 Ast0.WhenNotTrue
(e
) ->
788 Ast.WhenNotTrue
(rewrap_rule_elem e
(Ast.Exp
(expression e
)))
789 | Ast0.WhenNotFalse
(e
) ->
790 Ast.WhenNotFalse
(rewrap_rule_elem e
(Ast.Exp
(expression e
)))
791 | _
-> failwith
"not possible"
793 and process_list seqible isos
= function
796 let first = statement seqible x
in
798 if !Flag.track_iso_usage
799 then Ast.set_isos
first (isos
@(Ast.get_isos
first))
801 (match Ast0.unwrap x
with
802 Ast0.Dots
(_
,_
) | Ast0.Nest
(_
) ->
803 first::(process_list
(Ast.SequencibleAfterDots
[]) no_isos rest
)
805 first::(process_list
Ast.Sequencible
no_isos rest
))
807 and statement_dots seqible
d =
808 let isos = do_isos (Ast0.get_iso
d) in
810 (match Ast0.unwrap
d with
811 Ast0.DOTS
(x
) -> Ast.DOTS
(process_list seqible
isos x
)
812 | Ast0.CIRCLES
(x
) -> Ast.CIRCLES
(process_list seqible
isos x
)
813 | Ast0.STARS
(x
) -> Ast.STARS
(process_list seqible
isos x
))
815 and separate_decls seqible
d =
816 let rec collect_decls = function
819 (match Ast0.unwrap x
with
821 let (decls
,other
) = collect_decls xs
in
823 | Ast0.Dots
(_
,_
) | Ast0.Nest
(_
,_
,_
,_
,_
) ->
824 let (decls
,other
) = collect_decls xs
in
827 | _
-> (x
:: decls
,other
))
828 | Ast0.Disj
(starter
,stmt_dots_list
,mids
,ender
) ->
829 let disjs = List.map collect_dot_decls stmt_dots_list
in
830 let all_decls = List.for_all
(function (_
,s
) -> s
=[]) disjs in
833 let (decls
,other
) = collect_decls xs
in
838 and collect_dot_decls
d =
839 match Ast0.unwrap
d with
840 Ast0.DOTS
(x
) -> collect_decls x
841 | Ast0.CIRCLES
(x
) -> collect_decls x
842 | Ast0.STARS
(x
) -> collect_decls x
in
845 let (decls
,other
) = collect_decls l
in
846 (rewrap d no_isos (fn (List.map
(statement seqible
) decls
)),
848 (fn (process_list seqible
(do_isos (Ast0.get_iso
d)) other
))) in
849 match Ast0.unwrap
d with
850 Ast0.DOTS
(x
) -> process x
d (function x
-> Ast.DOTS x
)
851 | Ast0.CIRCLES
(x
) -> process x
d (function x
-> Ast.CIRCLES x
)
852 | Ast0.STARS
(x
) -> process x
d (function x
-> Ast.STARS x
) in
854 statement Ast.Sequencible s
856 and fninfo
= function
857 Ast0.FStorage
(stg) -> Ast.FStorage
(mcode stg)
858 | Ast0.FType
(ty) -> Ast.FType
(typeC ty)
859 | Ast0.FInline
(inline
) -> Ast.FInline
(mcode inline
)
860 | Ast0.FAttr
(attr
) -> Ast.FAttr
(mcode attr
)
862 and option_to_list
= function
868 (match Ast0.unwrap
c with
869 Ast0.Default
(def
,colon,code
) ->
870 let def = mcode def in
871 let colon = mcode colon in
872 let code = dots statement code in
873 Ast.CaseLine
(rewrap c no_isos (Ast.Default
(def,colon)),code)
874 | Ast0.Case
(case
,exp,colon,code) ->
875 let case = mcode case in
876 let exp = expression exp in
877 let colon = mcode colon in
878 let code = dots statement code in
879 Ast.CaseLine
(rewrap c no_isos (Ast.Case
(case,exp,colon)),code)
880 | Ast0.OptCase
(case) -> Ast.OptCase
(case_line
case))
882 and statement_dots l
= dots statement l
884 (* --------------------------------------------------------------------- *)
886 (* what is possible is only what is at the top level in an iso *)
887 and anything
= function
888 Ast0.DotsExprTag
(d) -> Ast.ExprDotsTag
(expression_dots
d)
889 | Ast0.DotsParamTag
(d) -> Ast.ParamDotsTag
(parameter_list
d)
890 | Ast0.DotsInitTag
(d) -> failwith
"not possible"
891 | Ast0.DotsStmtTag
(d) -> Ast.StmtDotsTag
(statement_dots
d)
892 | Ast0.DotsDeclTag
(d) -> Ast.DeclDotsTag
(declaration_dots
d)
893 | Ast0.DotsCaseTag
(d) -> failwith
"not possible"
894 | Ast0.IdentTag
(d) -> Ast.IdentTag
(ident
d)
895 | Ast0.ExprTag
(d) -> Ast.ExpressionTag
(expression d)
896 | Ast0.ArgExprTag
(d) | Ast0.TestExprTag
(d) ->
897 failwith
"only in isos, not converted to ast"
898 | Ast0.TypeCTag
(d) -> Ast.FullTypeTag
(typeC d)
899 | Ast0.ParamTag
(d) -> Ast.ParamTag
(parameterTypeDef
d)
900 | Ast0.InitTag
(d) -> Ast.InitTag
(initialiser
d)
901 | Ast0.DeclTag
(d) -> Ast.DeclarationTag
(declaration d)
902 | Ast0.StmtTag
(d) -> Ast.StatementTag
(statement d)
903 | Ast0.CaseLineTag
(d) -> Ast.CaseLineTag
(case_line
d)
904 | Ast0.TopTag
(d) -> Ast.Code
(top_level
d)
905 | Ast0.IsoWhenTag
(_
) -> failwith
"not possible"
906 | Ast0.IsoWhenTTag
(_
) -> failwith
"not possible"
907 | Ast0.IsoWhenFTag
(_
) -> failwith
"not possible"
908 | Ast0.MetaPosTag _
-> failwith
"not possible"
910 (* --------------------------------------------------------------------- *)
911 (* Function declaration *)
912 (* top level isos are probably lost to tracking *)
916 (match Ast0.unwrap t
with
917 Ast0.FILEINFO
(old_file
,new_file
) ->
918 Ast.FILEINFO
(mcode old_file
,mcode new_file
)
919 | Ast0.DECL
(stmt
) -> Ast.DECL
(statement stmt
)
920 | Ast0.CODE
(rule_elem_dots
) ->
921 Ast.CODE
(statement_dots rule_elem_dots
)
922 | Ast0.ERRORWORDS
(exps
) -> Ast.ERRORWORDS
(List.map
expression exps
)
923 | Ast0.OTHER
(_
) -> failwith
"eliminated by top_level")
925 (* --------------------------------------------------------------------- *)
926 (* Entry point for minus code *)
928 (* Inline_mcodes is very important - sends + code attached to the - code
929 down to the mcodes. The functions above can only be used when there is no
930 attached + code, eg in + code itself. *)
931 let ast0toast_toplevel x
=
932 inline_mcodes.V0.combiner_top_level x
;
935 let ast0toast name deps dropped exists x is_exp ruletype
=
936 List.iter
inline_mcodes.V0.combiner_top_level x
;
938 (name,(deps
,dropped
,exists
),List.map top_level x
,is_exp
,ruletype
)