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 rule_elems, and on subterms if the context is ? also. *)
27 module Ast0
= Ast0_cocci
28 module Ast
= Ast_cocci
30 (* --------------------------------------------------------------------- *)
32 let warning s
= Printf.printf
"warning: %s\n" s
36 (Printf.sprintf
"cocci line %d: %s"
37 ((Ast0.get_info w
).Ast0.pos_info
.Ast0.line_start
)
40 let make_opt_unique optfn uniquefn info tgt arity term
=
41 let term = Ast0.rewrap info
term in
44 else (* tgt must be NONE *)
46 Ast0.OPT
-> Ast0.copywrap info
(optfn
term)
47 | Ast0.UNIQUE
-> Ast0.copywrap info
(uniquefn
term)
48 | Ast0.NONE
-> failwith
"tgt must be NONE"
50 let all_same opt_allowed tgt line arities
=
54 (match List.hd arities
with
55 Ast0.OPT
when not opt_allowed
->
56 failwith
"opt only allowed for the elements of a statement list"
59 if not
(List.for_all
(function x
-> x
= tgt) arities
)
60 then warning (Printf.sprintf
"incompatible arity found on line %d" line
);
63 let get_option fn
= function
65 | Some x
-> Some
(fn x
)
67 let anyopt l fn
= List.exists
(function w
-> fn
(Ast0.unwrap w
)) l
70 let rec loop = function
73 match fn
(Ast0.unwrap x
) with
74 Some x
-> x
:: (loop xs
)
77 if List.length
res = List.length l
then Some
res else None
79 (* --------------------------------------------------------------------- *)
80 (* --------------------------------------------------------------------- *)
83 let mcode2line (_
,_
,info
,_
,_
) = info
.Ast0.pos_info
.Ast0.line_start
84 let mcode2arity (_
,arity
,_
,_
,_
) = arity
86 let mcode x
= x
(* nothing to do ... *)
88 (* --------------------------------------------------------------------- *)
93 (match Ast0.unwrap d
with
94 Ast0.DOTS
(x
) -> Ast0.DOTS
(List.map fn x
)
95 | Ast0.CIRCLES
(x
) -> Ast0.CIRCLES
(List.map fn x
)
96 | Ast0.STARS
(x
) -> Ast0.STARS
(List.map fn x
))
102 match Ast0.unwrap x
with
103 Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> true
110 match Ast0.unwrap x
with
111 Ast0.Dots
(_
,_
) | Ast0.Stars
(_
,_
) -> true
118 match Ast0.unwrap x
with
119 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) -> true
123 let concat_dots fn d
=
125 (match Ast0.unwrap d
with
127 let l = List.map fn x
in
130 else fail d
"inconsistent dots usage"
132 let l = List.map fn x
in
135 else fail d
"inconsistent dots usage"
137 let l = List.map fn x
in
140 else fail d
"inconsistent dots usage")
142 let flat_concat_dots fn d
=
143 match Ast0.unwrap d
with
144 Ast0.DOTS
(x
) -> List.map fn x
145 | Ast0.CIRCLES
(x
) -> List.map fn x
146 | Ast0.STARS
(x
) -> List.map fn x
148 (* --------------------------------------------------------------------- *)
153 (function x
-> Ast0.OptIdent x
)
154 (function x
-> Ast0.UniqueIdent x
)
156 let ident opt_allowed
tgt i
=
157 match Ast0.unwrap i
with
160 all_same opt_allowed
tgt (mcode2line name
)
161 [mcode2arity name
] in
162 let name = mcode name in
163 make_id i
tgt arity (Ast0.Id
(name))
164 | Ast0.MetaId
(name,constraints
,pure
) ->
166 all_same opt_allowed
tgt (mcode2line name)
167 [mcode2arity name] in
168 let name = mcode name in
169 make_id i
tgt arity (Ast0.MetaId
(name,constraints
,pure
))
170 | Ast0.MetaFunc
(name,constraints
,pure
) ->
172 all_same opt_allowed
tgt (mcode2line name)
173 [mcode2arity name] in
174 let name = mcode name in
175 make_id i
tgt arity (Ast0.MetaFunc
(name,constraints
,pure
))
176 | Ast0.MetaLocalFunc
(name,constraints
,pure
) ->
178 all_same opt_allowed
tgt (mcode2line name)
179 [mcode2arity name] in
180 let name = mcode name in
181 make_id i
tgt arity (Ast0.MetaLocalFunc
(name,constraints
,pure
))
182 | Ast0.OptIdent
(_
) | Ast0.UniqueIdent
(_
) ->
183 failwith
"unexpected code"
185 (* --------------------------------------------------------------------- *)
190 (function x
-> Ast0.OptExp x
)
191 (function x
-> Ast0.UniqueExp x
)
193 let rec top_expression opt_allowed
tgt expr
=
194 let exp_same = all_same opt_allowed
tgt in
195 match Ast0.unwrap expr
with
197 let new_id = ident opt_allowed
tgt id
in
199 (match Ast0.unwrap
new_id with
201 Ast0.OptExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
202 | Ast0.UniqueIdent
(id
) ->
203 Ast0.UniqueExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
204 | _
-> Ast0.Ident
(new_id))
205 | Ast0.Constant
(const
) ->
206 let arity = exp_same (mcode2line const
) [mcode2arity const
] in
207 let const = mcode const in
208 make_exp expr
tgt arity (Ast0.Constant
(const))
209 | Ast0.FunCall
(fn
,lp
,args
,rp
) ->
210 let arity = exp_same (mcode2line lp
) [mcode2arity lp
;mcode2arity rp
] in
211 let fn = expression
arity fn in
213 let args = dots (expression
arity) args in
215 make_exp expr
tgt arity (Ast0.FunCall
(fn,lp,args,rp))
216 | Ast0.Assignment
(left
,op
,right
,simple
) ->
217 let arity = exp_same (mcode2line op
) [mcode2arity op
] in
218 let left = expression
arity left in
220 let right = expression
arity right in
221 make_exp expr
tgt arity (Ast0.Assignment
(left,op,right,simple
))
222 | Ast0.CondExpr
(exp1
,why
,exp2
,colon
,exp3
) ->
224 exp_same (mcode2line why
) [mcode2arity why
; mcode2arity colon
] in
225 let exp1 = expression
arity exp1 in
226 let why = mcode why in
227 let exp2 = get_option (expression
arity) exp2 in
228 let colon = mcode colon in
229 let exp3 = expression
arity exp3 in
230 make_exp expr
tgt arity (Ast0.CondExpr
(exp1,why,exp2,colon,exp3))
231 | Ast0.Postfix
(exp
,op) ->
232 let arity = exp_same (mcode2line op) [mcode2arity op] in
233 let exp = expression
arity exp in
235 make_exp expr
tgt arity (Ast0.Postfix
(exp,op))
236 | Ast0.Infix
(exp,op) ->
237 let arity = exp_same (mcode2line op) [mcode2arity op] in
238 let exp = expression
arity exp in
240 make_exp expr
tgt arity (Ast0.Infix
(exp,op))
241 | Ast0.Unary
(exp,op) ->
242 let arity = exp_same (mcode2line op) [mcode2arity op] in
243 let exp = expression
arity exp in
245 make_exp expr
tgt arity (Ast0.Unary
(exp,op))
246 | Ast0.Binary
(left,op,right) ->
247 let arity = exp_same (mcode2line op) [mcode2arity op] in
248 let left = expression
arity left in
250 let right = expression
arity right in
251 make_exp expr
tgt arity (Ast0.Binary
(left,op,right))
252 | Ast0.Nested
(left,op,right) -> failwith
"nested in arity not possible"
253 | Ast0.Paren
(lp,exp,rp) ->
254 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
256 let exp = expression
arity exp in
258 make_exp expr
tgt arity (Ast0.Paren
(lp,exp,rp))
259 | Ast0.ArrayAccess
(exp1,lb
,exp2,rb
) ->
260 let arity = exp_same (mcode2line lb
) [mcode2arity lb
; mcode2arity rb
] in
261 let exp1 = expression
arity exp1 in
263 let exp2 = expression
arity exp2 in
265 make_exp expr
tgt arity (Ast0.ArrayAccess
(exp1,lb,exp2,rb))
266 | Ast0.RecordAccess
(exp,pt
,field
) ->
267 let arity = exp_same (mcode2line pt
) [mcode2arity pt
] in
268 let exp = expression
arity exp in
270 let field = ident false arity field in
271 make_exp expr
tgt arity (Ast0.RecordAccess
(exp,pt,field))
272 | Ast0.RecordPtAccess
(exp,ar
,field) ->
273 let arity = exp_same (mcode2line ar
) [mcode2arity ar
] in
274 let exp = expression
arity exp in
276 let field = ident false arity field in
277 make_exp expr
tgt arity (Ast0.RecordPtAccess
(exp,ar,field))
278 | Ast0.Cast
(lp,ty
,rp,exp) ->
279 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
281 let ty = typeC
arity ty in
283 let exp = expression
arity exp in
284 make_exp expr
tgt arity (Ast0.Cast
(lp,ty,rp,exp))
285 | Ast0.SizeOfExpr
(szf
,exp) ->
286 let arity = exp_same (mcode2line szf
) [mcode2arity szf
] in
287 let szf = mcode szf in
288 let exp = expression
arity exp in
289 make_exp expr
tgt arity (Ast0.SizeOfExpr
(szf,exp))
290 | Ast0.SizeOfType
(szf,lp,ty,rp) ->
292 exp_same (mcode2line szf) (List.map
mcode2arity [szf;lp;rp]) in
293 let szf = mcode szf in
295 let ty = typeC
arity ty in
297 make_exp expr
tgt arity (Ast0.SizeOfType
(szf,lp,ty,rp))
298 | Ast0.TypeExp
(ty) -> Ast0.rewrap expr
(Ast0.TypeExp
(typeC
tgt ty))
299 | Ast0.MetaErr
(name,constraints
,pure
) ->
300 let arity = exp_same (mcode2line name) [mcode2arity name] in
301 let name = mcode name in
302 make_exp expr
tgt arity (Ast0.MetaErr
(name,constraints
,pure
))
303 | Ast0.MetaExpr
(name,constraints
,ty,form
,pure
) ->
304 let arity = exp_same (mcode2line name) [mcode2arity name] in
305 let name = mcode name in
306 make_exp expr
tgt arity (Ast0.MetaExpr
(name,constraints
,ty,form
,pure
))
307 | Ast0.MetaExprList
(name,lenname
,pure
) ->
308 let arity = exp_same (mcode2line name) [mcode2arity name] in
309 let name = mcode name in
310 make_exp expr
tgt arity (Ast0.MetaExprList
(name,lenname
,pure
))
312 let arity = exp_same (mcode2line cm
) [mcode2arity cm
] in
314 make_exp expr
tgt arity (Ast0.EComma
(cm))
315 | Ast0.DisjExpr
(starter
,exps
,mids
,ender
) ->
316 let exps = List.map
(top_expression opt_allowed
tgt) exps in
317 (match List.rev
exps with
319 if anyopt xs
(function Ast0.OptExp
(_
) -> true | _
-> false)
320 then fail expr
"opt only allowed in the last disjunct"
322 Ast0.rewrap expr
(Ast0.DisjExpr
(starter
,exps,mids
,ender
))
323 | Ast0.NestExpr
(starter
,exp_dots
,ender
,whencode
,multi
) ->
325 Ast0.NestExpr
(starter
,
326 dots (top_expression true Ast0.NONE
) exp_dots
,
327 ender
,whencode
,multi
) in
329 | Ast0.Edots
(dots,whencode
) ->
330 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
331 let dots = mcode dots in
332 let whencode = get_option (expression
Ast0.NONE
) whencode in
333 make_exp expr
tgt arity (Ast0.Edots
(dots,whencode))
334 | Ast0.Ecircles
(dots,whencode) ->
335 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
336 let dots = mcode dots in
337 let whencode = get_option (expression
Ast0.NONE
) whencode in
338 make_exp expr
tgt arity (Ast0.Ecircles
(dots,whencode))
339 | Ast0.Estars
(dots,whencode) ->
340 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
341 let dots = mcode dots in
342 let whencode = get_option (expression
Ast0.NONE
) whencode in
343 make_exp expr
tgt arity (Ast0.Estars
(dots,whencode))
344 | Ast0.OptExp
(_
) | Ast0.UniqueExp
(_
) ->
345 failwith
"unexpected code"
347 and expression
tgt exp = top_expression false tgt exp
349 (* --------------------------------------------------------------------- *)
354 (function x
-> Ast0.OptType x
)
355 (function x
-> Ast0.UniqueType x
)
357 and top_typeC
tgt opt_allowed typ
=
358 match Ast0.unwrap typ
with
359 Ast0.ConstVol
(cv
,ty) ->
360 let arity = all_same opt_allowed
tgt (mcode2line cv
)
363 let ty = typeC
arity ty in
364 make_typeC typ
tgt arity (Ast0.ConstVol
(cv,ty))
365 | Ast0.BaseType
(ty,strings
) ->
367 all_same opt_allowed
tgt (mcode2line (List.hd strings
))
368 (List.map
mcode2arity strings
) in
369 let strings = List.map
mcode strings in
370 make_typeC typ
tgt arity (Ast0.BaseType
(ty,strings))
371 | Ast0.Signed
(sign
,ty) ->
373 all_same opt_allowed
tgt (mcode2line sign
) [mcode2arity sign
] in
374 let sign = mcode sign in
375 let ty = get_option (typeC
arity) ty in
376 make_typeC typ
tgt arity (Ast0.Signed
(sign,ty))
377 | Ast0.Pointer
(ty,star
) ->
379 all_same opt_allowed
tgt (mcode2line star
) [mcode2arity star
] in
380 let ty = typeC
arity ty in
381 let star = mcode star in
382 make_typeC typ
tgt arity (Ast0.Pointer
(ty,star))
383 | Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params
,rp2
) ->
385 all_same opt_allowed
tgt (mcode2line lp1
)
386 (List.map
mcode2arity [lp1
;star;rp1
;lp2
;rp2
]) in
387 let ty = typeC
arity ty in
388 let params = parameter_list
tgt params in
389 make_typeC typ
tgt arity
390 (Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params,rp2
))
391 | Ast0.FunctionType
(ty,lp1
,params,rp1
) ->
393 all_same opt_allowed
tgt (mcode2line lp1
)
394 (List.map
mcode2arity [lp1
;rp1
]) in
395 let ty = get_option (typeC
arity) ty in
396 let params = parameter_list
tgt params in
397 make_typeC typ
tgt arity (Ast0.FunctionType
(ty,lp1
,params,rp1
))
398 | Ast0.Array
(ty,lb,size
,rb) ->
400 all_same opt_allowed
tgt (mcode2line lb)
401 [mcode2arity lb;mcode2arity rb] in
402 let ty = typeC
arity ty in
404 let size = get_option (expression
arity) size in
406 make_typeC typ
tgt arity (Ast0.Array
(ty,lb,size,rb))
407 | Ast0.EnumName
(kind
,name) ->
409 all_same opt_allowed
tgt (mcode2line kind
) [mcode2arity kind
] in
410 let kind = mcode kind in
411 let name = ident false arity name in
412 make_typeC typ
tgt arity (Ast0.EnumName
(kind,name))
413 | Ast0.StructUnionName
(kind,name) ->
415 all_same opt_allowed
tgt (mcode2line kind)
416 [mcode2arity kind] in
417 let kind = mcode kind in
418 let name = get_option (ident false arity) name in
419 make_typeC typ
tgt arity (Ast0.StructUnionName
(kind,name))
420 | Ast0.StructUnionDef
(ty,lb,decls
,rb) ->
422 all_same opt_allowed
tgt (mcode2line lb)
423 (List.map
mcode2arity [lb;rb]) in
424 let ty = typeC
arity ty in
426 let decls = dots (declaration
tgt) decls in
428 make_typeC typ
tgt arity (Ast0.StructUnionDef
(ty,lb,decls,rb))
429 | Ast0.TypeName
(name) ->
431 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
432 let name = mcode name in
433 make_typeC typ
tgt arity (Ast0.TypeName
(name))
434 | Ast0.MetaType
(name,pure
) ->
436 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
437 let name = mcode name in
438 make_typeC typ
tgt arity (Ast0.MetaType
(name,pure
))
439 | Ast0.DisjType
(starter
,types
,mids
,ender
) ->
440 let types = List.map
(typeC
tgt) types in
441 (match List.rev
types with
443 if anyopt xs
(function Ast0.OptType
(_
) -> true | _
-> false)
444 then fail typ
"opt only allowed in the last disjunct"
446 let res = Ast0.DisjType
(starter
,types,mids
,ender
) in
448 | Ast0.OptType
(_
) | Ast0.UniqueType
(_
) ->
449 failwith
"unexpected code"
451 and typeC
tgt ty = top_typeC
tgt false ty
453 (* --------------------------------------------------------------------- *)
454 (* Variable declaration *)
455 (* Even if the Cocci program specifies a list of declarations, they are
456 split out into multiple declarations of a single variable each. *)
460 (function x
-> Ast0.OptDecl x
)
461 (function x
-> Ast0.UniqueDecl x
)
463 and declaration
tgt decl
=
464 match Ast0.unwrap decl
with
465 Ast0.Init
(stg
,ty,id
,eq
,exp,sem
) ->
467 all_same true tgt (mcode2line eq
)
468 ((match stg
with None
-> [] | Some x
-> [mcode2arity x
]) @
469 (List.map
mcode2arity [eq
;sem
])) in
470 let stg = get_option mcode stg in
471 let ty = typeC
arity ty in
472 let id = ident false arity id in
474 let exp = initialiser
arity exp in
475 let sem = mcode sem in
476 make_decl decl
tgt arity (Ast0.Init
(stg,ty,id,eq,exp,sem))
477 | Ast0.UnInit
(stg,ty,id,sem) ->
479 all_same true tgt (mcode2line sem)
480 ((match stg with None
-> [] | Some x
-> [mcode2arity x
]) @
481 [mcode2arity sem]) in
482 let stg = get_option mcode stg in
483 let ty = typeC
arity ty in
484 let id = ident false arity id in
485 let sem = mcode sem in
486 make_decl decl
tgt arity (Ast0.UnInit
(stg,ty,id,sem))
487 | Ast0.MacroDecl
(name,lp,args,rp,sem) ->
489 all_same true tgt (mcode2line lp) (List.map
mcode2arity [lp;rp;sem]) in
490 let name = ident false arity name in
492 let args = dots (expression
arity) args in
494 let sem = mcode sem in
495 make_decl decl
tgt arity (Ast0.MacroDecl
(name,lp,args,rp,sem))
496 | Ast0.TyDecl
(ty,sem) ->
498 all_same true tgt (mcode2line sem) [mcode2arity sem] in
499 let ty = typeC
arity ty in
500 let sem = mcode sem in
501 make_decl decl
tgt arity (Ast0.TyDecl
(ty,sem))
502 | Ast0.Typedef
(stg,ty,id,sem) ->
504 all_same true tgt (mcode2line sem)
505 [mcode2arity stg;mcode2arity sem] in
506 let stg = mcode stg in
507 let ty = typeC
arity ty in
508 let id = typeC
arity id in
509 let sem = mcode sem in
510 make_decl decl
tgt arity (Ast0.Typedef
(stg,ty,id,sem))
511 | Ast0.DisjDecl
(starter
,decls,mids
,ender
) ->
512 let decls = List.map
(declaration
tgt) decls in
513 (match List.rev
decls with
515 if anyopt xs
(function Ast0.OptDecl
(_
) -> true | _
-> false)
516 then fail decl
"opt only allowed in the last disjunct"
518 let res = Ast0.DisjDecl
(starter
,decls,mids
,ender
) in
520 | Ast0.Ddots
(dots,whencode) ->
521 let arity = all_same true tgt (mcode2line dots) [mcode2arity dots] in
522 let dots = mcode dots in
523 let whencode = get_option (declaration
Ast0.NONE
) whencode in
524 make_decl decl
tgt arity (Ast0.Ddots
(dots,whencode))
525 | Ast0.OptDecl
(_
) | Ast0.UniqueDecl
(_
) ->
526 failwith
"unexpected code"
528 (* --------------------------------------------------------------------- *)
533 (function x
-> Ast0.OptIni x
)
534 (function x
-> Ast0.UniqueIni x
)
536 and initialiser
tgt i
=
537 let init_same = all_same true tgt in
538 match Ast0.unwrap i
with
539 Ast0.MetaInit
(name,pure
) ->
540 let arity = init_same (mcode2line name) [mcode2arity name] in
541 let name = mcode name in
542 make_init i
tgt arity (Ast0.MetaInit
(name,pure
))
543 | Ast0.InitExpr
(exp) ->
544 Ast0.rewrap i
(Ast0.InitExpr
(expression
tgt exp))
545 | Ast0.InitList
(lb,initlist
,rb) ->
546 let arity = init_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
548 let initlist = dots (initialiser
arity) initlist in
550 make_init i
tgt arity (Ast0.InitList
(lb,initlist,rb))
551 | Ast0.InitGccExt
(designators
,eq,ini
) ->
552 let arity = init_same (mcode2line eq) [mcode2arity eq] in
553 let designators = List.map
(designator
arity) designators in
555 let ini = initialiser
arity ini in
556 make_init i
tgt arity (Ast0.InitGccExt
(designators,eq,ini))
557 | Ast0.InitGccName
(name,eq,ini) ->
558 let arity = init_same (mcode2line eq) [mcode2arity eq] in
559 let name = ident true arity name in
561 let ini = initialiser
arity ini in
562 make_init i
tgt arity (Ast0.InitGccName
(name,eq,ini))
564 let arity = init_same (mcode2line cm) [mcode2arity cm] in
566 make_init i
tgt arity (Ast0.IComma
(cm))
567 | Ast0.Idots
(dots,whencode) ->
568 let arity = init_same (mcode2line dots) [mcode2arity dots] in
569 let dots = mcode dots in
570 let whencode = get_option (initialiser
Ast0.NONE
) whencode in
571 make_init i
tgt arity (Ast0.Idots
(dots,whencode))
572 | Ast0.OptIni
(_
) | Ast0.UniqueIni
(_
) ->
573 failwith
"unexpected code"
575 and designator
tgt d
=
576 let dsame = all_same false tgt in
578 Ast0.DesignatorField
(dot
,id) ->
579 let arity = dsame (mcode2line dot
) [mcode2arity dot
] in
580 let dot = mcode dot in
581 let id = ident false arity id in
582 Ast0.DesignatorField
(dot,id)
583 | Ast0.DesignatorIndex
(lb,exp,rb) ->
584 let arity = dsame (mcode2line lb) [mcode2arity lb;mcode2arity rb] in
586 let exp = top_expression false arity exp in
588 Ast0.DesignatorIndex
(lb,exp,rb)
589 | Ast0.DesignatorRange
(lb,min
,dots,max
,rb) ->
591 dsame (mcode2line lb)
592 [mcode2arity lb;mcode2arity dots;mcode2arity rb] in
594 let min = top_expression false arity min in
595 let dots = mcode dots in
596 let max = top_expression false arity max in
598 Ast0.DesignatorRange
(lb,min,dots,max,rb)
600 (* --------------------------------------------------------------------- *)
605 (function x
-> Ast0.OptParam x
)
606 (function x
-> Ast0.UniqueParam x
)
608 and parameterTypeDef
tgt param
=
609 let param_same = all_same true tgt in
610 match Ast0.unwrap param
with
611 Ast0.VoidParam
(ty) -> Ast0.rewrap param
(Ast0.VoidParam
(typeC
tgt ty))
612 | Ast0.Param
(ty,Some
id) ->
613 let ty = top_typeC
tgt true ty in
614 let id = ident true tgt id in
616 (match (Ast0.unwrap
ty,Ast0.unwrap
id) with
617 (Ast0.OptType
(ty),Ast0.OptIdent
(id)) ->
618 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
619 | (Ast0.UniqueType
(ty),Ast0.UniqueIdent
(id)) ->
620 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
621 | (Ast0.OptType
(ty),_
) ->
622 fail param
"arity mismatch in param declaration"
623 | (_
,Ast0.OptIdent
(id)) ->
624 fail param
"arity mismatch in param declaration"
625 | _
-> Ast0.Param
(ty,Some
id))
626 | Ast0.Param
(ty,None
) ->
627 let ty = top_typeC
tgt true ty in
629 (match Ast0.unwrap
ty with
631 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
632 | Ast0.UniqueType
(ty) ->
633 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
634 | _
-> Ast0.Param
(ty,None
))
635 | Ast0.MetaParam
(name,pure
) ->
636 let arity = param_same (mcode2line name) [mcode2arity name] in
637 let name = mcode name in
638 make_param param
tgt arity (Ast0.MetaParam
(name,pure
))
639 | Ast0.MetaParamList
(name,lenname
,pure
) ->
640 let arity = param_same (mcode2line name) [mcode2arity name] in
641 let name = mcode name in
642 make_param param
tgt arity (Ast0.MetaParamList
(name,lenname
,pure
))
644 let arity = param_same (mcode2line cm) [mcode2arity cm] in
646 make_param param
tgt arity (Ast0.PComma
(cm))
647 | Ast0.Pdots
(dots) ->
648 let arity = param_same (mcode2line dots) [mcode2arity dots] in
649 let dots = mcode dots in
650 make_param param
tgt arity (Ast0.Pdots
(dots))
651 | Ast0.Pcircles
(dots) ->
652 let arity = param_same (mcode2line dots) [mcode2arity dots] in
653 let dots = mcode dots in
654 make_param param
tgt arity (Ast0.Pcircles
(dots))
655 | Ast0.OptParam
(_
) | Ast0.UniqueParam
(_
) ->
656 failwith
"unexpected code"
658 and parameter_list
tgt = dots (parameterTypeDef
tgt)
660 (* --------------------------------------------------------------------- *)
663 and make_rule_elem x
=
665 (function x
-> Ast0.OptStm x
)
666 (function x
-> Ast0.UniqueStm x
)
669 and statement
tgt stm
=
670 let stm_same = all_same true tgt in
671 match Ast0.unwrap stm
with
672 Ast0.Decl
(bef
,decl
) ->
673 let new_decl = declaration
tgt decl
in
675 (match Ast0.unwrap
new_decl with
676 Ast0.OptDecl
(decl
) ->
677 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
678 | Ast0.UniqueDecl
(decl
) ->
679 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
680 | _
-> Ast0.Decl
(bef
,new_decl))
681 | Ast0.Seq
(lbrace
,body
,rbrace
) ->
683 stm_same (mcode2line lbrace
)
684 [mcode2arity lbrace
; mcode2arity rbrace
] in
685 let lbrace = mcode lbrace in
686 let body = dots (statement
arity) body in
687 let rbrace = mcode rbrace in
688 make_rule_elem stm
tgt arity (Ast0.Seq
(lbrace,body,rbrace))
689 | Ast0.ExprStatement
(exp,sem) ->
690 let arity = stm_same (mcode2line sem) [mcode2arity sem] in
691 let exp = expression
arity exp in
692 let sem = mcode sem in
693 make_rule_elem stm
tgt arity (Ast0.ExprStatement
(exp,sem))
694 | Ast0.IfThen
(iff
,lp,exp,rp,branch
,aft
) ->
696 stm_same (mcode2line iff
) (List.map
mcode2arity [iff
;lp;rp]) in
697 let iff = mcode iff in
699 let exp = expression
arity exp in
701 let branch = statement
arity branch in
702 make_rule_elem stm
tgt arity (Ast0.IfThen
(iff,lp,exp,rp,branch,aft
))
703 | Ast0.IfThenElse
(iff,lp,exp,rp,branch1
,els
,branch2
,aft
) ->
705 stm_same (mcode2line iff) (List.map
mcode2arity [iff;lp;rp;els
]) in
706 let iff = mcode iff in
708 let exp = expression
arity exp in
710 let branch1 = statement
arity branch1 in
711 let els = mcode els in
712 let branch2 = statement
arity branch2 in
713 make_rule_elem stm
tgt arity
714 (Ast0.IfThenElse
(iff,lp,exp,rp,branch1,els,branch2,aft
))
715 | Ast0.While
(wh
,lp,exp,rp,body,aft
) ->
717 stm_same (mcode2line wh
)
718 (List.map
mcode2arity [wh
;lp;rp]) in
721 let exp = expression
arity exp in
723 let body = statement
arity body in
724 make_rule_elem stm
tgt arity (Ast0.While
(wh,lp,exp,rp,body,aft
))
725 | Ast0.Do
(d
,body,wh,lp,exp,rp,sem) ->
727 stm_same (mcode2line wh) (List.map
mcode2arity [d
;wh;lp;rp;sem]) in
729 let body = statement
arity body in
732 let exp = expression
arity exp in
734 let sem = mcode sem in
735 make_rule_elem stm
tgt arity (Ast0.Do
(d,body,wh,lp,exp,rp,sem))
736 | Ast0.For
(fr
,lp,exp1,sem1
,exp2,sem2
,exp3,rp,body,aft
) ->
738 stm_same (mcode2line fr
) (List.map
mcode2arity [fr
;lp;sem1
;sem2
;rp]) in
741 let exp1 = get_option (expression
arity) exp1 in
742 let sem1 = mcode sem1 in
743 let exp2 = get_option (expression
arity) exp2 in
744 let sem2= mcode sem2 in
745 let exp3 = get_option (expression
arity) exp3 in
747 let body = statement
arity body in
748 make_rule_elem stm
tgt arity
749 (Ast0.For
(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft
))
750 | Ast0.Iterator
(nm
,lp,args,rp,body,aft
) ->
751 let arity = stm_same (mcode2line lp) (List.map
mcode2arity [lp;rp]) in
752 let nm = ident false arity nm in
754 let args = dots (expression
arity) args in
756 let body = statement
arity body in
757 make_rule_elem stm
tgt arity (Ast0.Iterator
(nm,lp,args,rp,body,aft
))
758 | Ast0.Switch
(switch
,lp,exp,rp,lb,cases
,rb) ->
760 stm_same (mcode2line switch
)
761 (List.map
mcode2arity [switch
;lp;rp;lb;rb]) in
762 let switch = mcode switch in
764 let exp = expression
arity exp in
767 let cases = dots (case_line
arity) cases in
769 make_rule_elem stm
tgt arity
770 (Ast0.Switch
(switch,lp,exp,rp,lb,cases,rb))
771 | Ast0.Break
(br
,sem) ->
772 let arity = stm_same (mcode2line br
) (List.map
mcode2arity [br
;sem]) in
774 let sem = mcode sem in
775 make_rule_elem stm
tgt arity (Ast0.Break
(br,sem))
776 | Ast0.Continue
(cont
,sem) ->
778 stm_same (mcode2line cont
) (List.map
mcode2arity [cont
;sem]) in
779 let cont = mcode cont in
780 let sem = mcode sem in
781 make_rule_elem stm
tgt arity (Ast0.Continue
(cont,sem))
782 | Ast0.Label
(l,dd
) ->
783 let arity = mcode2arity dd
in
784 let l = ident false tgt l in
786 make_rule_elem stm
tgt arity (Ast0.Label
(l,dd))
787 | Ast0.Goto
(goto
,l,sem) ->
789 stm_same (mcode2line goto
) (List.map
mcode2arity [goto
;sem]) in
790 let goto = mcode goto in
791 let l = ident false tgt l in
792 let sem = mcode sem in
793 make_rule_elem stm
tgt arity (Ast0.Goto
(goto,l,sem))
794 | Ast0.Return
(ret
,sem) ->
795 let arity = stm_same (mcode2line ret
) (List.map
mcode2arity [ret
;sem]) in
796 let ret = mcode ret in
797 let sem = mcode sem in
798 make_rule_elem stm
tgt arity (Ast0.Return
(ret,sem))
799 | Ast0.ReturnExpr
(ret,exp,sem) ->
800 let arity = stm_same (mcode2line ret) (List.map
mcode2arity [ret;sem]) in
801 let ret = mcode ret in
802 let exp = expression
arity exp in
803 let sem = mcode sem in
804 make_rule_elem stm
tgt arity (Ast0.ReturnExpr
(ret,exp,sem))
805 | Ast0.MetaStmt
(name,pure
) ->
806 let arity = stm_same (mcode2line name) [mcode2arity name] in
807 let name = mcode name in
808 make_rule_elem stm
tgt arity (Ast0.MetaStmt
(name,pure
))
809 | Ast0.MetaStmtList
(name,pure
) ->
810 let arity = stm_same (mcode2line name) [mcode2arity name] in
811 let name = mcode name in
812 make_rule_elem stm
tgt arity (Ast0.MetaStmtList
(name,pure
))
814 let new_exp = top_expression true tgt exp in
816 (match Ast0.unwrap
new_exp with
818 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
819 | Ast0.UniqueExp
(exp) ->
820 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
821 | _
-> Ast0.Exp
(new_exp))
822 | Ast0.TopExp
(exp) ->
823 let new_exp = top_expression true tgt exp in
825 (match Ast0.unwrap
new_exp with
827 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
828 | Ast0.UniqueExp
(exp) ->
829 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
830 | _
-> Ast0.TopExp
(new_exp))
832 let new_ty = typeC
tgt ty in (* opt makes no sense alone at top level *)
834 (match Ast0.unwrap
new_ty with
836 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
837 | Ast0.UniqueType
(ty) ->
838 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
839 | _
-> Ast0.Ty
(new_ty))
840 | Ast0.TopInit
(init
) ->
841 let new_init = initialiser
tgt init
in
843 (match Ast0.unwrap
new_init with
845 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopInit
(init
)))
846 | Ast0.UniqueIni
(init
) ->
847 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopInit
(init
)))
848 | _
-> Ast0.TopInit
(new_init))
849 | Ast0.Disj
(starter
,rule_elem_dots_list
,mids
,ender
) ->
851 List.map
(function x
-> concat_dots (statement
tgt) x
)
852 rule_elem_dots_list
in
853 let (found_opt
,unopt
) =
855 (function (found_opt
,lines
) ->
858 (* previously just checked the last thing in the list,
859 but everything should be optional for the whole thing to
862 match Ast0.unwrap x
with
863 Ast0.OptStm
(x
) -> true
866 match Ast0.unwrap x
with
869 if List.for_all
is_opt l
870 then (true,List.map
unopt l)
873 match Ast0.unwrap x
with
875 (l,function l -> Ast0.rewrap x
(Ast0.DOTS
l))
877 (l,function l -> Ast0.rewrap x
(Ast0.CIRCLES
l))
879 (l,function l -> Ast0.rewrap x
(Ast0.STARS
l)) in
880 let (found_opt
,l) = rebuild l in
881 (found_opt
,(k
l)::lines
))
883 let unopt = List.rev
unopt in
886 make_rule_elem stm
tgt Ast0.OPT
(Ast0.Disj
(starter
,unopt,mids
,ender
))
887 else Ast0.rewrap stm
(Ast0.Disj
(starter
,stms,mids
,ender
))
888 | Ast0.Nest
(starter
,rule_elem_dots
,ender
,whn
,multi
) ->
889 let new_rule_elem_dots =
890 concat_dots (statement
Ast0.NONE
) rule_elem_dots
in
893 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
894 (expression
Ast0.NONE
))
897 (Ast0.Nest
(starter
,new_rule_elem_dots,ender
,whn,multi
))
898 | Ast0.Dots
(dots,whn) ->
899 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
900 let dots = mcode dots in
903 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
904 (expression
Ast0.NONE
))
906 make_rule_elem stm
tgt arity (Ast0.Dots
(dots,whn))
907 | Ast0.Circles
(dots,whn) ->
908 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
909 let dots = mcode dots in
912 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
913 (expression
Ast0.NONE
))
915 make_rule_elem stm
tgt arity (Ast0.Circles
(dots,whn))
916 | Ast0.Stars
(dots,whn) ->
917 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
918 let dots = mcode dots in
921 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
922 (expression
Ast0.NONE
))
924 make_rule_elem stm
tgt arity (Ast0.Stars
(dots,whn))
925 | Ast0.FunDecl
(bef
,fi
,name,lp,params,rp,lbrace,body,rbrace) ->
927 all_same true tgt (mcode2line lp)
928 ((List.map
mcode2arity [lp;rp;lbrace;rbrace]) @ (fninfo2arity fi
)) in
929 let fi = List.map
(fninfo
arity) fi in
930 let name = ident false arity name in
932 let params = parameter_list
arity params in
934 let lbrace = mcode lbrace in
935 let body = dots (statement
arity) body in
936 let rbrace = mcode rbrace in
937 make_rule_elem stm
tgt arity
938 (Ast0.FunDecl
(bef
,fi,name,lp,params,rp,lbrace,body,rbrace))
939 | Ast0.Include
(inc
,s
) ->
941 all_same true tgt (mcode2line inc
) [mcode2arity inc
; mcode2arity s
] in
942 let inc = mcode inc in
944 make_rule_elem stm
tgt arity (Ast0.Include
(inc,s))
945 | Ast0.Define
(def
,id,params,body) ->
946 let arity = all_same true tgt (mcode2line def
) [mcode2arity def
] in
947 let def = mcode def in
948 let id = ident false arity id in
949 let params = define_parameters
arity params in
950 let body = dots (statement
arity) body in
951 make_rule_elem stm
tgt arity (Ast0.Define
(def,id,params,body))
952 | Ast0.OptStm
(_
) | Ast0.UniqueStm
(_
) ->
953 failwith
"unexpected code"
955 and define_parameters
tgt params =
956 match Ast0.unwrap
params with
957 Ast0.NoParams
-> params
958 | Ast0.DParams
(lp,params,rp) ->
960 all_same true tgt (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
962 let params = dots (define_param
arity) params in
964 Ast0.rewrap
params (Ast0.DParams
(lp,params,rp))
966 and make_define_param x
=
968 (function x
-> Ast0.OptDParam x
)
969 (function x
-> Ast0.UniqueDParam x
)
972 and define_param
tgt param
=
973 match Ast0.unwrap param
with
975 let new_id = ident true tgt id in
977 (match Ast0.unwrap
new_id with
979 Ast0.OptDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
980 | Ast0.UniqueIdent
(decl
) ->
981 Ast0.UniqueDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
982 | _
-> Ast0.DParam
(new_id))
983 | Ast0.DPComma
(cm) ->
985 all_same true tgt (mcode2line cm) [mcode2arity cm] in
987 make_define_param param
tgt arity (Ast0.DPComma
(cm))
988 | Ast0.DPdots
(dots) ->
990 all_same true tgt (mcode2line dots) [mcode2arity dots] in
991 let dots = mcode dots in
992 make_define_param param
tgt arity (Ast0.DPdots
(dots))
993 | Ast0.DPcircles
(circles
) ->
995 all_same true tgt (mcode2line circles
) [mcode2arity circles
] in
996 let circles = mcode circles in
997 make_define_param param
tgt arity (Ast0.DPcircles
(circles))
998 | Ast0.OptDParam
(dp
) | Ast0.UniqueDParam
(dp
) ->
999 failwith
"unexpected code"
1001 and fninfo
arity = function
1002 Ast0.FStorage
(stg) -> Ast0.FStorage
(mcode stg)
1003 | Ast0.FType
(ty) -> Ast0.FType
(typeC
arity ty)
1004 | Ast0.FInline
(inline
) -> Ast0.FInline
(mcode inline
)
1005 | Ast0.FAttr
(attr
) -> Ast0.FAttr
(mcode attr
)
1007 and fninfo2arity fninfo
=
1011 Ast0.FStorage
(stg) -> [mcode2arity stg]
1012 | Ast0.FType
(ty) -> []
1013 | Ast0.FInline
(inline
) -> [mcode2arity inline
]
1014 | Ast0.FAttr
(attr
) -> [mcode2arity attr
])
1017 and whencode notfn alwaysfn expression
= function
1018 Ast0.WhenNot a
-> Ast0.WhenNot
(notfn a
)
1019 | Ast0.WhenAlways a
-> Ast0.WhenAlways
(alwaysfn a
)
1020 | Ast0.WhenModifier
(x
) -> Ast0.WhenModifier
(x
)
1021 | Ast0.WhenNotTrue a
-> Ast0.WhenNotTrue
(expression a
)
1022 | Ast0.WhenNotFalse a
-> Ast0.WhenNotFalse
(expression a
)
1024 and make_case_line
=
1026 (function x
-> Ast0.OptCase x
)
1027 (function x
-> failwith
"unique not allowed for case_line")
1029 and case_line
tgt c
=
1030 match Ast0.unwrap c
with
1031 Ast0.Default
(def,colon,code
) ->
1033 all_same true tgt (mcode2line def)
1034 [mcode2arity def; mcode2arity colon] in
1035 let def = mcode def in
1036 let colon = mcode colon in
1037 let code = dots (statement
arity) code in
1038 make_case_line c
tgt arity (Ast0.Default
(def,colon,code))
1039 | Ast0.Case
(case
,exp,colon,code) ->
1041 all_same true tgt (mcode2line case
)
1042 [mcode2arity case
; mcode2arity colon] in
1043 let case = mcode case in
1044 let exp = expression
arity exp in
1045 let colon = mcode colon in
1046 let code = dots (statement
arity) code in
1047 make_case_line c
tgt arity (Ast0.Case
(case,exp,colon,code))
1048 | Ast0.OptCase
(_
) -> failwith
"unexpected OptCase"
1050 (* --------------------------------------------------------------------- *)
1051 (* Function declaration *)
1052 (* Haven't thought much about arity here... *)
1054 let top_level tgt t
=
1056 (match Ast0.unwrap t
with
1057 Ast0.FILEINFO
(old_file
,new_file
) ->
1058 if mcode2arity old_file
= Ast0.NONE
&& mcode2arity new_file
= Ast0.NONE
1059 then Ast0.FILEINFO
(mcode old_file
,mcode new_file
)
1060 else fail t
"unexpected arity for file info"
1061 | Ast0.DECL
(stmt
) ->
1062 Ast0.DECL
(statement
tgt stmt
)
1063 | Ast0.CODE
(rule_elem_dots
) ->
1064 Ast0.CODE
(concat_dots (statement
tgt) rule_elem_dots
)
1065 | Ast0.ERRORWORDS
(exps) ->
1066 Ast0.ERRORWORDS
(List.map
(top_expression false Ast0.NONE
) exps)
1067 | Ast0.OTHER
(_
) -> fail t
"eliminated by top_level")
1069 let rule tgt = List.map
(top_level tgt)
1071 (* --------------------------------------------------------------------- *)
1074 let minus_arity code =