1 (* Arities matter for the minus slice, but not for the plus slice. *)
3 (* ? only allowed on rule_elems, and on subterms if the context is ? also. *)
5 module Ast0
= Ast0_cocci
8 (* --------------------------------------------------------------------- *)
10 let warning s
= Printf.printf
"warning: %s\n" s
14 (Printf.sprintf
"cocci line %d: %s"
15 ((Ast0.get_info w
).Ast0.pos_info
.Ast0.line_start
)
18 let make_opt_unique optfn uniquefn info tgt arity term
=
19 let term = Ast0.rewrap info
term in
22 else (* tgt must be NONE *)
24 Ast0.OPT
-> Ast0.copywrap info
(optfn
term)
25 | Ast0.UNIQUE
-> Ast0.copywrap info
(uniquefn
term)
26 | Ast0.NONE
-> failwith
"tgt must be NONE"
28 let all_same opt_allowed tgt line arities
=
32 (match List.hd arities
with
33 Ast0.OPT
when not opt_allowed
->
34 failwith
"opt only allowed for the elements of a statement list"
37 if not
(List.for_all
(function x
-> x
= tgt) arities
)
38 then warning (Printf.sprintf
"incompatible arity found on line %d" line
);
41 let get_option fn
= function
43 | Some x
-> Some
(fn x
)
45 let anyopt l fn
= List.exists
(function w
-> fn
(Ast0.unwrap w
)) l
48 let rec loop = function
51 match fn
(Ast0.unwrap x
) with
52 Some x
-> x
:: (loop xs
)
55 if List.length
res = List.length l
then Some
res else None
57 (* --------------------------------------------------------------------- *)
58 (* --------------------------------------------------------------------- *)
61 let mcode2line (_
,_
,info
,_
,_
,_
) = info
.Ast0.pos_info
.Ast0.line_start
62 let mcode2arity (_
,arity
,_
,_
,_
,_
) = arity
64 let mcode x
= x
(* nothing to do ... *)
66 (* --------------------------------------------------------------------- *)
71 (match Ast0.unwrap d
with
72 Ast0.DOTS
(x
) -> Ast0.DOTS
(List.map fn x
)
73 | Ast0.CIRCLES
(x
) -> Ast0.CIRCLES
(List.map fn x
)
74 | Ast0.STARS
(x
) -> Ast0.STARS
(List.map fn x
))
80 match Ast0.unwrap x
with
81 Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> true
88 match Ast0.unwrap x
with
89 Ast0.Dots
(_
,_
) | Ast0.Stars
(_
,_
) -> true
96 match Ast0.unwrap x
with
97 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) -> true
101 let concat_dots fn d
=
103 (match Ast0.unwrap d
with
105 let l = List.map fn x
in
108 else fail d
"inconsistent dots usage"
110 let l = List.map fn x
in
113 else fail d
"inconsistent dots usage"
115 let l = List.map fn x
in
118 else fail d
"inconsistent dots usage")
120 let flat_concat_dots fn d
=
121 match Ast0.unwrap d
with
122 Ast0.DOTS
(x
) -> List.map fn x
123 | Ast0.CIRCLES
(x
) -> List.map fn x
124 | Ast0.STARS
(x
) -> List.map fn x
126 (* --------------------------------------------------------------------- *)
131 (function x
-> Ast0.OptIdent x
)
132 (function x
-> Ast0.UniqueIdent x
)
134 let ident opt_allowed
tgt i
=
135 match Ast0.unwrap i
with
138 all_same opt_allowed
tgt (mcode2line name
)
139 [mcode2arity name
] in
140 let name = mcode name in
141 make_id i
tgt arity (Ast0.Id
(name))
142 | Ast0.MetaId
(name,constraints
,pure
) ->
144 all_same opt_allowed
tgt (mcode2line name)
145 [mcode2arity name] in
146 let name = mcode name in
147 make_id i
tgt arity (Ast0.MetaId
(name,constraints
,pure
))
148 | Ast0.MetaFunc
(name,constraints
,pure
) ->
150 all_same opt_allowed
tgt (mcode2line name)
151 [mcode2arity name] in
152 let name = mcode name in
153 make_id i
tgt arity (Ast0.MetaFunc
(name,constraints
,pure
))
154 | Ast0.MetaLocalFunc
(name,constraints
,pure
) ->
156 all_same opt_allowed
tgt (mcode2line name)
157 [mcode2arity name] in
158 let name = mcode name in
159 make_id i
tgt arity (Ast0.MetaLocalFunc
(name,constraints
,pure
))
160 | Ast0.OptIdent
(_
) | Ast0.UniqueIdent
(_
) ->
161 failwith
"unexpected code"
163 (* --------------------------------------------------------------------- *)
168 (function x
-> Ast0.OptExp x
)
169 (function x
-> Ast0.UniqueExp x
)
171 let rec top_expression opt_allowed
tgt expr
=
172 let exp_same = all_same opt_allowed
tgt in
173 match Ast0.unwrap expr
with
175 let new_id = ident opt_allowed
tgt id
in
177 (match Ast0.unwrap
new_id with
179 Ast0.OptExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
180 | Ast0.UniqueIdent
(id
) ->
181 Ast0.UniqueExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
182 | _
-> Ast0.Ident
(new_id))
183 | Ast0.Constant
(const
) ->
184 let arity = exp_same (mcode2line const
) [mcode2arity const
] in
185 let const = mcode const in
186 make_exp expr
tgt arity (Ast0.Constant
(const))
187 | Ast0.FunCall
(fn
,lp
,args
,rp
) ->
188 let arity = exp_same (mcode2line lp
) [mcode2arity lp
;mcode2arity rp
] in
189 let fn = expression
arity fn in
191 let args = dots (expression
arity) args in
193 make_exp expr
tgt arity (Ast0.FunCall
(fn,lp,args,rp))
194 | Ast0.Assignment
(left
,op
,right
,simple
) ->
195 let arity = exp_same (mcode2line op
) [mcode2arity op
] in
196 let left = expression
arity left in
198 let right = expression
arity right in
199 make_exp expr
tgt arity (Ast0.Assignment
(left,op,right,simple
))
200 | Ast0.CondExpr
(exp1
,why
,exp2
,colon
,exp3
) ->
202 exp_same (mcode2line why
) [mcode2arity why
; mcode2arity colon
] in
203 let exp1 = expression
arity exp1 in
204 let why = mcode why in
205 let exp2 = get_option (expression
arity) exp2 in
206 let colon = mcode colon in
207 let exp3 = expression
arity exp3 in
208 make_exp expr
tgt arity (Ast0.CondExpr
(exp1,why,exp2,colon,exp3))
209 | Ast0.Postfix
(exp
,op) ->
210 let arity = exp_same (mcode2line op) [mcode2arity op] in
211 let exp = expression
arity exp in
213 make_exp expr
tgt arity (Ast0.Postfix
(exp,op))
214 | Ast0.Infix
(exp,op) ->
215 let arity = exp_same (mcode2line op) [mcode2arity op] in
216 let exp = expression
arity exp in
218 make_exp expr
tgt arity (Ast0.Infix
(exp,op))
219 | Ast0.Unary
(exp,op) ->
220 let arity = exp_same (mcode2line op) [mcode2arity op] in
221 let exp = expression
arity exp in
223 make_exp expr
tgt arity (Ast0.Unary
(exp,op))
224 | Ast0.Binary
(left,op,right) ->
225 let arity = exp_same (mcode2line op) [mcode2arity op] in
226 let left = expression
arity left in
228 let right = expression
arity right in
229 make_exp expr
tgt arity (Ast0.Binary
(left,op,right))
230 | Ast0.Nested
(left,op,right) -> failwith
"nested in arity not possible"
231 | Ast0.Paren
(lp,exp,rp) ->
232 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
234 let exp = expression
arity exp in
236 make_exp expr
tgt arity (Ast0.Paren
(lp,exp,rp))
237 | Ast0.ArrayAccess
(exp1,lb
,exp2,rb
) ->
238 let arity = exp_same (mcode2line lb
) [mcode2arity lb
; mcode2arity rb
] in
239 let exp1 = expression
arity exp1 in
241 let exp2 = expression
arity exp2 in
243 make_exp expr
tgt arity (Ast0.ArrayAccess
(exp1,lb,exp2,rb))
244 | Ast0.RecordAccess
(exp,pt
,field
) ->
245 let arity = exp_same (mcode2line pt
) [mcode2arity pt
] in
246 let exp = expression
arity exp in
248 let field = ident false arity field in
249 make_exp expr
tgt arity (Ast0.RecordAccess
(exp,pt,field))
250 | Ast0.RecordPtAccess
(exp,ar
,field) ->
251 let arity = exp_same (mcode2line ar
) [mcode2arity ar
] in
252 let exp = expression
arity exp in
254 let field = ident false arity field in
255 make_exp expr
tgt arity (Ast0.RecordPtAccess
(exp,ar,field))
256 | Ast0.Cast
(lp,ty
,rp,exp) ->
257 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
259 let ty = typeC
arity ty in
261 let exp = expression
arity exp in
262 make_exp expr
tgt arity (Ast0.Cast
(lp,ty,rp,exp))
263 | Ast0.SizeOfExpr
(szf
,exp) ->
264 let arity = exp_same (mcode2line szf
) [mcode2arity szf
] in
265 let szf = mcode szf in
266 let exp = expression
arity exp in
267 make_exp expr
tgt arity (Ast0.SizeOfExpr
(szf,exp))
268 | Ast0.SizeOfType
(szf,lp,ty,rp) ->
270 exp_same (mcode2line szf) (List.map
mcode2arity [szf;lp;rp]) in
271 let szf = mcode szf in
273 let ty = typeC
arity ty in
275 make_exp expr
tgt arity (Ast0.SizeOfType
(szf,lp,ty,rp))
276 | Ast0.TypeExp
(ty) -> Ast0.rewrap expr
(Ast0.TypeExp
(typeC
tgt ty))
277 | Ast0.MetaErr
(name,constraints
,pure
) ->
278 let arity = exp_same (mcode2line name) [mcode2arity name] in
279 let name = mcode name in
280 make_exp expr
tgt arity (Ast0.MetaErr
(name,constraints
,pure
))
281 | Ast0.MetaExpr
(name,constraints
,ty,form
,pure
) ->
282 let arity = exp_same (mcode2line name) [mcode2arity name] in
283 let name = mcode name in
284 make_exp expr
tgt arity (Ast0.MetaExpr
(name,constraints
,ty,form
,pure
))
285 | Ast0.MetaExprList
(name,lenname
,pure
) ->
286 let arity = exp_same (mcode2line name) [mcode2arity name] in
287 let name = mcode name in
288 make_exp expr
tgt arity (Ast0.MetaExprList
(name,lenname
,pure
))
290 let arity = exp_same (mcode2line cm
) [mcode2arity cm
] in
292 make_exp expr
tgt arity (Ast0.EComma
(cm))
293 | Ast0.DisjExpr
(starter
,exps
,mids
,ender
) ->
294 let exps = List.map
(top_expression opt_allowed
tgt) exps in
295 (match List.rev
exps with
297 if anyopt xs
(function Ast0.OptExp
(_
) -> true | _
-> false)
298 then fail expr
"opt only allowed in the last disjunct"
300 Ast0.rewrap expr
(Ast0.DisjExpr
(starter
,exps,mids
,ender
))
301 | Ast0.NestExpr
(starter
,exp_dots
,ender
,whencode
,multi
) ->
303 Ast0.NestExpr
(starter
,
304 dots (top_expression true Ast0.NONE
) exp_dots
,
305 ender
,whencode
,multi
) in
307 | Ast0.Edots
(dots,whencode
) ->
308 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
309 let dots = mcode dots in
310 let whencode = get_option (expression
Ast0.NONE
) whencode in
311 make_exp expr
tgt arity (Ast0.Edots
(dots,whencode))
312 | Ast0.Ecircles
(dots,whencode) ->
313 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
314 let dots = mcode dots in
315 let whencode = get_option (expression
Ast0.NONE
) whencode in
316 make_exp expr
tgt arity (Ast0.Ecircles
(dots,whencode))
317 | Ast0.Estars
(dots,whencode) ->
318 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
319 let dots = mcode dots in
320 let whencode = get_option (expression
Ast0.NONE
) whencode in
321 make_exp expr
tgt arity (Ast0.Estars
(dots,whencode))
322 (* why does optexp exist???? *)
323 | Ast0.OptExp
(_
) | Ast0.UniqueExp
(_
) ->
324 failwith
"unexpected code"
326 and expression
tgt exp = top_expression false tgt exp
328 (* --------------------------------------------------------------------- *)
333 (function x
-> Ast0.OptType x
)
334 (function x
-> Ast0.UniqueType x
)
336 and top_typeC
tgt opt_allowed typ
=
337 match Ast0.unwrap typ
with
338 Ast0.ConstVol
(cv
,ty) ->
339 let arity = all_same opt_allowed
tgt (mcode2line cv
)
342 let ty = typeC
arity ty in
343 make_typeC typ
tgt arity (Ast0.ConstVol
(cv,ty))
344 | Ast0.BaseType
(ty,strings
) ->
346 all_same opt_allowed
tgt (mcode2line (List.hd strings
))
347 (List.map
mcode2arity strings
) in
348 let strings = List.map
mcode strings in
349 make_typeC typ
tgt arity (Ast0.BaseType
(ty,strings))
350 | Ast0.Signed
(sign
,ty) ->
352 all_same opt_allowed
tgt (mcode2line sign
) [mcode2arity sign
] in
353 let sign = mcode sign in
354 let ty = get_option (typeC
arity) ty in
355 make_typeC typ
tgt arity (Ast0.Signed
(sign,ty))
356 | Ast0.Pointer
(ty,star
) ->
358 all_same opt_allowed
tgt (mcode2line star
) [mcode2arity star
] in
359 let ty = typeC
arity ty in
360 let star = mcode star in
361 make_typeC typ
tgt arity (Ast0.Pointer
(ty,star))
362 | Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params
,rp2
) ->
364 all_same opt_allowed
tgt (mcode2line lp1
)
365 (List.map
mcode2arity [lp1
;star;rp1
;lp2
;rp2
]) in
366 let ty = typeC
arity ty in
367 let params = parameter_list
tgt params in
368 make_typeC typ
tgt arity
369 (Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params,rp2
))
370 | Ast0.FunctionType
(ty,lp1
,params,rp1
) ->
372 all_same opt_allowed
tgt (mcode2line lp1
)
373 (List.map
mcode2arity [lp1
;rp1
]) in
374 let ty = get_option (typeC
arity) ty in
375 let params = parameter_list
tgt params in
376 make_typeC typ
tgt arity (Ast0.FunctionType
(ty,lp1
,params,rp1
))
377 | Ast0.Array
(ty,lb,size
,rb) ->
379 all_same opt_allowed
tgt (mcode2line lb)
380 [mcode2arity lb;mcode2arity rb] in
381 let ty = typeC
arity ty in
383 let size = get_option (expression
arity) size in
385 make_typeC typ
tgt arity (Ast0.Array
(ty,lb,size,rb))
386 | Ast0.EnumName
(kind
,name) ->
388 all_same opt_allowed
tgt (mcode2line kind
) [mcode2arity kind
] in
389 let kind = mcode kind in
390 let name = ident false arity name in
391 make_typeC typ
tgt arity (Ast0.EnumName
(kind,name))
392 | Ast0.StructUnionName
(kind,name) ->
394 all_same opt_allowed
tgt (mcode2line kind)
395 [mcode2arity kind] in
396 let kind = mcode kind in
397 let name = get_option (ident false arity) name in
398 make_typeC typ
tgt arity (Ast0.StructUnionName
(kind,name))
399 | Ast0.StructUnionDef
(ty,lb,decls
,rb) ->
401 all_same opt_allowed
tgt (mcode2line lb)
402 (List.map
mcode2arity [lb;rb]) in
403 let ty = typeC
arity ty in
405 let decls = dots (declaration
tgt) decls in
407 make_typeC typ
tgt arity (Ast0.StructUnionDef
(ty,lb,decls,rb))
408 | Ast0.TypeName
(name) ->
410 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
411 let name = mcode name in
412 make_typeC typ
tgt arity (Ast0.TypeName
(name))
413 | Ast0.MetaType
(name,pure
) ->
415 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
416 let name = mcode name in
417 make_typeC typ
tgt arity (Ast0.MetaType
(name,pure
))
418 | Ast0.DisjType
(starter
,types
,mids
,ender
) ->
419 let types = List.map
(typeC
tgt) types in
420 (match List.rev
types with
422 if anyopt xs
(function Ast0.OptType
(_
) -> true | _
-> false)
423 then fail typ
"opt only allowed in the last disjunct"
425 let res = Ast0.DisjType
(starter
,types,mids
,ender
) in
427 | Ast0.OptType
(_
) | Ast0.UniqueType
(_
) ->
428 failwith
"unexpected code"
430 and typeC
tgt ty = top_typeC
tgt false ty
432 (* --------------------------------------------------------------------- *)
433 (* Variable declaration *)
434 (* Even if the Cocci program specifies a list of declarations, they are
435 split out into multiple declarations of a single variable each. *)
439 (function x
-> Ast0.OptDecl x
)
440 (function x
-> Ast0.UniqueDecl x
)
442 and declaration
tgt decl
=
443 match Ast0.unwrap decl
with
444 Ast0.Init
(stg
,ty,id
,eq
,exp,sem
) ->
446 all_same true tgt (mcode2line eq
)
447 ((match stg
with None
-> [] | Some x
-> [mcode2arity x
]) @
448 (List.map
mcode2arity [eq
;sem
])) in
449 let stg = get_option mcode stg in
450 let ty = typeC
arity ty in
451 let id = ident false arity id in
453 let exp = initialiser
arity exp in
454 let sem = mcode sem in
455 make_decl decl
tgt arity (Ast0.Init
(stg,ty,id,eq,exp,sem))
456 | Ast0.UnInit
(stg,ty,id,sem) ->
458 all_same true tgt (mcode2line sem)
459 ((match stg with None
-> [] | Some x
-> [mcode2arity x
]) @
460 [mcode2arity sem]) in
461 let stg = get_option mcode stg in
462 let ty = typeC
arity ty in
463 let id = ident false arity id in
464 let sem = mcode sem in
465 make_decl decl
tgt arity (Ast0.UnInit
(stg,ty,id,sem))
466 | Ast0.MacroDecl
(name,lp,args,rp,sem) ->
468 all_same true tgt (mcode2line lp) (List.map
mcode2arity [lp;rp;sem]) in
469 let name = ident false arity name in
471 let args = dots (expression
arity) args in
473 let sem = mcode sem in
474 make_decl decl
tgt arity (Ast0.MacroDecl
(name,lp,args,rp,sem))
475 | Ast0.TyDecl
(ty,sem) ->
477 all_same true tgt (mcode2line sem) [mcode2arity sem] in
478 let ty = typeC
arity ty in
479 let sem = mcode sem in
480 make_decl decl
tgt arity (Ast0.TyDecl
(ty,sem))
481 | Ast0.Typedef
(stg,ty,id,sem) ->
483 all_same true tgt (mcode2line sem)
484 [mcode2arity stg;mcode2arity sem] in
485 let stg = mcode stg in
486 let ty = typeC
arity ty in
487 let id = typeC
arity id in
488 let sem = mcode sem in
489 make_decl decl
tgt arity (Ast0.Typedef
(stg,ty,id,sem))
490 | Ast0.DisjDecl
(starter
,decls,mids
,ender
) ->
491 let decls = List.map
(declaration
tgt) decls in
492 (match List.rev
decls with
494 if anyopt xs
(function Ast0.OptDecl
(_
) -> true | _
-> false)
495 then fail decl
"opt only allowed in the last disjunct"
497 let res = Ast0.DisjDecl
(starter
,decls,mids
,ender
) in
499 | Ast0.Ddots
(dots,whencode) ->
500 let arity = all_same true tgt (mcode2line dots) [mcode2arity dots] in
501 let dots = mcode dots in
502 let whencode = get_option (declaration
Ast0.NONE
) whencode in
503 make_decl decl
tgt arity (Ast0.Ddots
(dots,whencode))
504 | Ast0.OptDecl
(_
) | Ast0.UniqueDecl
(_
) ->
505 failwith
"unexpected code"
507 (* --------------------------------------------------------------------- *)
512 (function x
-> Ast0.OptIni x
)
513 (function x
-> Ast0.UniqueIni x
)
515 and initialiser
tgt i
=
516 let init_same = all_same true tgt in
517 match Ast0.unwrap i
with
518 Ast0.MetaInit
(name,pure
) ->
519 let arity = init_same (mcode2line name) [mcode2arity name] in
520 let name = mcode name in
521 make_init i
tgt arity (Ast0.MetaInit
(name,pure
))
522 | Ast0.InitExpr
(exp) ->
523 Ast0.rewrap i
(Ast0.InitExpr
(expression
tgt exp))
524 | Ast0.InitList
(lb,initlist
,rb) ->
525 let arity = init_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
527 let initlist = dots (initialiser
arity) initlist in
529 make_init i
tgt arity (Ast0.InitList
(lb,initlist,rb))
530 | Ast0.InitGccExt
(designators
,eq,ini
) ->
531 let arity = init_same (mcode2line eq) [mcode2arity eq] in
532 let designators = List.map
(designator
arity) designators in
534 let ini = initialiser
arity ini in
535 make_init i
tgt arity (Ast0.InitGccExt
(designators,eq,ini))
536 | Ast0.InitGccName
(name,eq,ini) ->
537 let arity = init_same (mcode2line eq) [mcode2arity eq] in
538 let name = ident true arity name in
540 let ini = initialiser
arity ini in
541 make_init i
tgt arity (Ast0.InitGccName
(name,eq,ini))
543 let arity = init_same (mcode2line cm) [mcode2arity cm] in
545 make_init i
tgt arity (Ast0.IComma
(cm))
546 | Ast0.Idots
(dots,whencode) ->
547 let arity = init_same (mcode2line dots) [mcode2arity dots] in
548 let dots = mcode dots in
549 let whencode = get_option (initialiser
Ast0.NONE
) whencode in
550 make_init i
tgt arity (Ast0.Idots
(dots,whencode))
551 | Ast0.OptIni
(_
) | Ast0.UniqueIni
(_
) ->
552 failwith
"unexpected code"
554 and designator
tgt d
=
555 let dsame = all_same false tgt in
557 Ast0.DesignatorField
(dot
,id) ->
558 let arity = dsame (mcode2line dot
) [mcode2arity dot
] in
559 let dot = mcode dot in
560 let id = ident false arity id in
561 Ast0.DesignatorField
(dot,id)
562 | Ast0.DesignatorIndex
(lb,exp,rb) ->
563 let arity = dsame (mcode2line lb) [mcode2arity lb;mcode2arity rb] in
565 let exp = top_expression false arity exp in
567 Ast0.DesignatorIndex
(lb,exp,rb)
568 | Ast0.DesignatorRange
(lb,min
,dots,max
,rb) ->
570 dsame (mcode2line lb)
571 [mcode2arity lb;mcode2arity dots;mcode2arity rb] in
573 let min = top_expression false arity min in
574 let dots = mcode dots in
575 let max = top_expression false arity max in
577 Ast0.DesignatorRange
(lb,min,dots,max,rb)
579 (* --------------------------------------------------------------------- *)
584 (function x
-> Ast0.OptParam x
)
585 (function x
-> Ast0.UniqueParam x
)
587 and parameterTypeDef
tgt param
=
588 let param_same = all_same true tgt in
589 match Ast0.unwrap param
with
590 Ast0.VoidParam
(ty) -> Ast0.rewrap param
(Ast0.VoidParam
(typeC
tgt ty))
591 | Ast0.Param
(ty,Some
id) ->
592 let ty = top_typeC
tgt true ty in
593 let id = ident true tgt id in
595 (match (Ast0.unwrap
ty,Ast0.unwrap
id) with
596 (Ast0.OptType
(ty),Ast0.OptIdent
(id)) ->
597 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
598 | (Ast0.UniqueType
(ty),Ast0.UniqueIdent
(id)) ->
599 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
600 | (Ast0.OptType
(ty),_
) ->
601 fail param
"arity mismatch in param declaration"
602 | (_
,Ast0.OptIdent
(id)) ->
603 fail param
"arity mismatch in param declaration"
604 | _
-> Ast0.Param
(ty,Some
id))
605 | Ast0.Param
(ty,None
) ->
606 let ty = top_typeC
tgt true ty in
608 (match Ast0.unwrap
ty with
610 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
611 | Ast0.UniqueType
(ty) ->
612 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
613 | _
-> Ast0.Param
(ty,None
))
614 | Ast0.MetaParam
(name,pure
) ->
615 let arity = param_same (mcode2line name) [mcode2arity name] in
616 let name = mcode name in
617 make_param param
tgt arity (Ast0.MetaParam
(name,pure
))
618 | Ast0.MetaParamList
(name,lenname
,pure
) ->
619 let arity = param_same (mcode2line name) [mcode2arity name] in
620 let name = mcode name in
621 make_param param
tgt arity (Ast0.MetaParamList
(name,lenname
,pure
))
623 let arity = param_same (mcode2line cm) [mcode2arity cm] in
625 make_param param
tgt arity (Ast0.PComma
(cm))
626 | Ast0.Pdots
(dots) ->
627 let arity = param_same (mcode2line dots) [mcode2arity dots] in
628 let dots = mcode dots in
629 make_param param
tgt arity (Ast0.Pdots
(dots))
630 | Ast0.Pcircles
(dots) ->
631 let arity = param_same (mcode2line dots) [mcode2arity dots] in
632 let dots = mcode dots in
633 make_param param
tgt arity (Ast0.Pcircles
(dots))
634 | Ast0.OptParam
(_
) | Ast0.UniqueParam
(_
) ->
635 failwith
"unexpected code"
637 and parameter_list
tgt = dots (parameterTypeDef
tgt)
639 (* --------------------------------------------------------------------- *)
642 and make_rule_elem x
=
644 (function x
-> Ast0.OptStm x
)
645 (function x
-> Ast0.UniqueStm x
)
648 and statement
tgt stm
=
649 let stm_same = all_same true tgt in
650 match Ast0.unwrap stm
with
651 Ast0.Decl
(bef
,decl
) ->
652 let new_decl = declaration
tgt decl
in
654 (match Ast0.unwrap
new_decl with
655 Ast0.OptDecl
(decl
) ->
656 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
657 | Ast0.UniqueDecl
(decl
) ->
658 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
659 | _
-> Ast0.Decl
(bef
,new_decl))
660 | Ast0.Seq
(lbrace
,body
,rbrace
) ->
662 stm_same (mcode2line lbrace
)
663 [mcode2arity lbrace
; mcode2arity rbrace
] in
664 let lbrace = mcode lbrace in
665 let body = dots (statement
arity) body in
666 let rbrace = mcode rbrace in
667 make_rule_elem stm
tgt arity (Ast0.Seq
(lbrace,body,rbrace))
668 | Ast0.ExprStatement
(exp,sem) ->
669 let arity = stm_same (mcode2line sem) [mcode2arity sem] in
670 let exp = expression
arity exp in
671 let sem = mcode sem in
672 make_rule_elem stm
tgt arity (Ast0.ExprStatement
(exp,sem))
673 | Ast0.IfThen
(iff
,lp,exp,rp,branch
,aft
) ->
675 stm_same (mcode2line iff
) (List.map
mcode2arity [iff
;lp;rp]) in
676 let iff = mcode iff in
678 let exp = expression
arity exp in
680 let branch = statement
arity branch in
681 make_rule_elem stm
tgt arity (Ast0.IfThen
(iff,lp,exp,rp,branch,aft
))
682 | Ast0.IfThenElse
(iff,lp,exp,rp,branch1
,els
,branch2
,aft
) ->
684 stm_same (mcode2line iff) (List.map
mcode2arity [iff;lp;rp;els
]) in
685 let iff = mcode iff in
687 let exp = expression
arity exp in
689 let branch1 = statement
arity branch1 in
690 let els = mcode els in
691 let branch2 = statement
arity branch2 in
692 make_rule_elem stm
tgt arity
693 (Ast0.IfThenElse
(iff,lp,exp,rp,branch1,els,branch2,aft
))
694 | Ast0.While
(wh
,lp,exp,rp,body,aft
) ->
696 stm_same (mcode2line wh
)
697 (List.map
mcode2arity [wh
;lp;rp]) in
700 let exp = expression
arity exp in
702 let body = statement
arity body in
703 make_rule_elem stm
tgt arity (Ast0.While
(wh,lp,exp,rp,body,aft
))
704 | Ast0.Do
(d
,body,wh,lp,exp,rp,sem) ->
706 stm_same (mcode2line wh) (List.map
mcode2arity [d
;wh;lp;rp;sem]) in
708 let body = statement
arity body in
711 let exp = expression
arity exp in
713 let sem = mcode sem in
714 make_rule_elem stm
tgt arity (Ast0.Do
(d,body,wh,lp,exp,rp,sem))
715 | Ast0.For
(fr
,lp,exp1,sem1
,exp2,sem2
,exp3,rp,body,aft
) ->
717 stm_same (mcode2line fr
) (List.map
mcode2arity [fr
;lp;sem1
;sem2
;rp]) in
720 let exp1 = get_option (expression
arity) exp1 in
721 let sem1 = mcode sem1 in
722 let exp2 = get_option (expression
arity) exp2 in
723 let sem2= mcode sem2 in
724 let exp3 = get_option (expression
arity) exp3 in
726 let body = statement
arity body in
727 make_rule_elem stm
tgt arity
728 (Ast0.For
(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft
))
729 | Ast0.Iterator
(nm
,lp,args,rp,body,aft
) ->
730 let arity = stm_same (mcode2line lp) (List.map
mcode2arity [lp;rp]) in
731 let nm = ident false arity nm in
733 let args = dots (expression
arity) args in
735 let body = statement
arity body in
736 make_rule_elem stm
tgt arity (Ast0.Iterator
(nm,lp,args,rp,body,aft
))
737 | Ast0.Switch
(switch
,lp,exp,rp,lb,decls,cases
,rb) ->
739 stm_same (mcode2line switch
)
740 (List.map
mcode2arity [switch
;lp;rp;lb;rb]) in
741 let switch = mcode switch in
743 let exp = expression
arity exp in
746 let decls = dots (statement
arity) decls in
747 let cases = dots (case_line
arity) cases in
749 make_rule_elem stm
tgt arity
750 (Ast0.Switch
(switch,lp,exp,rp,lb,decls,cases,rb))
751 | Ast0.Break
(br
,sem) ->
752 let arity = stm_same (mcode2line br
) (List.map
mcode2arity [br
;sem]) in
754 let sem = mcode sem in
755 make_rule_elem stm
tgt arity (Ast0.Break
(br,sem))
756 | Ast0.Continue
(cont
,sem) ->
758 stm_same (mcode2line cont
) (List.map
mcode2arity [cont
;sem]) in
759 let cont = mcode cont in
760 let sem = mcode sem in
761 make_rule_elem stm
tgt arity (Ast0.Continue
(cont,sem))
762 | Ast0.Label
(l,dd
) ->
763 let arity = mcode2arity dd
in
764 let l = ident false tgt l in
766 make_rule_elem stm
tgt arity (Ast0.Label
(l,dd))
767 | Ast0.Goto
(goto
,l,sem) ->
769 stm_same (mcode2line goto
) (List.map
mcode2arity [goto
;sem]) in
770 let goto = mcode goto in
771 let l = ident false tgt l in
772 let sem = mcode sem in
773 make_rule_elem stm
tgt arity (Ast0.Goto
(goto,l,sem))
774 | Ast0.Return
(ret
,sem) ->
775 let arity = stm_same (mcode2line ret
) (List.map
mcode2arity [ret
;sem]) in
776 let ret = mcode ret in
777 let sem = mcode sem in
778 make_rule_elem stm
tgt arity (Ast0.Return
(ret,sem))
779 | Ast0.ReturnExpr
(ret,exp,sem) ->
780 let arity = stm_same (mcode2line ret) (List.map
mcode2arity [ret;sem]) in
781 let ret = mcode ret in
782 let exp = expression
arity exp in
783 let sem = mcode sem in
784 make_rule_elem stm
tgt arity (Ast0.ReturnExpr
(ret,exp,sem))
785 | Ast0.MetaStmt
(name,pure
) ->
786 let arity = stm_same (mcode2line name) [mcode2arity name] in
787 let name = mcode name in
788 make_rule_elem stm
tgt arity (Ast0.MetaStmt
(name,pure
))
789 | Ast0.MetaStmtList
(name,pure
) ->
790 let arity = stm_same (mcode2line name) [mcode2arity name] in
791 let name = mcode name in
792 make_rule_elem stm
tgt arity (Ast0.MetaStmtList
(name,pure
))
794 let new_exp = top_expression true tgt exp in
796 (match Ast0.unwrap
new_exp with
798 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
799 | Ast0.UniqueExp
(exp) ->
800 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
801 | _
-> Ast0.Exp
(new_exp))
802 | Ast0.TopExp
(exp) ->
803 let new_exp = top_expression true tgt exp in
805 (match Ast0.unwrap
new_exp with
807 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
808 | Ast0.UniqueExp
(exp) ->
809 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
810 | _
-> Ast0.TopExp
(new_exp))
812 let new_ty = typeC
tgt ty in (* opt makes no sense alone at top level *)
814 (match Ast0.unwrap
new_ty with
816 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
817 | Ast0.UniqueType
(ty) ->
818 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
819 | _
-> Ast0.Ty
(new_ty))
820 | Ast0.TopInit
(init
) ->
821 let new_init = initialiser
tgt init
in
823 (match Ast0.unwrap
new_init with
825 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopInit
(init
)))
826 | Ast0.UniqueIni
(init
) ->
827 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopInit
(init
)))
828 | _
-> Ast0.TopInit
(new_init))
829 | Ast0.Disj
(starter
,rule_elem_dots_list
,mids
,ender
) ->
831 List.map
(function x
-> concat_dots (statement
tgt) x
)
832 rule_elem_dots_list
in
833 let (found_opt
,unopt
) =
835 (function (found_opt
,lines
) ->
838 (* previously just checked the last thing in the list,
839 but everything should be optional for the whole thing to
842 match Ast0.unwrap x
with
843 Ast0.OptStm
(x
) -> true
846 match Ast0.unwrap x
with
849 if List.for_all
is_opt l
850 then (true,List.map
unopt l)
853 match Ast0.unwrap x
with
855 (l,function l -> Ast0.rewrap x
(Ast0.DOTS
l))
857 (l,function l -> Ast0.rewrap x
(Ast0.CIRCLES
l))
859 (l,function l -> Ast0.rewrap x
(Ast0.STARS
l)) in
860 let (found_opt
,l) = rebuild l in
861 (found_opt
,(k
l)::lines
))
863 let unopt = List.rev
unopt in
866 make_rule_elem stm
tgt Ast0.OPT
(Ast0.Disj
(starter
,unopt,mids
,ender
))
867 else Ast0.rewrap stm
(Ast0.Disj
(starter
,stms,mids
,ender
))
868 | Ast0.Nest
(starter
,rule_elem_dots
,ender
,whn
,multi
) ->
869 let new_rule_elem_dots =
870 concat_dots (statement
Ast0.NONE
) rule_elem_dots
in
873 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
874 (expression
Ast0.NONE
))
877 (Ast0.Nest
(starter
,new_rule_elem_dots,ender
,whn,multi
))
878 | Ast0.Dots
(dots,whn) ->
879 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
880 let dots = mcode dots in
883 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
884 (expression
Ast0.NONE
))
886 make_rule_elem stm
tgt arity (Ast0.Dots
(dots,whn))
887 | Ast0.Circles
(dots,whn) ->
888 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
889 let dots = mcode dots in
892 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
893 (expression
Ast0.NONE
))
895 make_rule_elem stm
tgt arity (Ast0.Circles
(dots,whn))
896 | Ast0.Stars
(dots,whn) ->
897 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
898 let dots = mcode dots in
901 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
902 (expression
Ast0.NONE
))
904 make_rule_elem stm
tgt arity (Ast0.Stars
(dots,whn))
905 | Ast0.FunDecl
(bef
,fi
,name,lp,params,rp,lbrace,body,rbrace) ->
907 all_same true tgt (mcode2line lp)
908 ((List.map
mcode2arity [lp;rp;lbrace;rbrace]) @ (fninfo2arity fi
)) in
909 let fi = List.map
(fninfo
arity) fi in
910 let name = ident false arity name in
912 let params = parameter_list
arity params in
914 let lbrace = mcode lbrace in
915 let body = dots (statement
arity) body in
916 let rbrace = mcode rbrace in
917 make_rule_elem stm
tgt arity
918 (Ast0.FunDecl
(bef
,fi,name,lp,params,rp,lbrace,body,rbrace))
919 | Ast0.Include
(inc
,s
) ->
921 all_same true tgt (mcode2line inc
) [mcode2arity inc
; mcode2arity s
] in
922 let inc = mcode inc in
924 make_rule_elem stm
tgt arity (Ast0.Include
(inc,s))
925 | Ast0.Define
(def
,id,params,body) ->
926 let arity = all_same true tgt (mcode2line def
) [mcode2arity def
] in
927 let def = mcode def in
928 let id = ident false arity id in
929 let params = define_parameters
arity params in
930 let body = dots (statement
arity) body in
931 make_rule_elem stm
tgt arity (Ast0.Define
(def,id,params,body))
932 | Ast0.OptStm
(_
) | Ast0.UniqueStm
(_
) ->
933 failwith
"unexpected code"
935 and define_parameters
tgt params =
936 match Ast0.unwrap
params with
937 Ast0.NoParams
-> params
938 | Ast0.DParams
(lp,params,rp) ->
940 all_same true tgt (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
942 let params = dots (define_param
arity) params in
944 Ast0.rewrap
params (Ast0.DParams
(lp,params,rp))
946 and make_define_param x
=
948 (function x
-> Ast0.OptDParam x
)
949 (function x
-> Ast0.UniqueDParam x
)
952 and define_param
tgt param
=
953 match Ast0.unwrap param
with
955 let new_id = ident true tgt id in
957 (match Ast0.unwrap
new_id with
959 Ast0.OptDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
960 | Ast0.UniqueIdent
(decl
) ->
961 Ast0.UniqueDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
962 | _
-> Ast0.DParam
(new_id))
963 | Ast0.DPComma
(cm) ->
965 all_same true tgt (mcode2line cm) [mcode2arity cm] in
967 make_define_param param
tgt arity (Ast0.DPComma
(cm))
968 | Ast0.DPdots
(dots) ->
970 all_same true tgt (mcode2line dots) [mcode2arity dots] in
971 let dots = mcode dots in
972 make_define_param param
tgt arity (Ast0.DPdots
(dots))
973 | Ast0.DPcircles
(circles
) ->
975 all_same true tgt (mcode2line circles
) [mcode2arity circles
] in
976 let circles = mcode circles in
977 make_define_param param
tgt arity (Ast0.DPcircles
(circles))
978 | Ast0.OptDParam
(dp
) | Ast0.UniqueDParam
(dp
) ->
979 failwith
"unexpected code"
981 and fninfo
arity = function
982 Ast0.FStorage
(stg) -> Ast0.FStorage
(mcode stg)
983 | Ast0.FType
(ty) -> Ast0.FType
(typeC
arity ty)
984 | Ast0.FInline
(inline
) -> Ast0.FInline
(mcode inline
)
985 | Ast0.FAttr
(attr
) -> Ast0.FAttr
(mcode attr
)
987 and fninfo2arity fninfo
=
991 Ast0.FStorage
(stg) -> [mcode2arity stg]
992 | Ast0.FType
(ty) -> []
993 | Ast0.FInline
(inline
) -> [mcode2arity inline
]
994 | Ast0.FAttr
(attr
) -> [mcode2arity attr
])
997 and whencode notfn alwaysfn expression
= function
998 Ast0.WhenNot a
-> Ast0.WhenNot
(notfn a
)
999 | Ast0.WhenAlways a
-> Ast0.WhenAlways
(alwaysfn a
)
1000 | Ast0.WhenModifier
(x
) -> Ast0.WhenModifier
(x
)
1001 | Ast0.WhenNotTrue a
-> Ast0.WhenNotTrue
(expression a
)
1002 | Ast0.WhenNotFalse a
-> Ast0.WhenNotFalse
(expression a
)
1004 and make_case_line
=
1006 (function x
-> Ast0.OptCase x
)
1007 (function x
-> failwith
"unique not allowed for case_line")
1009 and case_line
tgt c
=
1010 match Ast0.unwrap c
with
1011 Ast0.Default
(def,colon,code
) ->
1013 all_same true tgt (mcode2line def)
1014 [mcode2arity def; mcode2arity colon] in
1015 let def = mcode def in
1016 let colon = mcode colon in
1017 let code = dots (statement
arity) code in
1018 make_case_line c
tgt arity (Ast0.Default
(def,colon,code))
1019 | Ast0.Case
(case
,exp,colon,code) ->
1021 all_same true tgt (mcode2line case
)
1022 [mcode2arity case
; mcode2arity colon] in
1023 let case = mcode case in
1024 let exp = expression
arity exp in
1025 let colon = mcode colon in
1026 let code = dots (statement
arity) code in
1027 make_case_line c
tgt arity (Ast0.Case
(case,exp,colon,code))
1028 | Ast0.DisjCase
(starter
,case_lines
,mids
,ender
) ->
1029 let case_lines = List.map
(case_line
tgt) case_lines in
1030 (match List.rev
case_lines with
1032 if anyopt xs
(function Ast0.OptCase
(_
) -> true | _
-> false)
1033 then fail c
"opt only allowed in the last disjunct"
1035 Ast0.rewrap c
(Ast0.DisjCase
(starter
,case_lines,mids
,ender
))
1036 | Ast0.OptCase
(_
) -> failwith
"unexpected OptCase"
1038 (* --------------------------------------------------------------------- *)
1039 (* Function declaration *)
1040 (* Haven't thought much about arity here... *)
1042 let top_level tgt t
=
1044 (match Ast0.unwrap t
with
1045 Ast0.FILEINFO
(old_file
,new_file
) ->
1046 if mcode2arity old_file
= Ast0.NONE
&& mcode2arity new_file
= Ast0.NONE
1047 then Ast0.FILEINFO
(mcode old_file
,mcode new_file
)
1048 else fail t
"unexpected arity for file info"
1049 | Ast0.DECL
(stmt
) ->
1050 Ast0.DECL
(statement
tgt stmt
)
1051 | Ast0.CODE
(rule_elem_dots
) ->
1052 Ast0.CODE
(concat_dots (statement
tgt) rule_elem_dots
)
1053 | Ast0.ERRORWORDS
(exps) ->
1054 Ast0.ERRORWORDS
(List.map
(top_expression false Ast0.NONE
) exps)
1055 | Ast0.OTHER
(_
) -> fail t
"eliminated by top_level")
1057 let rule tgt = List.map
(top_level tgt)
1059 (* --------------------------------------------------------------------- *)
1062 let minus_arity code =