2 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
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.
24 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
25 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
26 * This file is part of Coccinelle.
28 * Coccinelle is free software: you can redistribute it and/or modify
29 * it under the terms of the GNU General Public License as published by
30 * the Free Software Foundation, according to version 2 of the License.
32 * Coccinelle is distributed in the hope that it will be useful,
33 * but WITHOUT ANY WARRANTY; without even the implied warranty of
34 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
35 * GNU General Public License for more details.
37 * You should have received a copy of the GNU General Public License
38 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
40 * The authors reserve the right to distribute this or future versions of
41 * Coccinelle under other licenses.
45 (* Arities matter for the minus slice, but not for the plus slice. *)
47 (* ? only allowed on rule_elems, and on subterms if the context is ? also. *)
49 module Ast0
= Ast0_cocci
50 module Ast
= Ast_cocci
52 (* --------------------------------------------------------------------- *)
54 let warning s
= Printf.printf
"warning: %s\n" s
58 (Printf.sprintf
"cocci line %d: %s"
59 ((Ast0.get_info w
).Ast0.pos_info
.Ast0.line_start
)
62 let make_opt_unique optfn uniquefn info tgt arity term
=
63 let term = Ast0.rewrap info
term in
66 else (* tgt must be NONE *)
68 Ast0.OPT
-> Ast0.copywrap info
(optfn
term)
69 | Ast0.UNIQUE
-> Ast0.copywrap info
(uniquefn
term)
70 | Ast0.NONE
-> failwith
"tgt must be NONE"
72 let all_same opt_allowed tgt line arities
=
76 (match List.hd arities
with
77 Ast0.OPT
when not opt_allowed
->
78 failwith
"opt only allowed for the elements of a statement list"
81 if not
(List.for_all
(function x
-> x
= tgt) arities
)
82 then warning (Printf.sprintf
"incompatible arity found on line %d" line
);
85 let get_option fn
= function
87 | Some x
-> Some
(fn x
)
89 let anyopt l fn
= List.exists
(function w
-> fn
(Ast0.unwrap w
)) l
92 let rec loop = function
95 match fn
(Ast0.unwrap x
) with
96 Some x
-> x
:: (loop xs
)
99 if List.length
res = List.length l
then Some
res else None
101 (* --------------------------------------------------------------------- *)
102 (* --------------------------------------------------------------------- *)
105 let mcode2line (_
,_
,info
,_
,_
,_
) = info
.Ast0.pos_info
.Ast0.line_start
106 let mcode2arity (_
,arity
,_
,_
,_
,_
) = arity
108 let mcode x
= x
(* nothing to do ... *)
110 (* --------------------------------------------------------------------- *)
115 (match Ast0.unwrap d
with
116 Ast0.DOTS
(x
) -> Ast0.DOTS
(List.map fn x
)
117 | Ast0.CIRCLES
(x
) -> Ast0.CIRCLES
(List.map fn x
)
118 | Ast0.STARS
(x
) -> Ast0.STARS
(List.map fn x
))
124 match Ast0.unwrap x
with
125 Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> true
132 match Ast0.unwrap x
with
133 Ast0.Dots
(_
,_
) | Ast0.Stars
(_
,_
) -> true
140 match Ast0.unwrap x
with
141 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) -> true
145 let concat_dots fn d
=
147 (match Ast0.unwrap d
with
149 let l = List.map fn x
in
152 else fail d
"inconsistent dots usage"
154 let l = List.map fn x
in
157 else fail d
"inconsistent dots usage"
159 let l = List.map fn x
in
162 else fail d
"inconsistent dots usage")
164 let flat_concat_dots fn d
=
165 match Ast0.unwrap d
with
166 Ast0.DOTS
(x
) -> List.map fn x
167 | Ast0.CIRCLES
(x
) -> List.map fn x
168 | Ast0.STARS
(x
) -> List.map fn x
170 (* --------------------------------------------------------------------- *)
175 (function x
-> Ast0.OptIdent x
)
176 (function x
-> Ast0.UniqueIdent x
)
178 let ident opt_allowed
tgt i
=
179 match Ast0.unwrap i
with
182 all_same opt_allowed
tgt (mcode2line name
)
183 [mcode2arity name
] in
184 let name = mcode name in
185 make_id i
tgt arity (Ast0.Id
(name))
186 | Ast0.MetaId
(name,constraints
,pure
) ->
188 all_same opt_allowed
tgt (mcode2line name)
189 [mcode2arity name] in
190 let name = mcode name in
191 make_id i
tgt arity (Ast0.MetaId
(name,constraints
,pure
))
192 | Ast0.MetaFunc
(name,constraints
,pure
) ->
194 all_same opt_allowed
tgt (mcode2line name)
195 [mcode2arity name] in
196 let name = mcode name in
197 make_id i
tgt arity (Ast0.MetaFunc
(name,constraints
,pure
))
198 | Ast0.MetaLocalFunc
(name,constraints
,pure
) ->
200 all_same opt_allowed
tgt (mcode2line name)
201 [mcode2arity name] in
202 let name = mcode name in
203 make_id i
tgt arity (Ast0.MetaLocalFunc
(name,constraints
,pure
))
204 | Ast0.OptIdent
(_
) | Ast0.UniqueIdent
(_
) ->
205 failwith
"unexpected code"
207 (* --------------------------------------------------------------------- *)
212 (function x
-> Ast0.OptExp x
)
213 (function x
-> Ast0.UniqueExp x
)
215 let rec top_expression opt_allowed
tgt expr
=
216 let exp_same = all_same opt_allowed
tgt in
217 match Ast0.unwrap expr
with
219 let new_id = ident opt_allowed
tgt id
in
221 (match Ast0.unwrap
new_id with
223 Ast0.OptExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
224 | Ast0.UniqueIdent
(id
) ->
225 Ast0.UniqueExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
226 | _
-> Ast0.Ident
(new_id))
227 | Ast0.Constant
(const
) ->
228 let arity = exp_same (mcode2line const
) [mcode2arity const
] in
229 let const = mcode const in
230 make_exp expr
tgt arity (Ast0.Constant
(const))
231 | Ast0.FunCall
(fn
,lp
,args
,rp
) ->
232 let arity = exp_same (mcode2line lp
) [mcode2arity lp
;mcode2arity rp
] in
233 let fn = expression
arity fn in
235 let args = dots (expression
arity) args in
237 make_exp expr
tgt arity (Ast0.FunCall
(fn,lp,args,rp))
238 | Ast0.Assignment
(left
,op
,right
,simple
) ->
239 let arity = exp_same (mcode2line op
) [mcode2arity op
] in
240 let left = expression
arity left in
242 let right = expression
arity right in
243 make_exp expr
tgt arity (Ast0.Assignment
(left,op,right,simple
))
244 | Ast0.CondExpr
(exp1
,why
,exp2
,colon
,exp3
) ->
246 exp_same (mcode2line why
) [mcode2arity why
; mcode2arity colon
] in
247 let exp1 = expression
arity exp1 in
248 let why = mcode why in
249 let exp2 = get_option (expression
arity) exp2 in
250 let colon = mcode colon in
251 let exp3 = expression
arity exp3 in
252 make_exp expr
tgt arity (Ast0.CondExpr
(exp1,why,exp2,colon,exp3))
253 | Ast0.Postfix
(exp
,op) ->
254 let arity = exp_same (mcode2line op) [mcode2arity op] in
255 let exp = expression
arity exp in
257 make_exp expr
tgt arity (Ast0.Postfix
(exp,op))
258 | Ast0.Infix
(exp,op) ->
259 let arity = exp_same (mcode2line op) [mcode2arity op] in
260 let exp = expression
arity exp in
262 make_exp expr
tgt arity (Ast0.Infix
(exp,op))
263 | Ast0.Unary
(exp,op) ->
264 let arity = exp_same (mcode2line op) [mcode2arity op] in
265 let exp = expression
arity exp in
267 make_exp expr
tgt arity (Ast0.Unary
(exp,op))
268 | Ast0.Binary
(left,op,right) ->
269 let arity = exp_same (mcode2line op) [mcode2arity op] in
270 let left = expression
arity left in
272 let right = expression
arity right in
273 make_exp expr
tgt arity (Ast0.Binary
(left,op,right))
274 | Ast0.Nested
(left,op,right) -> failwith
"nested in arity not possible"
275 | Ast0.Paren
(lp,exp,rp) ->
276 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
278 let exp = expression
arity exp in
280 make_exp expr
tgt arity (Ast0.Paren
(lp,exp,rp))
281 | Ast0.ArrayAccess
(exp1,lb
,exp2,rb
) ->
282 let arity = exp_same (mcode2line lb
) [mcode2arity lb
; mcode2arity rb
] in
283 let exp1 = expression
arity exp1 in
285 let exp2 = expression
arity exp2 in
287 make_exp expr
tgt arity (Ast0.ArrayAccess
(exp1,lb,exp2,rb))
288 | Ast0.RecordAccess
(exp,pt
,field
) ->
289 let arity = exp_same (mcode2line pt
) [mcode2arity pt
] in
290 let exp = expression
arity exp in
292 let field = ident false arity field in
293 make_exp expr
tgt arity (Ast0.RecordAccess
(exp,pt,field))
294 | Ast0.RecordPtAccess
(exp,ar
,field) ->
295 let arity = exp_same (mcode2line ar
) [mcode2arity ar
] in
296 let exp = expression
arity exp in
298 let field = ident false arity field in
299 make_exp expr
tgt arity (Ast0.RecordPtAccess
(exp,ar,field))
300 | Ast0.Cast
(lp,ty
,rp,exp) ->
301 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
303 let ty = typeC
arity ty in
305 let exp = expression
arity exp in
306 make_exp expr
tgt arity (Ast0.Cast
(lp,ty,rp,exp))
307 | Ast0.SizeOfExpr
(szf
,exp) ->
308 let arity = exp_same (mcode2line szf
) [mcode2arity szf
] in
309 let szf = mcode szf in
310 let exp = expression
arity exp in
311 make_exp expr
tgt arity (Ast0.SizeOfExpr
(szf,exp))
312 | Ast0.SizeOfType
(szf,lp,ty,rp) ->
314 exp_same (mcode2line szf) (List.map
mcode2arity [szf;lp;rp]) in
315 let szf = mcode szf in
317 let ty = typeC
arity ty in
319 make_exp expr
tgt arity (Ast0.SizeOfType
(szf,lp,ty,rp))
320 | Ast0.TypeExp
(ty) -> Ast0.rewrap expr
(Ast0.TypeExp
(typeC
tgt ty))
321 | Ast0.MetaErr
(name,constraints
,pure
) ->
322 let arity = exp_same (mcode2line name) [mcode2arity name] in
323 let name = mcode name in
324 make_exp expr
tgt arity (Ast0.MetaErr
(name,constraints
,pure
))
325 | Ast0.MetaExpr
(name,constraints
,ty,form
,pure
) ->
326 let arity = exp_same (mcode2line name) [mcode2arity name] in
327 let name = mcode name in
328 make_exp expr
tgt arity (Ast0.MetaExpr
(name,constraints
,ty,form
,pure
))
329 | Ast0.MetaExprList
(name,lenname
,pure
) ->
330 let arity = exp_same (mcode2line name) [mcode2arity name] in
331 let name = mcode name in
332 make_exp expr
tgt arity (Ast0.MetaExprList
(name,lenname
,pure
))
334 let arity = exp_same (mcode2line cm
) [mcode2arity cm
] in
336 make_exp expr
tgt arity (Ast0.EComma
(cm))
337 | Ast0.DisjExpr
(starter
,exps
,mids
,ender
) ->
338 let exps = List.map
(top_expression opt_allowed
tgt) exps in
339 (match List.rev
exps with
341 if anyopt xs
(function Ast0.OptExp
(_
) -> true | _
-> false)
342 then fail expr
"opt only allowed in the last disjunct"
344 Ast0.rewrap expr
(Ast0.DisjExpr
(starter
,exps,mids
,ender
))
345 | Ast0.NestExpr
(starter
,exp_dots
,ender
,whencode
,multi
) ->
347 Ast0.NestExpr
(starter
,
348 dots (top_expression true Ast0.NONE
) exp_dots
,
349 ender
,whencode
,multi
) in
351 | Ast0.Edots
(dots,whencode
) ->
352 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
353 let dots = mcode dots in
354 let whencode = get_option (expression
Ast0.NONE
) whencode in
355 make_exp expr
tgt arity (Ast0.Edots
(dots,whencode))
356 | Ast0.Ecircles
(dots,whencode) ->
357 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
358 let dots = mcode dots in
359 let whencode = get_option (expression
Ast0.NONE
) whencode in
360 make_exp expr
tgt arity (Ast0.Ecircles
(dots,whencode))
361 | Ast0.Estars
(dots,whencode) ->
362 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
363 let dots = mcode dots in
364 let whencode = get_option (expression
Ast0.NONE
) whencode in
365 make_exp expr
tgt arity (Ast0.Estars
(dots,whencode))
366 (* why does optexp exist???? *)
367 | Ast0.OptExp
(_
) | Ast0.UniqueExp
(_
) ->
368 failwith
"unexpected code"
370 and expression
tgt exp = top_expression false tgt exp
372 (* --------------------------------------------------------------------- *)
377 (function x
-> Ast0.OptType x
)
378 (function x
-> Ast0.UniqueType x
)
380 and top_typeC
tgt opt_allowed typ
=
381 match Ast0.unwrap typ
with
382 Ast0.ConstVol
(cv
,ty) ->
383 let arity = all_same opt_allowed
tgt (mcode2line cv
)
386 let ty = typeC
arity ty in
387 make_typeC typ
tgt arity (Ast0.ConstVol
(cv,ty))
388 | Ast0.BaseType
(ty,strings
) ->
390 all_same opt_allowed
tgt (mcode2line (List.hd strings
))
391 (List.map
mcode2arity strings
) in
392 let strings = List.map
mcode strings in
393 make_typeC typ
tgt arity (Ast0.BaseType
(ty,strings))
394 | Ast0.Signed
(sign
,ty) ->
396 all_same opt_allowed
tgt (mcode2line sign
) [mcode2arity sign
] in
397 let sign = mcode sign in
398 let ty = get_option (typeC
arity) ty in
399 make_typeC typ
tgt arity (Ast0.Signed
(sign,ty))
400 | Ast0.Pointer
(ty,star
) ->
402 all_same opt_allowed
tgt (mcode2line star
) [mcode2arity star
] in
403 let ty = typeC
arity ty in
404 let star = mcode star in
405 make_typeC typ
tgt arity (Ast0.Pointer
(ty,star))
406 | Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params
,rp2
) ->
408 all_same opt_allowed
tgt (mcode2line lp1
)
409 (List.map
mcode2arity [lp1
;star;rp1
;lp2
;rp2
]) in
410 let ty = typeC
arity ty in
411 let params = parameter_list
tgt params in
412 make_typeC typ
tgt arity
413 (Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params,rp2
))
414 | Ast0.FunctionType
(ty,lp1
,params,rp1
) ->
416 all_same opt_allowed
tgt (mcode2line lp1
)
417 (List.map
mcode2arity [lp1
;rp1
]) in
418 let ty = get_option (typeC
arity) ty in
419 let params = parameter_list
tgt params in
420 make_typeC typ
tgt arity (Ast0.FunctionType
(ty,lp1
,params,rp1
))
421 | Ast0.Array
(ty,lb,size
,rb) ->
423 all_same opt_allowed
tgt (mcode2line lb)
424 [mcode2arity lb;mcode2arity rb] in
425 let ty = typeC
arity ty in
427 let size = get_option (expression
arity) size in
429 make_typeC typ
tgt arity (Ast0.Array
(ty,lb,size,rb))
430 | Ast0.EnumName
(kind
,name) ->
432 all_same opt_allowed
tgt (mcode2line kind
) [mcode2arity kind
] in
433 let kind = mcode kind in
434 let name = ident false arity name in
435 make_typeC typ
tgt arity (Ast0.EnumName
(kind,name))
436 | Ast0.StructUnionName
(kind,name) ->
438 all_same opt_allowed
tgt (mcode2line kind)
439 [mcode2arity kind] in
440 let kind = mcode kind in
441 let name = get_option (ident false arity) name in
442 make_typeC typ
tgt arity (Ast0.StructUnionName
(kind,name))
443 | Ast0.StructUnionDef
(ty,lb,decls
,rb) ->
445 all_same opt_allowed
tgt (mcode2line lb)
446 (List.map
mcode2arity [lb;rb]) in
447 let ty = typeC
arity ty in
449 let decls = dots (declaration
tgt) decls in
451 make_typeC typ
tgt arity (Ast0.StructUnionDef
(ty,lb,decls,rb))
452 | Ast0.TypeName
(name) ->
454 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
455 let name = mcode name in
456 make_typeC typ
tgt arity (Ast0.TypeName
(name))
457 | Ast0.MetaType
(name,pure
) ->
459 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
460 let name = mcode name in
461 make_typeC typ
tgt arity (Ast0.MetaType
(name,pure
))
462 | Ast0.DisjType
(starter
,types
,mids
,ender
) ->
463 let types = List.map
(typeC
tgt) types in
464 (match List.rev
types with
466 if anyopt xs
(function Ast0.OptType
(_
) -> true | _
-> false)
467 then fail typ
"opt only allowed in the last disjunct"
469 let res = Ast0.DisjType
(starter
,types,mids
,ender
) in
471 | Ast0.OptType
(_
) | Ast0.UniqueType
(_
) ->
472 failwith
"unexpected code"
474 and typeC
tgt ty = top_typeC
tgt false ty
476 (* --------------------------------------------------------------------- *)
477 (* Variable declaration *)
478 (* Even if the Cocci program specifies a list of declarations, they are
479 split out into multiple declarations of a single variable each. *)
483 (function x
-> Ast0.OptDecl x
)
484 (function x
-> Ast0.UniqueDecl x
)
486 and declaration
tgt decl
=
487 match Ast0.unwrap decl
with
488 Ast0.Init
(stg
,ty,id
,eq
,exp,sem
) ->
490 all_same true tgt (mcode2line eq
)
491 ((match stg
with None
-> [] | Some x
-> [mcode2arity x
]) @
492 (List.map
mcode2arity [eq
;sem
])) in
493 let stg = get_option mcode stg in
494 let ty = typeC
arity ty in
495 let id = ident false arity id in
497 let exp = initialiser
arity exp in
498 let sem = mcode sem in
499 make_decl decl
tgt arity (Ast0.Init
(stg,ty,id,eq,exp,sem))
500 | Ast0.UnInit
(stg,ty,id,sem) ->
502 all_same true tgt (mcode2line sem)
503 ((match stg with None
-> [] | Some x
-> [mcode2arity x
]) @
504 [mcode2arity sem]) in
505 let stg = get_option mcode stg in
506 let ty = typeC
arity ty in
507 let id = ident false arity id in
508 let sem = mcode sem in
509 make_decl decl
tgt arity (Ast0.UnInit
(stg,ty,id,sem))
510 | Ast0.MacroDecl
(name,lp,args,rp,sem) ->
512 all_same true tgt (mcode2line lp) (List.map
mcode2arity [lp;rp;sem]) in
513 let name = ident false arity name in
515 let args = dots (expression
arity) args in
517 let sem = mcode sem in
518 make_decl decl
tgt arity (Ast0.MacroDecl
(name,lp,args,rp,sem))
519 | Ast0.TyDecl
(ty,sem) ->
521 all_same true tgt (mcode2line sem) [mcode2arity sem] in
522 let ty = typeC
arity ty in
523 let sem = mcode sem in
524 make_decl decl
tgt arity (Ast0.TyDecl
(ty,sem))
525 | Ast0.Typedef
(stg,ty,id,sem) ->
527 all_same true tgt (mcode2line sem)
528 [mcode2arity stg;mcode2arity sem] in
529 let stg = mcode stg in
530 let ty = typeC
arity ty in
531 let id = typeC
arity id in
532 let sem = mcode sem in
533 make_decl decl
tgt arity (Ast0.Typedef
(stg,ty,id,sem))
534 | Ast0.DisjDecl
(starter
,decls,mids
,ender
) ->
535 let decls = List.map
(declaration
tgt) decls in
536 (match List.rev
decls with
538 if anyopt xs
(function Ast0.OptDecl
(_
) -> true | _
-> false)
539 then fail decl
"opt only allowed in the last disjunct"
541 let res = Ast0.DisjDecl
(starter
,decls,mids
,ender
) in
543 | Ast0.Ddots
(dots,whencode) ->
544 let arity = all_same true tgt (mcode2line dots) [mcode2arity dots] in
545 let dots = mcode dots in
546 let whencode = get_option (declaration
Ast0.NONE
) whencode in
547 make_decl decl
tgt arity (Ast0.Ddots
(dots,whencode))
548 | Ast0.OptDecl
(_
) | Ast0.UniqueDecl
(_
) ->
549 failwith
"unexpected code"
551 (* --------------------------------------------------------------------- *)
556 (function x
-> Ast0.OptIni x
)
557 (function x
-> Ast0.UniqueIni x
)
559 and initialiser
tgt i
=
560 let init_same = all_same true tgt in
561 match Ast0.unwrap i
with
562 Ast0.MetaInit
(name,pure
) ->
563 let arity = init_same (mcode2line name) [mcode2arity name] in
564 let name = mcode name in
565 make_init i
tgt arity (Ast0.MetaInit
(name,pure
))
566 | Ast0.InitExpr
(exp) ->
567 Ast0.rewrap i
(Ast0.InitExpr
(expression
tgt exp))
568 | Ast0.InitList
(lb,initlist
,rb) ->
569 let arity = init_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
571 let initlist = dots (initialiser
arity) initlist in
573 make_init i
tgt arity (Ast0.InitList
(lb,initlist,rb))
574 | Ast0.InitGccExt
(designators
,eq,ini
) ->
575 let arity = init_same (mcode2line eq) [mcode2arity eq] in
576 let designators = List.map
(designator
arity) designators in
578 let ini = initialiser
arity ini in
579 make_init i
tgt arity (Ast0.InitGccExt
(designators,eq,ini))
580 | Ast0.InitGccName
(name,eq,ini) ->
581 let arity = init_same (mcode2line eq) [mcode2arity eq] in
582 let name = ident true arity name in
584 let ini = initialiser
arity ini in
585 make_init i
tgt arity (Ast0.InitGccName
(name,eq,ini))
587 let arity = init_same (mcode2line cm) [mcode2arity cm] in
589 make_init i
tgt arity (Ast0.IComma
(cm))
590 | Ast0.Idots
(dots,whencode) ->
591 let arity = init_same (mcode2line dots) [mcode2arity dots] in
592 let dots = mcode dots in
593 let whencode = get_option (initialiser
Ast0.NONE
) whencode in
594 make_init i
tgt arity (Ast0.Idots
(dots,whencode))
595 | Ast0.OptIni
(_
) | Ast0.UniqueIni
(_
) ->
596 failwith
"unexpected code"
598 and designator
tgt d
=
599 let dsame = all_same false tgt in
601 Ast0.DesignatorField
(dot
,id) ->
602 let arity = dsame (mcode2line dot
) [mcode2arity dot
] in
603 let dot = mcode dot in
604 let id = ident false arity id in
605 Ast0.DesignatorField
(dot,id)
606 | Ast0.DesignatorIndex
(lb,exp,rb) ->
607 let arity = dsame (mcode2line lb) [mcode2arity lb;mcode2arity rb] in
609 let exp = top_expression false arity exp in
611 Ast0.DesignatorIndex
(lb,exp,rb)
612 | Ast0.DesignatorRange
(lb,min
,dots,max
,rb) ->
614 dsame (mcode2line lb)
615 [mcode2arity lb;mcode2arity dots;mcode2arity rb] in
617 let min = top_expression false arity min in
618 let dots = mcode dots in
619 let max = top_expression false arity max in
621 Ast0.DesignatorRange
(lb,min,dots,max,rb)
623 (* --------------------------------------------------------------------- *)
628 (function x
-> Ast0.OptParam x
)
629 (function x
-> Ast0.UniqueParam x
)
631 and parameterTypeDef
tgt param
=
632 let param_same = all_same true tgt in
633 match Ast0.unwrap param
with
634 Ast0.VoidParam
(ty) -> Ast0.rewrap param
(Ast0.VoidParam
(typeC
tgt ty))
635 | Ast0.Param
(ty,Some
id) ->
636 let ty = top_typeC
tgt true ty in
637 let id = ident true tgt id in
639 (match (Ast0.unwrap
ty,Ast0.unwrap
id) with
640 (Ast0.OptType
(ty),Ast0.OptIdent
(id)) ->
641 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
642 | (Ast0.UniqueType
(ty),Ast0.UniqueIdent
(id)) ->
643 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
644 | (Ast0.OptType
(ty),_
) ->
645 fail param
"arity mismatch in param declaration"
646 | (_
,Ast0.OptIdent
(id)) ->
647 fail param
"arity mismatch in param declaration"
648 | _
-> Ast0.Param
(ty,Some
id))
649 | Ast0.Param
(ty,None
) ->
650 let ty = top_typeC
tgt true ty in
652 (match Ast0.unwrap
ty with
654 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
655 | Ast0.UniqueType
(ty) ->
656 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
657 | _
-> Ast0.Param
(ty,None
))
658 | Ast0.MetaParam
(name,pure
) ->
659 let arity = param_same (mcode2line name) [mcode2arity name] in
660 let name = mcode name in
661 make_param param
tgt arity (Ast0.MetaParam
(name,pure
))
662 | Ast0.MetaParamList
(name,lenname
,pure
) ->
663 let arity = param_same (mcode2line name) [mcode2arity name] in
664 let name = mcode name in
665 make_param param
tgt arity (Ast0.MetaParamList
(name,lenname
,pure
))
667 let arity = param_same (mcode2line cm) [mcode2arity cm] in
669 make_param param
tgt arity (Ast0.PComma
(cm))
670 | Ast0.Pdots
(dots) ->
671 let arity = param_same (mcode2line dots) [mcode2arity dots] in
672 let dots = mcode dots in
673 make_param param
tgt arity (Ast0.Pdots
(dots))
674 | Ast0.Pcircles
(dots) ->
675 let arity = param_same (mcode2line dots) [mcode2arity dots] in
676 let dots = mcode dots in
677 make_param param
tgt arity (Ast0.Pcircles
(dots))
678 | Ast0.OptParam
(_
) | Ast0.UniqueParam
(_
) ->
679 failwith
"unexpected code"
681 and parameter_list
tgt = dots (parameterTypeDef
tgt)
683 (* --------------------------------------------------------------------- *)
686 and make_rule_elem x
=
688 (function x
-> Ast0.OptStm x
)
689 (function x
-> Ast0.UniqueStm x
)
692 and statement
tgt stm
=
693 let stm_same = all_same true tgt in
694 match Ast0.unwrap stm
with
695 Ast0.Decl
(bef
,decl
) ->
696 let new_decl = declaration
tgt decl
in
698 (match Ast0.unwrap
new_decl with
699 Ast0.OptDecl
(decl
) ->
700 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
701 | Ast0.UniqueDecl
(decl
) ->
702 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
703 | _
-> Ast0.Decl
(bef
,new_decl))
704 | Ast0.Seq
(lbrace
,body
,rbrace
) ->
706 stm_same (mcode2line lbrace
)
707 [mcode2arity lbrace
; mcode2arity rbrace
] in
708 let lbrace = mcode lbrace in
709 let body = dots (statement
arity) body in
710 let rbrace = mcode rbrace in
711 make_rule_elem stm
tgt arity (Ast0.Seq
(lbrace,body,rbrace))
712 | Ast0.ExprStatement
(exp,sem) ->
713 let arity = stm_same (mcode2line sem) [mcode2arity sem] in
714 let exp = expression
arity exp in
715 let sem = mcode sem in
716 make_rule_elem stm
tgt arity (Ast0.ExprStatement
(exp,sem))
717 | Ast0.IfThen
(iff
,lp,exp,rp,branch
,aft
) ->
719 stm_same (mcode2line iff
) (List.map
mcode2arity [iff
;lp;rp]) in
720 let iff = mcode iff in
722 let exp = expression
arity exp in
724 let branch = statement
arity branch in
725 make_rule_elem stm
tgt arity (Ast0.IfThen
(iff,lp,exp,rp,branch,aft
))
726 | Ast0.IfThenElse
(iff,lp,exp,rp,branch1
,els
,branch2
,aft
) ->
728 stm_same (mcode2line iff) (List.map
mcode2arity [iff;lp;rp;els
]) in
729 let iff = mcode iff in
731 let exp = expression
arity exp in
733 let branch1 = statement
arity branch1 in
734 let els = mcode els in
735 let branch2 = statement
arity branch2 in
736 make_rule_elem stm
tgt arity
737 (Ast0.IfThenElse
(iff,lp,exp,rp,branch1,els,branch2,aft
))
738 | Ast0.While
(wh
,lp,exp,rp,body,aft
) ->
740 stm_same (mcode2line wh
)
741 (List.map
mcode2arity [wh
;lp;rp]) in
744 let exp = expression
arity exp in
746 let body = statement
arity body in
747 make_rule_elem stm
tgt arity (Ast0.While
(wh,lp,exp,rp,body,aft
))
748 | Ast0.Do
(d
,body,wh,lp,exp,rp,sem) ->
750 stm_same (mcode2line wh) (List.map
mcode2arity [d
;wh;lp;rp;sem]) in
752 let body = statement
arity body in
755 let exp = expression
arity exp in
757 let sem = mcode sem in
758 make_rule_elem stm
tgt arity (Ast0.Do
(d,body,wh,lp,exp,rp,sem))
759 | Ast0.For
(fr
,lp,exp1,sem1
,exp2,sem2
,exp3,rp,body,aft
) ->
761 stm_same (mcode2line fr
) (List.map
mcode2arity [fr
;lp;sem1
;sem2
;rp]) in
764 let exp1 = get_option (expression
arity) exp1 in
765 let sem1 = mcode sem1 in
766 let exp2 = get_option (expression
arity) exp2 in
767 let sem2= mcode sem2 in
768 let exp3 = get_option (expression
arity) exp3 in
770 let body = statement
arity body in
771 make_rule_elem stm
tgt arity
772 (Ast0.For
(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft
))
773 | Ast0.Iterator
(nm
,lp,args,rp,body,aft
) ->
774 let arity = stm_same (mcode2line lp) (List.map
mcode2arity [lp;rp]) in
775 let nm = ident false arity nm in
777 let args = dots (expression
arity) args in
779 let body = statement
arity body in
780 make_rule_elem stm
tgt arity (Ast0.Iterator
(nm,lp,args,rp,body,aft
))
781 | Ast0.Switch
(switch
,lp,exp,rp,lb,decls,cases
,rb) ->
783 stm_same (mcode2line switch
)
784 (List.map
mcode2arity [switch
;lp;rp;lb;rb]) in
785 let switch = mcode switch in
787 let exp = expression
arity exp in
790 let decls = dots (statement
arity) decls in
791 let cases = dots (case_line
arity) cases in
793 make_rule_elem stm
tgt arity
794 (Ast0.Switch
(switch,lp,exp,rp,lb,decls,cases,rb))
795 | Ast0.Break
(br
,sem) ->
796 let arity = stm_same (mcode2line br
) (List.map
mcode2arity [br
;sem]) in
798 let sem = mcode sem in
799 make_rule_elem stm
tgt arity (Ast0.Break
(br,sem))
800 | Ast0.Continue
(cont
,sem) ->
802 stm_same (mcode2line cont
) (List.map
mcode2arity [cont
;sem]) in
803 let cont = mcode cont in
804 let sem = mcode sem in
805 make_rule_elem stm
tgt arity (Ast0.Continue
(cont,sem))
806 | Ast0.Label
(l,dd
) ->
807 let arity = mcode2arity dd
in
808 let l = ident false tgt l in
810 make_rule_elem stm
tgt arity (Ast0.Label
(l,dd))
811 | Ast0.Goto
(goto
,l,sem) ->
813 stm_same (mcode2line goto
) (List.map
mcode2arity [goto
;sem]) in
814 let goto = mcode goto in
815 let l = ident false arity l in
816 let sem = mcode sem in
817 make_rule_elem stm
tgt arity (Ast0.Goto
(goto,l,sem))
818 | Ast0.Return
(ret
,sem) ->
819 let arity = stm_same (mcode2line ret
) (List.map
mcode2arity [ret
;sem]) in
820 let ret = mcode ret in
821 let sem = mcode sem in
822 make_rule_elem stm
tgt arity (Ast0.Return
(ret,sem))
823 | Ast0.ReturnExpr
(ret,exp,sem) ->
824 let arity = stm_same (mcode2line ret) (List.map
mcode2arity [ret;sem]) in
825 let ret = mcode ret in
826 let exp = expression
arity exp in
827 let sem = mcode sem in
828 make_rule_elem stm
tgt arity (Ast0.ReturnExpr
(ret,exp,sem))
829 | Ast0.MetaStmt
(name,pure
) ->
830 let arity = stm_same (mcode2line name) [mcode2arity name] in
831 let name = mcode name in
832 make_rule_elem stm
tgt arity (Ast0.MetaStmt
(name,pure
))
833 | Ast0.MetaStmtList
(name,pure
) ->
834 let arity = stm_same (mcode2line name) [mcode2arity name] in
835 let name = mcode name in
836 make_rule_elem stm
tgt arity (Ast0.MetaStmtList
(name,pure
))
838 let new_exp = top_expression true tgt exp in
840 (match Ast0.unwrap
new_exp with
842 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
843 | Ast0.UniqueExp
(exp) ->
844 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
845 | _
-> Ast0.Exp
(new_exp))
846 | Ast0.TopExp
(exp) ->
847 let new_exp = top_expression true tgt exp in
849 (match Ast0.unwrap
new_exp with
851 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
852 | Ast0.UniqueExp
(exp) ->
853 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
854 | _
-> Ast0.TopExp
(new_exp))
856 let new_ty = typeC
tgt ty in (* opt makes no sense alone at top level *)
858 (match Ast0.unwrap
new_ty with
860 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
861 | Ast0.UniqueType
(ty) ->
862 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
863 | _
-> Ast0.Ty
(new_ty))
864 | Ast0.TopInit
(init
) ->
865 let new_init = initialiser
tgt init
in
867 (match Ast0.unwrap
new_init with
869 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopInit
(init
)))
870 | Ast0.UniqueIni
(init
) ->
871 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopInit
(init
)))
872 | _
-> Ast0.TopInit
(new_init))
873 | Ast0.Disj
(starter
,rule_elem_dots_list
,mids
,ender
) ->
875 List.map
(function x
-> concat_dots (statement
tgt) x
)
876 rule_elem_dots_list
in
877 let (found_opt
,unopt
) =
879 (function (found_opt
,lines
) ->
882 (* previously just checked the last thing in the list,
883 but everything should be optional for the whole thing to
886 match Ast0.unwrap x
with
887 Ast0.OptStm
(x
) -> true
890 match Ast0.unwrap x
with
893 if List.for_all
is_opt l
894 then (true,List.map
unopt l)
897 match Ast0.unwrap x
with
899 (l,function l -> Ast0.rewrap x
(Ast0.DOTS
l))
901 (l,function l -> Ast0.rewrap x
(Ast0.CIRCLES
l))
903 (l,function l -> Ast0.rewrap x
(Ast0.STARS
l)) in
904 let (found_opt
,l) = rebuild l in
905 (found_opt
,(k
l)::lines
))
907 let unopt = List.rev
unopt in
910 make_rule_elem stm
tgt Ast0.OPT
(Ast0.Disj
(starter
,unopt,mids
,ender
))
911 else Ast0.rewrap stm
(Ast0.Disj
(starter
,stms,mids
,ender
))
912 | Ast0.Nest
(starter
,rule_elem_dots
,ender
,whn
,multi
) ->
913 let new_rule_elem_dots =
914 concat_dots (statement
Ast0.NONE
) rule_elem_dots
in
917 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
918 (expression
Ast0.NONE
))
921 (Ast0.Nest
(starter
,new_rule_elem_dots,ender
,whn,multi
))
922 | Ast0.Dots
(dots,whn) ->
923 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
924 let dots = mcode dots in
927 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
928 (expression
Ast0.NONE
))
930 make_rule_elem stm
tgt arity (Ast0.Dots
(dots,whn))
931 | Ast0.Circles
(dots,whn) ->
932 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
933 let dots = mcode dots in
936 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
937 (expression
Ast0.NONE
))
939 make_rule_elem stm
tgt arity (Ast0.Circles
(dots,whn))
940 | Ast0.Stars
(dots,whn) ->
941 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
942 let dots = mcode dots in
945 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
946 (expression
Ast0.NONE
))
948 make_rule_elem stm
tgt arity (Ast0.Stars
(dots,whn))
949 | Ast0.FunDecl
(bef
,fi
,name,lp,params,rp,lbrace,body,rbrace) ->
951 all_same true tgt (mcode2line lp)
952 ((List.map
mcode2arity [lp;rp;lbrace;rbrace]) @ (fninfo2arity fi
)) in
953 let fi = List.map
(fninfo
arity) fi in
954 let name = ident false arity name in
956 let params = parameter_list
arity params in
958 let lbrace = mcode lbrace in
959 let body = dots (statement
arity) body in
960 let rbrace = mcode rbrace in
961 make_rule_elem stm
tgt arity
962 (Ast0.FunDecl
(bef
,fi,name,lp,params,rp,lbrace,body,rbrace))
963 | Ast0.Include
(inc
,s
) ->
965 all_same true tgt (mcode2line inc
) [mcode2arity inc
; mcode2arity s
] in
966 let inc = mcode inc in
968 make_rule_elem stm
tgt arity (Ast0.Include
(inc,s))
969 | Ast0.Define
(def
,id,params,body) ->
970 let arity = all_same true tgt (mcode2line def
) [mcode2arity def
] in
971 let def = mcode def in
972 let id = ident false arity id in
973 let params = define_parameters
arity params in
974 let body = dots (statement
arity) body in
975 make_rule_elem stm
tgt arity (Ast0.Define
(def,id,params,body))
976 | Ast0.OptStm
(_
) | Ast0.UniqueStm
(_
) ->
977 failwith
"unexpected code"
979 and define_parameters
tgt params =
980 match Ast0.unwrap
params with
981 Ast0.NoParams
-> params
982 | Ast0.DParams
(lp,params,rp) ->
984 all_same true tgt (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
986 let params = dots (define_param
arity) params in
988 Ast0.rewrap
params (Ast0.DParams
(lp,params,rp))
990 and make_define_param x
=
992 (function x
-> Ast0.OptDParam x
)
993 (function x
-> Ast0.UniqueDParam x
)
996 and define_param
tgt param
=
997 match Ast0.unwrap param
with
999 let new_id = ident true tgt id in
1001 (match Ast0.unwrap
new_id with
1002 Ast0.OptIdent
(id) ->
1003 Ast0.OptDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
1004 | Ast0.UniqueIdent
(decl
) ->
1005 Ast0.UniqueDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
1006 | _
-> Ast0.DParam
(new_id))
1007 | Ast0.DPComma
(cm) ->
1009 all_same true tgt (mcode2line cm) [mcode2arity cm] in
1010 let cm = mcode cm in
1011 make_define_param param
tgt arity (Ast0.DPComma
(cm))
1012 | Ast0.DPdots
(dots) ->
1014 all_same true tgt (mcode2line dots) [mcode2arity dots] in
1015 let dots = mcode dots in
1016 make_define_param param
tgt arity (Ast0.DPdots
(dots))
1017 | Ast0.DPcircles
(circles
) ->
1019 all_same true tgt (mcode2line circles
) [mcode2arity circles
] in
1020 let circles = mcode circles in
1021 make_define_param param
tgt arity (Ast0.DPcircles
(circles))
1022 | Ast0.OptDParam
(dp
) | Ast0.UniqueDParam
(dp
) ->
1023 failwith
"unexpected code"
1025 and fninfo
arity = function
1026 Ast0.FStorage
(stg) -> Ast0.FStorage
(mcode stg)
1027 | Ast0.FType
(ty) -> Ast0.FType
(typeC
arity ty)
1028 | Ast0.FInline
(inline
) -> Ast0.FInline
(mcode inline
)
1029 | Ast0.FAttr
(attr
) -> Ast0.FAttr
(mcode attr
)
1031 and fninfo2arity fninfo
=
1035 Ast0.FStorage
(stg) -> [mcode2arity stg]
1036 | Ast0.FType
(ty) -> []
1037 | Ast0.FInline
(inline
) -> [mcode2arity inline
]
1038 | Ast0.FAttr
(attr
) -> [mcode2arity attr
])
1041 and whencode notfn alwaysfn expression
= function
1042 Ast0.WhenNot a
-> Ast0.WhenNot
(notfn a
)
1043 | Ast0.WhenAlways a
-> Ast0.WhenAlways
(alwaysfn a
)
1044 | Ast0.WhenModifier
(x
) -> Ast0.WhenModifier
(x
)
1045 | Ast0.WhenNotTrue a
-> Ast0.WhenNotTrue
(expression a
)
1046 | Ast0.WhenNotFalse a
-> Ast0.WhenNotFalse
(expression a
)
1048 and make_case_line
=
1050 (function x
-> Ast0.OptCase x
)
1051 (function x
-> failwith
"unique not allowed for case_line")
1053 and case_line
tgt c
=
1054 match Ast0.unwrap c
with
1055 Ast0.Default
(def,colon,code
) ->
1057 all_same true tgt (mcode2line def)
1058 [mcode2arity def; mcode2arity colon] in
1059 let def = mcode def in
1060 let colon = mcode colon in
1061 let code = dots (statement
arity) code in
1062 make_case_line c
tgt arity (Ast0.Default
(def,colon,code))
1063 | Ast0.Case
(case
,exp,colon,code) ->
1065 all_same true tgt (mcode2line case
)
1066 [mcode2arity case
; mcode2arity colon] in
1067 let case = mcode case in
1068 let exp = expression
arity exp in
1069 let colon = mcode colon in
1070 let code = dots (statement
arity) code in
1071 make_case_line c
tgt arity (Ast0.Case
(case,exp,colon,code))
1072 | Ast0.DisjCase
(starter
,case_lines
,mids
,ender
) ->
1073 let case_lines = List.map
(case_line
tgt) case_lines in
1074 (match List.rev
case_lines with
1076 if anyopt xs
(function Ast0.OptCase
(_
) -> true | _
-> false)
1077 then fail c
"opt only allowed in the last disjunct"
1079 Ast0.rewrap c
(Ast0.DisjCase
(starter
,case_lines,mids
,ender
))
1080 | Ast0.OptCase
(_
) -> failwith
"unexpected OptCase"
1082 (* --------------------------------------------------------------------- *)
1083 (* Function declaration *)
1084 (* Haven't thought much about arity here... *)
1086 let top_level tgt t
=
1088 (match Ast0.unwrap t
with
1089 Ast0.FILEINFO
(old_file
,new_file
) ->
1090 if mcode2arity old_file
= Ast0.NONE
&& mcode2arity new_file
= Ast0.NONE
1091 then Ast0.FILEINFO
(mcode old_file
,mcode new_file
)
1092 else fail t
"unexpected arity for file info"
1093 | Ast0.DECL
(stmt
) ->
1094 Ast0.DECL
(statement
tgt stmt
)
1095 | Ast0.CODE
(rule_elem_dots
) ->
1096 Ast0.CODE
(concat_dots (statement
tgt) rule_elem_dots
)
1097 | Ast0.ERRORWORDS
(exps) ->
1098 Ast0.ERRORWORDS
(List.map
(top_expression false Ast0.NONE
) exps)
1099 | Ast0.OTHER
(_
) -> fail t
"eliminated by top_level")
1101 let rule tgt = List.map
(top_level tgt)
1103 (* --------------------------------------------------------------------- *)
1106 let minus_arity code =