2 * Copyright 2005-2008, 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" ((Ast0.get_info w
).Ast0.line_start
)
39 let make_opt_unique optfn uniquefn info tgt arity term
=
40 let term = Ast0.rewrap info
term in
43 else (* tgt must be NONE *)
45 Ast0.OPT
-> Ast0.copywrap info
(optfn
term)
46 | Ast0.UNIQUE
-> Ast0.copywrap info
(uniquefn
term)
47 | Ast0.NONE
-> failwith
"tgt must be NONE"
49 let all_same opt_allowed tgt line arities
=
53 (match List.hd arities
with
54 Ast0.OPT
when not opt_allowed
->
55 failwith
"opt only allowed for the elements of a statement list"
58 if not
(List.for_all
(function x
-> x
= tgt) arities
)
59 then warning (Printf.sprintf
"incompatible arity found on line %d" line
);
62 let get_option fn
= function
64 | Some x
-> Some
(fn x
)
66 let anyopt l fn
= List.exists
(function w
-> fn
(Ast0.unwrap w
)) l
69 let rec loop = function
72 match fn
(Ast0.unwrap x
) with
73 Some x
-> x
:: (loop xs
)
76 if List.length
res = List.length l
then Some
res else None
78 (* --------------------------------------------------------------------- *)
79 (* --------------------------------------------------------------------- *)
82 let mcode2line (_
,_
,info
,_
,_
) = info
.Ast0.line_start
83 let mcode2arity (_
,arity
,_
,_
,_
) = arity
85 let mcode x
= x
(* nothing to do ... *)
87 (* --------------------------------------------------------------------- *)
92 (match Ast0.unwrap d
with
93 Ast0.DOTS
(x
) -> Ast0.DOTS
(List.map fn x
)
94 | Ast0.CIRCLES
(x
) -> Ast0.CIRCLES
(List.map fn x
)
95 | Ast0.STARS
(x
) -> Ast0.STARS
(List.map fn x
))
101 match Ast0.unwrap x
with
102 Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> true
109 match Ast0.unwrap x
with
110 Ast0.Dots
(_
,_
) | Ast0.Stars
(_
,_
) -> true
117 match Ast0.unwrap x
with
118 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) -> true
122 let concat_dots fn d
=
124 (match Ast0.unwrap d
with
126 let l = List.map fn x
in
129 else fail d
"inconsistent dots usage"
131 let l = List.map fn x
in
134 else fail d
"inconsistent dots usage"
136 let l = List.map fn x
in
139 else fail d
"inconsistent dots usage")
141 let flat_concat_dots fn d
=
142 match Ast0.unwrap d
with
143 Ast0.DOTS
(x
) -> List.map fn x
144 | Ast0.CIRCLES
(x
) -> List.map fn x
145 | Ast0.STARS
(x
) -> List.map fn x
147 (* --------------------------------------------------------------------- *)
152 (function x
-> Ast0.OptIdent x
)
153 (function x
-> Ast0.UniqueIdent x
)
155 let ident opt_allowed
tgt i
=
156 match Ast0.unwrap i
with
159 all_same opt_allowed
tgt (mcode2line name
)
160 [mcode2arity name
] in
161 let name = mcode name in
162 make_id i
tgt arity (Ast0.Id
(name))
163 | Ast0.MetaId
(name,constraints
,pure
) ->
165 all_same opt_allowed
tgt (mcode2line name)
166 [mcode2arity name] in
167 let name = mcode name in
168 make_id i
tgt arity (Ast0.MetaId
(name,constraints
,pure
))
169 | Ast0.MetaFunc
(name,constraints
,pure
) ->
171 all_same opt_allowed
tgt (mcode2line name)
172 [mcode2arity name] in
173 let name = mcode name in
174 make_id i
tgt arity (Ast0.MetaFunc
(name,constraints
,pure
))
175 | Ast0.MetaLocalFunc
(name,constraints
,pure
) ->
177 all_same opt_allowed
tgt (mcode2line name)
178 [mcode2arity name] in
179 let name = mcode name in
180 make_id i
tgt arity (Ast0.MetaLocalFunc
(name,constraints
,pure
))
181 | Ast0.OptIdent
(_
) | Ast0.UniqueIdent
(_
) ->
182 failwith
"unexpected code"
184 (* --------------------------------------------------------------------- *)
189 (function x
-> Ast0.OptExp x
)
190 (function x
-> Ast0.UniqueExp x
)
192 let rec top_expression opt_allowed
tgt expr
=
193 let exp_same = all_same opt_allowed
tgt in
194 match Ast0.unwrap expr
with
196 let new_id = ident opt_allowed
tgt id
in
198 (match Ast0.unwrap
new_id with
200 Ast0.OptExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
201 | Ast0.UniqueIdent
(id
) ->
202 Ast0.UniqueExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
203 | _
-> Ast0.Ident
(new_id))
204 | Ast0.Constant
(const
) ->
205 let arity = exp_same (mcode2line const
) [mcode2arity const
] in
206 let const = mcode const in
207 make_exp expr
tgt arity (Ast0.Constant
(const))
208 | Ast0.FunCall
(fn
,lp
,args
,rp
) ->
209 let arity = exp_same (mcode2line lp
) [mcode2arity lp
;mcode2arity rp
] in
210 let fn = expression
arity fn in
212 let args = dots (expression
arity) args in
214 make_exp expr
tgt arity (Ast0.FunCall
(fn,lp,args,rp))
215 | Ast0.Assignment
(left
,op
,right
,simple
) ->
216 let arity = exp_same (mcode2line op
) [mcode2arity op
] in
217 let left = expression
arity left in
219 let right = expression
arity right in
220 make_exp expr
tgt arity (Ast0.Assignment
(left,op,right,simple
))
221 | Ast0.CondExpr
(exp1
,why
,exp2
,colon
,exp3
) ->
223 exp_same (mcode2line why
) [mcode2arity why
; mcode2arity colon
] in
224 let exp1 = expression
arity exp1 in
225 let why = mcode why in
226 let exp2 = get_option (expression
arity) exp2 in
227 let colon = mcode colon in
228 let exp3 = expression
arity exp3 in
229 make_exp expr
tgt arity (Ast0.CondExpr
(exp1,why,exp2,colon,exp3))
230 | Ast0.Postfix
(exp
,op) ->
231 let arity = exp_same (mcode2line op) [mcode2arity op] in
232 let exp = expression
arity exp in
234 make_exp expr
tgt arity (Ast0.Postfix
(exp,op))
235 | Ast0.Infix
(exp,op) ->
236 let arity = exp_same (mcode2line op) [mcode2arity op] in
237 let exp = expression
arity exp in
239 make_exp expr
tgt arity (Ast0.Infix
(exp,op))
240 | Ast0.Unary
(exp,op) ->
241 let arity = exp_same (mcode2line op) [mcode2arity op] in
242 let exp = expression
arity exp in
244 make_exp expr
tgt arity (Ast0.Unary
(exp,op))
245 | Ast0.Binary
(left,op,right) ->
246 let arity = exp_same (mcode2line op) [mcode2arity op] in
247 let left = expression
arity left in
249 let right = expression
arity right in
250 make_exp expr
tgt arity (Ast0.Binary
(left,op,right))
251 | Ast0.Nested
(left,op,right) -> failwith
"nested in arity not possible"
252 | Ast0.Paren
(lp,exp,rp) ->
253 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
255 let exp = expression
arity exp in
257 make_exp expr
tgt arity (Ast0.Paren
(lp,exp,rp))
258 | Ast0.ArrayAccess
(exp1,lb
,exp2,rb
) ->
259 let arity = exp_same (mcode2line lb
) [mcode2arity lb
; mcode2arity rb
] in
260 let exp1 = expression
arity exp1 in
262 let exp2 = expression
arity exp2 in
264 make_exp expr
tgt arity (Ast0.ArrayAccess
(exp1,lb,exp2,rb))
265 | Ast0.RecordAccess
(exp,pt
,field
) ->
266 let arity = exp_same (mcode2line pt
) [mcode2arity pt
] in
267 let exp = expression
arity exp in
269 let field = ident false arity field in
270 make_exp expr
tgt arity (Ast0.RecordAccess
(exp,pt,field))
271 | Ast0.RecordPtAccess
(exp,ar
,field) ->
272 let arity = exp_same (mcode2line ar
) [mcode2arity ar
] in
273 let exp = expression
arity exp in
275 let field = ident false arity field in
276 make_exp expr
tgt arity (Ast0.RecordPtAccess
(exp,ar,field))
277 | Ast0.Cast
(lp,ty
,rp,exp) ->
278 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
280 let ty = typeC
arity ty in
282 let exp = expression
arity exp in
283 make_exp expr
tgt arity (Ast0.Cast
(lp,ty,rp,exp))
284 | Ast0.SizeOfExpr
(szf
,exp) ->
285 let arity = exp_same (mcode2line szf
) [mcode2arity szf
] in
286 let szf = mcode szf in
287 let exp = expression
arity exp in
288 make_exp expr
tgt arity (Ast0.SizeOfExpr
(szf,exp))
289 | Ast0.SizeOfType
(szf,lp,ty,rp) ->
291 exp_same (mcode2line szf) (List.map
mcode2arity [szf;lp;rp]) in
292 let szf = mcode szf in
294 let ty = typeC
arity ty in
296 make_exp expr
tgt arity (Ast0.SizeOfType
(szf,lp,ty,rp))
297 | Ast0.TypeExp
(ty) -> Ast0.rewrap expr
(Ast0.TypeExp
(typeC
tgt ty))
298 | Ast0.MetaErr
(name,constraints
,pure
) ->
299 let arity = exp_same (mcode2line name) [mcode2arity name] in
300 let name = mcode name in
301 make_exp expr
tgt arity (Ast0.MetaErr
(name,constraints
,pure
))
302 | Ast0.MetaExpr
(name,constraints
,ty,form
,pure
) ->
303 let arity = exp_same (mcode2line name) [mcode2arity name] in
304 let name = mcode name in
305 make_exp expr
tgt arity (Ast0.MetaExpr
(name,constraints
,ty,form
,pure
))
306 | Ast0.MetaExprList
(name,lenname
,pure
) ->
307 let arity = exp_same (mcode2line name) [mcode2arity name] in
308 let name = mcode name in
309 make_exp expr
tgt arity (Ast0.MetaExprList
(name,lenname
,pure
))
311 let arity = exp_same (mcode2line cm
) [mcode2arity cm
] in
313 make_exp expr
tgt arity (Ast0.EComma
(cm))
314 | Ast0.DisjExpr
(starter
,exps
,mids
,ender
) ->
315 let exps = List.map
(top_expression opt_allowed
tgt) exps in
316 (match List.rev
exps with
318 if anyopt xs
(function Ast0.OptExp
(_
) -> true | _
-> false)
319 then fail expr
"opt only allowed in the last disjunct"
321 Ast0.rewrap expr
(Ast0.DisjExpr
(starter
,exps,mids
,ender
))
322 | Ast0.NestExpr
(starter
,exp_dots
,ender
,whencode
,multi
) ->
324 Ast0.NestExpr
(starter
,
325 dots (top_expression true Ast0.NONE
) exp_dots
,
326 ender
,whencode
,multi
) in
328 | Ast0.Edots
(dots,whencode
) ->
329 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
330 let dots = mcode dots in
331 let whencode = get_option (expression
Ast0.NONE
) whencode in
332 make_exp expr
tgt arity (Ast0.Edots
(dots,whencode))
333 | Ast0.Ecircles
(dots,whencode) ->
334 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
335 let dots = mcode dots in
336 let whencode = get_option (expression
Ast0.NONE
) whencode in
337 make_exp expr
tgt arity (Ast0.Ecircles
(dots,whencode))
338 | Ast0.Estars
(dots,whencode) ->
339 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
340 let dots = mcode dots in
341 let whencode = get_option (expression
Ast0.NONE
) whencode in
342 make_exp expr
tgt arity (Ast0.Estars
(dots,whencode))
343 | Ast0.OptExp
(_
) | Ast0.UniqueExp
(_
) ->
344 failwith
"unexpected code"
346 and expression
tgt exp = top_expression false tgt exp
348 (* --------------------------------------------------------------------- *)
353 (function x
-> Ast0.OptType x
)
354 (function x
-> Ast0.UniqueType x
)
356 and top_typeC
tgt opt_allowed typ
=
357 match Ast0.unwrap typ
with
358 Ast0.ConstVol
(cv
,ty) ->
359 let arity = all_same opt_allowed
tgt (mcode2line cv
)
362 let ty = typeC
arity ty in
363 make_typeC typ
tgt arity (Ast0.ConstVol
(cv,ty))
364 | Ast0.BaseType
(ty,Some sign
) ->
366 all_same opt_allowed
tgt (mcode2line ty)
367 [mcode2arity ty; mcode2arity sign
] in
369 let sign = mcode sign in
370 make_typeC typ
tgt arity (Ast0.BaseType
(ty,Some
sign))
371 | Ast0.BaseType
(ty,None
) ->
373 all_same opt_allowed
tgt (mcode2line ty) [mcode2arity ty] in
375 make_typeC typ
tgt arity (Ast0.BaseType
(ty,None
))
376 | Ast0.ImplicitInt
(sign) ->
378 all_same opt_allowed
tgt (mcode2line sign) [mcode2arity sign] in
379 let sign = mcode sign in
380 make_typeC typ
tgt arity (Ast0.ImplicitInt
(sign))
381 | Ast0.Pointer
(ty,star
) ->
383 all_same opt_allowed
tgt (mcode2line star
) [mcode2arity star
] in
384 let ty = typeC
arity ty in
385 let star = mcode star in
386 make_typeC typ
tgt arity (Ast0.Pointer
(ty,star))
387 | Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params
,rp2
) ->
389 all_same opt_allowed
tgt (mcode2line lp1
)
390 (List.map
mcode2arity [lp1
;star;rp1
;lp2
;rp2
]) in
391 let ty = typeC
arity ty in
392 let params = parameter_list
tgt params in
393 make_typeC typ
tgt arity
394 (Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params,rp2
))
395 | Ast0.FunctionType
(ty,lp1
,params,rp1
) ->
397 all_same opt_allowed
tgt (mcode2line lp1
)
398 (List.map
mcode2arity [lp1
;rp1
]) in
399 let ty = get_option (typeC
arity) ty in
400 let params = parameter_list
tgt params in
401 make_typeC typ
tgt arity (Ast0.FunctionType
(ty,lp1
,params,rp1
))
402 | Ast0.Array
(ty,lb,size
,rb) ->
404 all_same opt_allowed
tgt (mcode2line lb)
405 [mcode2arity lb;mcode2arity rb] in
406 let ty = typeC
arity ty in
408 let size = get_option (expression
arity) size in
410 make_typeC typ
tgt arity (Ast0.Array
(ty,lb,size,rb))
411 | Ast0.StructUnionName
(kind
,name) ->
413 all_same opt_allowed
tgt (mcode2line kind
)
414 [mcode2arity kind
] in
415 let kind = mcode kind in
416 let name = get_option (ident false arity) name in
417 make_typeC typ
tgt arity (Ast0.StructUnionName
(kind,name))
418 | Ast0.StructUnionDef
(ty,lb,decls
,rb) ->
420 all_same opt_allowed
tgt (mcode2line lb)
421 (List.map
mcode2arity [lb;rb]) in
422 let ty = typeC
arity ty in
424 let decls = dots (declaration
tgt) decls in
426 make_typeC typ
tgt arity (Ast0.StructUnionDef
(ty,lb,decls,rb))
427 | Ast0.TypeName
(name) ->
429 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
430 let name = mcode name in
431 make_typeC typ
tgt arity (Ast0.TypeName
(name))
432 | Ast0.MetaType
(name,pure
) ->
434 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
435 let name = mcode name in
436 make_typeC typ
tgt arity (Ast0.MetaType
(name,pure
))
437 | Ast0.DisjType
(starter
,types
,mids
,ender
) ->
438 let types = List.map
(typeC
tgt) types in
439 (match List.rev
types with
441 if anyopt xs
(function Ast0.OptType
(_
) -> true | _
-> false)
442 then fail typ
"opt only allowed in the last disjunct"
444 let res = Ast0.DisjType
(starter
,types,mids
,ender
) in
446 | Ast0.OptType
(_
) | Ast0.UniqueType
(_
) ->
447 failwith
"unexpected code"
449 and typeC
tgt ty = top_typeC
tgt false ty
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. *)
458 (function x
-> Ast0.OptDecl x
)
459 (function x
-> Ast0.UniqueDecl x
)
461 and declaration
tgt decl
=
462 match Ast0.unwrap decl
with
463 Ast0.Init
(stg
,ty,id
,eq
,exp,sem
) ->
465 all_same true tgt (mcode2line eq
)
466 ((match stg
with None
-> [] | Some x
-> [mcode2arity x
]) @
467 (List.map
mcode2arity [eq
;sem
])) in
468 let stg = get_option mcode stg in
469 let ty = typeC
arity ty in
470 let id = ident false arity id in
472 let exp = initialiser
arity exp in
473 let sem = mcode sem in
474 make_decl decl
tgt arity (Ast0.Init
(stg,ty,id,eq,exp,sem))
475 | Ast0.UnInit
(stg,ty,id,sem) ->
477 all_same true tgt (mcode2line sem)
478 ((match stg with None
-> [] | Some x
-> [mcode2arity x
]) @
479 [mcode2arity sem]) in
480 let stg = get_option mcode stg in
481 let ty = typeC
arity ty in
482 let id = ident false arity id in
483 let sem = mcode sem in
484 make_decl decl
tgt arity (Ast0.UnInit
(stg,ty,id,sem))
485 | Ast0.MacroDecl
(name,lp,args,rp,sem) ->
487 all_same true tgt (mcode2line lp) (List.map
mcode2arity [lp;rp;sem]) in
488 let name = ident false arity name in
490 let args = dots (expression
arity) args in
492 let sem = mcode sem in
493 make_decl decl
tgt arity (Ast0.MacroDecl
(name,lp,args,rp,sem))
494 | Ast0.TyDecl
(ty,sem) ->
496 all_same true tgt (mcode2line sem) [mcode2arity sem] in
497 let ty = typeC
arity ty in
498 let sem = mcode sem in
499 make_decl decl
tgt arity (Ast0.TyDecl
(ty,sem))
500 | Ast0.Typedef
(stg,ty,id,sem) ->
502 all_same true tgt (mcode2line sem)
503 [mcode2arity stg;mcode2arity sem] in
504 let stg = mcode stg in
505 let ty = typeC
arity ty in
506 let id = typeC
arity id in
507 let sem = mcode sem in
508 make_decl decl
tgt arity (Ast0.Typedef
(stg,ty,id,sem))
509 | Ast0.DisjDecl
(starter
,decls,mids
,ender
) ->
510 let decls = List.map
(declaration
tgt) decls in
511 (match List.rev
decls with
513 if anyopt xs
(function Ast0.OptDecl
(_
) -> true | _
-> false)
514 then fail decl
"opt only allowed in the last disjunct"
516 let res = Ast0.DisjDecl
(starter
,decls,mids
,ender
) in
518 | Ast0.Ddots
(dots,whencode) ->
519 let arity = all_same true tgt (mcode2line dots) [mcode2arity dots] in
520 let dots = mcode dots in
521 let whencode = get_option (declaration
Ast0.NONE
) whencode in
522 make_decl decl
tgt arity (Ast0.Ddots
(dots,whencode))
523 | Ast0.OptDecl
(_
) | Ast0.UniqueDecl
(_
) ->
524 failwith
"unexpected code"
526 (* --------------------------------------------------------------------- *)
531 (function x
-> Ast0.OptIni x
)
532 (function x
-> Ast0.UniqueIni x
)
534 and initialiser
tgt i
=
535 let init_same = all_same true tgt in
536 match Ast0.unwrap i
with
537 Ast0.InitExpr
(exp) ->
538 Ast0.rewrap i
(Ast0.InitExpr
(expression
tgt exp))
539 | Ast0.InitList
(lb,initlist
,rb) ->
540 let arity = init_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
542 let initlist = dots (initialiser
arity) initlist in
544 make_init i
tgt arity (Ast0.InitList
(lb,initlist,rb))
545 | Ast0.InitGccDotName
(dot
,name,eq,ini
) ->
547 init_same (mcode2line dot
) [mcode2arity dot
; mcode2arity eq] in
548 let dot = mcode dot in
549 let name = ident true arity name in
551 let ini = initialiser
arity ini in
552 make_init i
tgt arity (Ast0.InitGccDotName
(dot,name,eq,ini))
553 | Ast0.InitGccName
(name,eq,ini) ->
554 let arity = init_same (mcode2line eq) [mcode2arity eq] in
555 let name = ident true arity name in
557 let ini = initialiser
arity ini in
558 make_init i
tgt arity (Ast0.InitGccName
(name,eq,ini))
559 | Ast0.InitGccIndex
(lb,exp,rb,eq,ini) ->
561 init_same (mcode2line lb)
562 [mcode2arity lb; mcode2arity rb; mcode2arity eq] in
564 let exp = expression
arity exp in
567 let ini = initialiser
arity ini in
568 make_init i
tgt arity (Ast0.InitGccIndex
(lb,exp,rb,eq,ini))
569 | Ast0.InitGccRange
(lb,exp1,dots,exp2,rb,eq,ini) ->
571 init_same (mcode2line lb)
572 [mcode2arity lb; mcode2arity dots; mcode2arity rb; mcode2arity eq] in
574 let exp1 = expression
arity exp1 in
575 let dots = mcode dots in
576 let exp2 = expression
arity exp2 in
579 let ini = initialiser
arity ini in
580 make_init i
tgt arity
581 (Ast0.InitGccRange
(lb,exp1,dots,exp2,rb,eq,ini))
583 let arity = init_same (mcode2line cm) [mcode2arity cm] in
585 make_init i
tgt arity (Ast0.IComma
(cm))
586 | Ast0.Idots
(dots,whencode) ->
587 let arity = init_same (mcode2line dots) [mcode2arity dots] in
588 let dots = mcode dots in
589 let whencode = get_option (initialiser
Ast0.NONE
) whencode in
590 make_init i
tgt arity (Ast0.Idots
(dots,whencode))
591 | Ast0.OptIni
(_
) | Ast0.UniqueIni
(_
) ->
592 failwith
"unexpected code"
594 (* --------------------------------------------------------------------- *)
599 (function x
-> Ast0.OptParam x
)
600 (function x
-> Ast0.UniqueParam x
)
602 and parameterTypeDef
tgt param
=
603 let param_same = all_same true tgt in
604 match Ast0.unwrap param
with
605 Ast0.VoidParam
(ty) -> Ast0.rewrap param
(Ast0.VoidParam
(typeC
tgt ty))
606 | Ast0.Param
(ty,Some
id) ->
607 let ty = top_typeC
tgt true ty in
608 let id = ident true tgt id in
610 (match (Ast0.unwrap
ty,Ast0.unwrap
id) with
611 (Ast0.OptType
(ty),Ast0.OptIdent
(id)) ->
612 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
613 | (Ast0.UniqueType
(ty),Ast0.UniqueIdent
(id)) ->
614 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
615 | (Ast0.OptType
(ty),_
) ->
616 fail param
"arity mismatch in param declaration"
617 | (_
,Ast0.OptIdent
(id)) ->
618 fail param
"arity mismatch in param declaration"
619 | _
-> Ast0.Param
(ty,Some
id))
620 | Ast0.Param
(ty,None
) ->
621 let ty = top_typeC
tgt true ty in
623 (match Ast0.unwrap
ty with
625 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
626 | Ast0.UniqueType
(ty) ->
627 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
628 | _
-> Ast0.Param
(ty,None
))
629 | Ast0.MetaParam
(name,pure
) ->
630 let arity = param_same (mcode2line name) [mcode2arity name] in
631 let name = mcode name in
632 make_param param
tgt arity (Ast0.MetaParam
(name,pure
))
633 | Ast0.MetaParamList
(name,lenname
,pure
) ->
634 let arity = param_same (mcode2line name) [mcode2arity name] in
635 let name = mcode name in
636 make_param param
tgt arity (Ast0.MetaParamList
(name,lenname
,pure
))
638 let arity = param_same (mcode2line cm) [mcode2arity cm] in
640 make_param param
tgt arity (Ast0.PComma
(cm))
641 | Ast0.Pdots
(dots) ->
642 let arity = param_same (mcode2line dots) [mcode2arity dots] in
643 let dots = mcode dots in
644 make_param param
tgt arity (Ast0.Pdots
(dots))
645 | Ast0.Pcircles
(dots) ->
646 let arity = param_same (mcode2line dots) [mcode2arity dots] in
647 let dots = mcode dots in
648 make_param param
tgt arity (Ast0.Pcircles
(dots))
649 | Ast0.OptParam
(_
) | Ast0.UniqueParam
(_
) ->
650 failwith
"unexpected code"
652 and parameter_list
tgt = dots (parameterTypeDef
tgt)
654 (* --------------------------------------------------------------------- *)
657 and make_rule_elem x
=
659 (function x
-> Ast0.OptStm x
)
660 (function x
-> Ast0.UniqueStm x
)
663 and statement
tgt stm
=
664 let stm_same = all_same true tgt in
665 match Ast0.unwrap stm
with
666 Ast0.Decl
(bef
,decl
) ->
667 let new_decl = declaration
tgt decl
in
669 (match Ast0.unwrap
new_decl with
670 Ast0.OptDecl
(decl
) ->
671 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
672 | Ast0.UniqueDecl
(decl
) ->
673 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
674 | _
-> Ast0.Decl
(bef
,new_decl))
675 | Ast0.Seq
(lbrace
,body
,rbrace
) ->
677 stm_same (mcode2line lbrace
)
678 [mcode2arity lbrace
; mcode2arity rbrace
] in
679 let lbrace = mcode lbrace in
680 let body = dots (statement
arity) body in
681 let rbrace = mcode rbrace in
682 make_rule_elem stm
tgt arity (Ast0.Seq
(lbrace,body,rbrace))
683 | Ast0.ExprStatement
(exp,sem) ->
684 let arity = stm_same (mcode2line sem) [mcode2arity sem] in
685 let exp = expression
arity exp in
686 let sem = mcode sem in
687 make_rule_elem stm
tgt arity (Ast0.ExprStatement
(exp,sem))
688 | Ast0.IfThen
(iff
,lp,exp,rp,branch
,aft
) ->
690 stm_same (mcode2line iff
) (List.map
mcode2arity [iff
;lp;rp]) in
691 let iff = mcode iff in
693 let exp = expression
arity exp in
695 let branch = statement
arity branch in
696 make_rule_elem stm
tgt arity (Ast0.IfThen
(iff,lp,exp,rp,branch,aft
))
697 | Ast0.IfThenElse
(iff,lp,exp,rp,branch1
,els
,branch2
,aft
) ->
699 stm_same (mcode2line iff) (List.map
mcode2arity [iff;lp;rp;els
]) in
700 let iff = mcode iff in
702 let exp = expression
arity exp in
704 let branch1 = statement
arity branch1 in
705 let els = mcode els in
706 let branch2 = statement
arity branch2 in
707 make_rule_elem stm
tgt arity
708 (Ast0.IfThenElse
(iff,lp,exp,rp,branch1,els,branch2,aft
))
709 | Ast0.While
(wh
,lp,exp,rp,body,aft
) ->
711 stm_same (mcode2line wh
)
712 (List.map
mcode2arity [wh
;lp;rp]) in
715 let exp = expression
arity exp in
717 let body = statement
arity body in
718 make_rule_elem stm
tgt arity (Ast0.While
(wh,lp,exp,rp,body,aft
))
719 | Ast0.Do
(d
,body,wh,lp,exp,rp,sem) ->
721 stm_same (mcode2line wh) (List.map
mcode2arity [d
;wh;lp;rp;sem]) in
723 let body = statement
arity body in
726 let exp = expression
arity exp in
728 let sem = mcode sem in
729 make_rule_elem stm
tgt arity (Ast0.Do
(d,body,wh,lp,exp,rp,sem))
730 | Ast0.For
(fr
,lp,exp1,sem1
,exp2,sem2
,exp3,rp,body,aft
) ->
732 stm_same (mcode2line fr
) (List.map
mcode2arity [fr
;lp;sem1
;sem2
;rp]) in
735 let exp1 = get_option (expression
arity) exp1 in
736 let sem1 = mcode sem1 in
737 let exp2 = get_option (expression
arity) exp2 in
738 let sem2= mcode sem2 in
739 let exp3 = get_option (expression
arity) exp3 in
741 let body = statement
arity body in
742 make_rule_elem stm
tgt arity
743 (Ast0.For
(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft
))
744 | Ast0.Iterator
(nm
,lp,args,rp,body,aft
) ->
745 let arity = stm_same (mcode2line lp) (List.map
mcode2arity [lp;rp]) in
746 let nm = ident false arity nm in
748 let args = dots (expression
arity) args in
750 let body = statement
arity body in
751 make_rule_elem stm
tgt arity (Ast0.Iterator
(nm,lp,args,rp,body,aft
))
752 | Ast0.Switch
(switch
,lp,exp,rp,lb,cases
,rb) ->
754 stm_same (mcode2line switch
)
755 (List.map
mcode2arity [switch
;lp;rp;lb;rb]) in
756 let switch = mcode switch in
758 let exp = expression
arity exp in
761 let cases = dots (case_line
arity) cases in
763 make_rule_elem stm
tgt arity
764 (Ast0.Switch
(switch,lp,exp,rp,lb,cases,rb))
765 | Ast0.Break
(br
,sem) ->
766 let arity = stm_same (mcode2line br
) (List.map
mcode2arity [br
;sem]) in
768 let sem = mcode sem in
769 make_rule_elem stm
tgt arity (Ast0.Break
(br,sem))
770 | Ast0.Continue
(cont
,sem) ->
772 stm_same (mcode2line cont
) (List.map
mcode2arity [cont
;sem]) in
773 let cont = mcode cont in
774 let sem = mcode sem in
775 make_rule_elem stm
tgt arity (Ast0.Continue
(cont,sem))
776 | Ast0.Label
(l,dd
) ->
777 let arity = mcode2arity dd
in
778 let l = ident false tgt l in
780 make_rule_elem stm
tgt arity (Ast0.Label
(l,dd))
781 | Ast0.Goto
(goto
,l,sem) ->
783 stm_same (mcode2line goto
) (List.map
mcode2arity [goto
;sem]) in
784 let goto = mcode goto in
785 let l = ident false tgt l in
786 let sem = mcode sem in
787 make_rule_elem stm
tgt arity (Ast0.Goto
(goto,l,sem))
788 | Ast0.Return
(ret
,sem) ->
789 let arity = stm_same (mcode2line ret
) (List.map
mcode2arity [ret
;sem]) in
790 let ret = mcode ret in
791 let sem = mcode sem in
792 make_rule_elem stm
tgt arity (Ast0.Return
(ret,sem))
793 | Ast0.ReturnExpr
(ret,exp,sem) ->
794 let arity = stm_same (mcode2line ret) (List.map
mcode2arity [ret;sem]) in
795 let ret = mcode ret in
796 let exp = expression
arity exp in
797 let sem = mcode sem in
798 make_rule_elem stm
tgt arity (Ast0.ReturnExpr
(ret,exp,sem))
799 | Ast0.MetaStmt
(name,pure
) ->
800 let arity = stm_same (mcode2line name) [mcode2arity name] in
801 let name = mcode name in
802 make_rule_elem stm
tgt arity (Ast0.MetaStmt
(name,pure
))
803 | Ast0.MetaStmtList
(name,pure
) ->
804 let arity = stm_same (mcode2line name) [mcode2arity name] in
805 let name = mcode name in
806 make_rule_elem stm
tgt arity (Ast0.MetaStmtList
(name,pure
))
808 let new_exp = top_expression true tgt exp in
810 (match Ast0.unwrap
new_exp with
812 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
813 | Ast0.UniqueExp
(exp) ->
814 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
815 | _
-> Ast0.Exp
(new_exp))
816 | Ast0.TopExp
(exp) ->
817 let new_exp = top_expression true tgt exp in
819 (match Ast0.unwrap
new_exp with
821 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
822 | Ast0.UniqueExp
(exp) ->
823 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
824 | _
-> Ast0.TopExp
(new_exp))
826 let new_ty = typeC
tgt ty in (* opt makes no sense alone at top level *)
828 (match Ast0.unwrap
new_ty with
830 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
831 | Ast0.UniqueType
(ty) ->
832 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
833 | _
-> Ast0.Ty
(new_ty))
834 | Ast0.Disj
(starter
,rule_elem_dots_list
,mids
,ender
) ->
836 List.map
(function x
-> concat_dots (statement
tgt) x
)
837 rule_elem_dots_list
in
838 let (found_opt
,unopt
) =
840 (function (found_opt
,lines
) ->
843 (* previously just checked the last thing in the list,
844 but everything should be optional for the whole thing to
847 match Ast0.unwrap x
with
848 Ast0.OptStm
(x
) -> true
851 match Ast0.unwrap x
with
854 if List.for_all
is_opt l
855 then (true,List.map
unopt l)
858 match Ast0.unwrap x
with
860 (l,function l -> Ast0.rewrap x
(Ast0.DOTS
l))
862 (l,function l -> Ast0.rewrap x
(Ast0.CIRCLES
l))
864 (l,function l -> Ast0.rewrap x
(Ast0.STARS
l)) in
865 let (found_opt
,l) = rebuild l in
866 (found_opt
,(k
l)::lines
))
868 let unopt = List.rev
unopt in
871 make_rule_elem stm
tgt Ast0.OPT
(Ast0.Disj
(starter
,unopt,mids
,ender
))
872 else Ast0.rewrap stm
(Ast0.Disj
(starter
,stms,mids
,ender
))
873 | Ast0.Nest
(starter
,rule_elem_dots
,ender
,whn
,multi
) ->
874 let new_rule_elem_dots =
875 concat_dots (statement
Ast0.NONE
) rule_elem_dots
in
878 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
))
881 (Ast0.Nest
(starter
,new_rule_elem_dots,ender
,whn,multi
))
882 | Ast0.Dots
(dots,whn) ->
883 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
884 let dots = mcode dots in
887 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
))
889 make_rule_elem stm
tgt arity (Ast0.Dots
(dots,whn))
890 | Ast0.Circles
(dots,whn) ->
891 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
892 let dots = mcode dots in
895 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
))
897 make_rule_elem stm
tgt arity (Ast0.Circles
(dots,whn))
898 | Ast0.Stars
(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
))
905 make_rule_elem stm
tgt arity (Ast0.Stars
(dots,whn))
906 | Ast0.FunDecl
(bef
,fi
,name,lp,params,rp,lbrace,body,rbrace) ->
908 all_same true tgt (mcode2line lp)
909 ((List.map
mcode2arity [lp;rp;lbrace;rbrace]) @ (fninfo2arity fi
)) in
910 let fi = List.map
(fninfo
arity) fi in
911 let name = ident false arity name in
913 let params = parameter_list
arity params in
915 let lbrace = mcode lbrace in
916 let body = dots (statement
arity) body in
917 let rbrace = mcode rbrace in
918 make_rule_elem stm
tgt arity
919 (Ast0.FunDecl
(bef
,fi,name,lp,params,rp,lbrace,body,rbrace))
920 | Ast0.Include
(inc
,s
) ->
922 all_same true tgt (mcode2line inc
) [mcode2arity inc
; mcode2arity s
] in
923 let inc = mcode inc in
925 make_rule_elem stm
tgt arity (Ast0.Include
(inc,s))
926 | Ast0.Define
(def
,id,params,body) ->
927 let arity = all_same true tgt (mcode2line def
) [mcode2arity def
] in
928 let def = mcode def in
929 let id = ident false arity id in
930 let params = define_parameters
arity params in
931 let body = dots (statement
arity) body in
932 make_rule_elem stm
tgt arity (Ast0.Define
(def,id,params,body))
933 | Ast0.OptStm
(_
) | Ast0.UniqueStm
(_
) ->
934 failwith
"unexpected code"
936 and define_parameters
tgt params =
937 match Ast0.unwrap
params with
938 Ast0.NoParams
-> params
939 | Ast0.DParams
(lp,params,rp) ->
941 all_same true tgt (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
943 let params = dots (define_param
arity) params in
945 Ast0.rewrap
params (Ast0.DParams
(lp,params,rp))
947 and make_define_param x
=
949 (function x
-> Ast0.OptDParam x
)
950 (function x
-> Ast0.UniqueDParam x
)
953 and define_param
tgt param
=
954 match Ast0.unwrap param
with
956 let new_id = ident true tgt id in
958 (match Ast0.unwrap
new_id with
960 Ast0.OptDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
961 | Ast0.UniqueIdent
(decl
) ->
962 Ast0.UniqueDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
963 | _
-> Ast0.DParam
(new_id))
964 | Ast0.DPComma
(cm) ->
966 all_same true tgt (mcode2line cm) [mcode2arity cm] in
968 make_define_param param
tgt arity (Ast0.DPComma
(cm))
969 | Ast0.DPdots
(dots) ->
971 all_same true tgt (mcode2line dots) [mcode2arity dots] in
972 let dots = mcode dots in
973 make_define_param param
tgt arity (Ast0.DPdots
(dots))
974 | Ast0.DPcircles
(circles
) ->
976 all_same true tgt (mcode2line circles
) [mcode2arity circles
] in
977 let circles = mcode circles in
978 make_define_param param
tgt arity (Ast0.DPcircles
(circles))
979 | Ast0.OptDParam
(dp
) | Ast0.UniqueDParam
(dp
) ->
980 failwith
"unexpected code"
982 and fninfo
arity = function
983 Ast0.FStorage
(stg) -> Ast0.FStorage
(mcode stg)
984 | Ast0.FType
(ty) -> Ast0.FType
(typeC
arity ty)
985 | Ast0.FInline
(inline
) -> Ast0.FInline
(mcode inline
)
986 | Ast0.FAttr
(attr
) -> Ast0.FAttr
(mcode attr
)
988 and fninfo2arity fninfo
=
992 Ast0.FStorage
(stg) -> [mcode2arity stg]
993 | Ast0.FType
(ty) -> []
994 | Ast0.FInline
(inline
) -> [mcode2arity inline
]
995 | Ast0.FAttr
(attr
) -> [mcode2arity attr
])
998 and whencode notfn alwaysfn
= function
999 Ast0.WhenNot a
-> Ast0.WhenNot
(notfn a
)
1000 | Ast0.WhenAlways a
-> Ast0.WhenAlways
(alwaysfn a
)
1001 | Ast0.WhenModifier
(x
) -> Ast0.WhenModifier
(x
)
1003 and make_case_line
=
1005 (function x
-> Ast0.OptCase x
)
1006 (function x
-> failwith
"unique not allowed for case_line")
1008 and case_line
tgt c
=
1009 match Ast0.unwrap c
with
1010 Ast0.Default
(def,colon,code
) ->
1012 all_same true tgt (mcode2line def)
1013 [mcode2arity def; mcode2arity colon] in
1014 let def = mcode def in
1015 let colon = mcode colon in
1016 let code = dots (statement
arity) code in
1017 make_case_line c
tgt arity (Ast0.Default
(def,colon,code))
1018 | Ast0.Case
(case
,exp,colon,code) ->
1020 all_same true tgt (mcode2line case
)
1021 [mcode2arity case
; mcode2arity colon] in
1022 let case = mcode case in
1023 let exp = expression
arity exp in
1024 let colon = mcode colon in
1025 let code = dots (statement
arity) code in
1026 make_case_line c
tgt arity (Ast0.Case
(case,exp,colon,code))
1027 | Ast0.OptCase
(_
) -> failwith
"unexpected OptCase"
1029 (* --------------------------------------------------------------------- *)
1030 (* Function declaration *)
1031 (* Haven't thought much about arity here... *)
1033 let top_level tgt t
=
1035 (match Ast0.unwrap t
with
1036 Ast0.FILEINFO
(old_file
,new_file
) ->
1037 if mcode2arity old_file
= Ast0.NONE
&& mcode2arity new_file
= Ast0.NONE
1038 then Ast0.FILEINFO
(mcode old_file
,mcode new_file
)
1039 else fail t
"unexpected arity for file info"
1040 | Ast0.DECL
(stmt
) ->
1041 Ast0.DECL
(statement
tgt stmt
)
1042 | Ast0.CODE
(rule_elem_dots
) ->
1043 Ast0.CODE
(concat_dots (statement
tgt) rule_elem_dots
)
1044 | Ast0.ERRORWORDS
(exps) ->
1045 Ast0.ERRORWORDS
(List.map
(top_expression false Ast0.NONE
) exps)
1046 | Ast0.OTHER
(_
) -> fail t
"eliminated by top_level")
1048 let rule tgt = List.map
(top_level tgt)
1050 (* --------------------------------------------------------------------- *)
1053 let minus_arity code =