2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
27 (* Arities matter for the minus slice, but not for the plus slice. *)
29 (* ? only allowed on rule_elems, and on subterms if the context is ? also. *)
31 module Ast0
= Ast0_cocci
32 module Ast
= Ast_cocci
34 (* --------------------------------------------------------------------- *)
36 let warning s
= Printf.printf
"warning: %s\n" s
40 (Printf.sprintf
"cocci line %d: %s"
41 ((Ast0.get_info w
).Ast0.pos_info
.Ast0.line_start
)
44 let make_opt_unique optfn uniquefn info tgt arity term
=
45 let term = Ast0.rewrap info
term in
48 else (* tgt must be NONE *)
50 Ast0.OPT
-> Ast0.copywrap info
(optfn
term)
51 | Ast0.UNIQUE
-> Ast0.copywrap info
(uniquefn
term)
52 | Ast0.NONE
-> failwith
"tgt must be NONE"
54 let all_same opt_allowed tgt line arities
=
58 (match List.hd arities
with
59 Ast0.OPT
when not opt_allowed
->
60 failwith
"opt only allowed for the elements of a statement list"
63 if not
(List.for_all
(function x
-> x
= tgt) arities
)
64 then warning (Printf.sprintf
"incompatible arity found on line %d" line
);
67 let get_option fn
= function
69 | Some x
-> Some
(fn x
)
71 let anyopt l fn
= List.exists
(function w
-> fn
(Ast0.unwrap w
)) l
74 let rec loop = function
77 match fn
(Ast0.unwrap x
) with
78 Some x
-> x
:: (loop xs
)
81 if List.length
res = List.length l
then Some
res else None
83 (* --------------------------------------------------------------------- *)
84 (* --------------------------------------------------------------------- *)
87 let mcode2line (_
,_
,info
,_
,_
,_
) = info
.Ast0.pos_info
.Ast0.line_start
88 let mcode2arity (_
,arity
,_
,_
,_
,_
) = arity
90 let mcode x
= x
(* nothing to do ... *)
92 (* --------------------------------------------------------------------- *)
97 (match Ast0.unwrap d
with
98 Ast0.DOTS
(x
) -> Ast0.DOTS
(List.map fn x
)
99 | Ast0.CIRCLES
(x
) -> Ast0.CIRCLES
(List.map fn x
)
100 | Ast0.STARS
(x
) -> Ast0.STARS
(List.map fn x
))
106 match Ast0.unwrap x
with
107 Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> true
114 match Ast0.unwrap x
with
115 Ast0.Dots
(_
,_
) | Ast0.Stars
(_
,_
) -> true
122 match Ast0.unwrap x
with
123 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) -> true
127 let concat_dots fn d
=
129 (match Ast0.unwrap d
with
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 l = List.map fn x
in
144 else fail d
"inconsistent dots usage")
146 let flat_concat_dots fn d
=
147 match Ast0.unwrap d
with
148 Ast0.DOTS
(x
) -> List.map fn x
149 | Ast0.CIRCLES
(x
) -> List.map fn x
150 | Ast0.STARS
(x
) -> List.map fn x
152 (* --------------------------------------------------------------------- *)
157 (function x
-> Ast0.OptIdent x
)
158 (function x
-> Ast0.UniqueIdent x
)
160 let rec ident opt_allowed
tgt i
=
161 match Ast0.unwrap i
with
164 all_same opt_allowed
tgt (mcode2line name
)
165 [mcode2arity name
] in
166 let name = mcode name in
167 make_id i
tgt arity (Ast0.Id
(name))
168 | Ast0.MetaId
(name,constraints
,seed
,pure
) ->
170 all_same opt_allowed
tgt (mcode2line name)
171 [mcode2arity name] in
172 let name = mcode name in
173 make_id i
tgt arity (Ast0.MetaId
(name,constraints
,seed
,pure
))
174 | Ast0.MetaFunc
(name,constraints
,pure
) ->
176 all_same opt_allowed
tgt (mcode2line name)
177 [mcode2arity name] in
178 let name = mcode name in
179 make_id i
tgt arity (Ast0.MetaFunc
(name,constraints
,pure
))
180 | Ast0.MetaLocalFunc
(name,constraints
,pure
) ->
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.MetaLocalFunc
(name,constraints
,pure
))
186 | Ast0.DisjId
(starter
,id_list
,mids
,ender
) ->
187 let id_list = List.map
(ident opt_allowed
tgt) id_list in
188 (match List.rev
id_list with
190 if anyopt xs
(function Ast0.OptIdent
(_
) -> true | _
-> false)
191 then fail i
"opt only allowed in the last disjunct"
193 Ast0.rewrap i
(Ast0.DisjId
(starter
,id_list,mids
,ender
))
194 | Ast0.OptIdent
(_
) | Ast0.UniqueIdent
(_
) ->
195 failwith
"unexpected code"
197 (* --------------------------------------------------------------------- *)
202 (function x
-> Ast0.OptExp x
)
203 (function x
-> Ast0.UniqueExp x
)
205 let rec top_expression opt_allowed
tgt expr
=
206 let exp_same = all_same opt_allowed
tgt in
207 match Ast0.unwrap expr
with
209 let new_id = ident opt_allowed
tgt id
in
211 (match Ast0.unwrap
new_id with
213 Ast0.OptExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
214 | Ast0.UniqueIdent
(id
) ->
215 Ast0.UniqueExp
(Ast0.rewrap expr
(Ast0.Ident
(id
)))
216 | _
-> Ast0.Ident
(new_id))
217 | Ast0.Constant
(const
) ->
218 let arity = exp_same (mcode2line const
) [mcode2arity const
] in
219 let const = mcode const in
220 make_exp expr
tgt arity (Ast0.Constant
(const))
221 | Ast0.FunCall
(fn
,lp
,args
,rp
) ->
222 let arity = exp_same (mcode2line lp
) [mcode2arity lp
;mcode2arity rp
] in
223 let fn = expression
arity fn in
225 let args = dots (expression
arity) args in
227 make_exp expr
tgt arity (Ast0.FunCall
(fn,lp,args,rp))
228 | Ast0.Assignment
(left
,op
,right
,simple
) ->
229 let arity = exp_same (mcode2line op
) [mcode2arity op
] in
230 let left = expression
arity left in
232 let right = expression
arity right in
233 make_exp expr
tgt arity (Ast0.Assignment
(left,op,right,simple
))
234 | Ast0.Sequence
(left,op,right) ->
235 let arity = exp_same (mcode2line op) [mcode2arity op] in
236 let left = expression
arity left in
238 let right = expression
arity right in
239 make_exp expr
tgt arity (Ast0.Sequence
(left,op,right))
240 | Ast0.CondExpr
(exp1
,why
,exp2
,colon
,exp3
) ->
242 exp_same (mcode2line why
) [mcode2arity why
; mcode2arity colon
] in
243 let exp1 = expression
arity exp1 in
244 let why = mcode why in
245 let exp2 = get_option (expression
arity) exp2 in
246 let colon = mcode colon in
247 let exp3 = expression
arity exp3 in
248 make_exp expr
tgt arity (Ast0.CondExpr
(exp1,why,exp2,colon,exp3))
249 | Ast0.Postfix
(exp
,op) ->
250 let arity = exp_same (mcode2line op) [mcode2arity op] in
251 let exp = expression
arity exp in
253 make_exp expr
tgt arity (Ast0.Postfix
(exp,op))
254 | Ast0.Infix
(exp,op) ->
255 let arity = exp_same (mcode2line op) [mcode2arity op] in
256 let exp = expression
arity exp in
258 make_exp expr
tgt arity (Ast0.Infix
(exp,op))
259 | Ast0.Unary
(exp,op) ->
260 let arity = exp_same (mcode2line op) [mcode2arity op] in
261 let exp = expression
arity exp in
263 make_exp expr
tgt arity (Ast0.Unary
(exp,op))
264 | Ast0.Binary
(left,op,right) ->
265 let arity = exp_same (mcode2line op) [mcode2arity op] in
266 let left = expression
arity left in
268 let right = expression
arity right in
269 make_exp expr
tgt arity (Ast0.Binary
(left,op,right))
270 | Ast0.Nested
(left,op,right) -> failwith
"nested in arity not possible"
271 | Ast0.Paren
(lp,exp,rp) ->
272 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
274 let exp = expression
arity exp in
276 make_exp expr
tgt arity (Ast0.Paren
(lp,exp,rp))
277 | Ast0.ArrayAccess
(exp1,lb
,exp2,rb
) ->
278 let arity = exp_same (mcode2line lb
) [mcode2arity lb
; mcode2arity rb
] in
279 let exp1 = expression
arity exp1 in
281 let exp2 = expression
arity exp2 in
283 make_exp expr
tgt arity (Ast0.ArrayAccess
(exp1,lb,exp2,rb))
284 | Ast0.RecordAccess
(exp,pt
,field
) ->
285 let arity = exp_same (mcode2line pt
) [mcode2arity pt
] in
286 let exp = expression
arity exp in
288 let field = ident false arity field in
289 make_exp expr
tgt arity (Ast0.RecordAccess
(exp,pt,field))
290 | Ast0.RecordPtAccess
(exp,ar
,field) ->
291 let arity = exp_same (mcode2line ar
) [mcode2arity ar
] in
292 let exp = expression
arity exp in
294 let field = ident false arity field in
295 make_exp expr
tgt arity (Ast0.RecordPtAccess
(exp,ar,field))
296 | Ast0.Cast
(lp,ty
,rp,exp) ->
297 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
299 let ty = typeC
arity ty in
301 let exp = expression
arity exp in
302 make_exp expr
tgt arity (Ast0.Cast
(lp,ty,rp,exp))
303 | Ast0.SizeOfExpr
(szf
,exp) ->
304 let arity = exp_same (mcode2line szf
) [mcode2arity szf
] in
305 let szf = mcode szf in
306 let exp = expression
arity exp in
307 make_exp expr
tgt arity (Ast0.SizeOfExpr
(szf,exp))
308 | Ast0.SizeOfType
(szf,lp,ty,rp) ->
310 exp_same (mcode2line szf) (List.map
mcode2arity [szf;lp;rp]) in
311 let szf = mcode szf in
313 let ty = typeC
arity ty in
315 make_exp expr
tgt arity (Ast0.SizeOfType
(szf,lp,ty,rp))
316 | Ast0.TypeExp
(ty) -> Ast0.rewrap expr
(Ast0.TypeExp
(typeC
tgt ty))
317 | Ast0.MetaErr
(name,constraints
,pure
) ->
318 let arity = exp_same (mcode2line name) [mcode2arity name] in
319 let name = mcode name in
320 make_exp expr
tgt arity (Ast0.MetaErr
(name,constraints
,pure
))
321 | Ast0.MetaExpr
(name,constraints
,ty,form
,pure
) ->
322 let arity = exp_same (mcode2line name) [mcode2arity name] in
323 let name = mcode name in
324 make_exp expr
tgt arity (Ast0.MetaExpr
(name,constraints
,ty,form
,pure
))
325 | Ast0.MetaExprList
(name,lenname
,pure
) ->
326 let arity = exp_same (mcode2line name) [mcode2arity name] in
327 let name = mcode name in
328 make_exp expr
tgt arity (Ast0.MetaExprList
(name,lenname
,pure
))
330 let arity = exp_same (mcode2line cm
) [mcode2arity cm
] in
332 make_exp expr
tgt arity (Ast0.EComma
(cm))
333 | Ast0.DisjExpr
(starter
,exps
,mids
,ender
) ->
334 let exps = List.map
(top_expression opt_allowed
tgt) exps in
335 (match List.rev
exps with
337 if anyopt xs
(function Ast0.OptExp
(_
) -> true | _
-> false)
338 then fail expr
"opt only allowed in the last disjunct"
340 Ast0.rewrap expr
(Ast0.DisjExpr
(starter
,exps,mids
,ender
))
341 | Ast0.NestExpr
(starter
,exp_dots
,ender
,whencode
,multi
) ->
343 Ast0.NestExpr
(starter
,
344 dots (top_expression true Ast0.NONE
) exp_dots
,
345 ender
,whencode
,multi
) in
347 | Ast0.Edots
(dots,whencode
) ->
348 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
349 let dots = mcode dots in
350 let whencode = get_option (expression
Ast0.NONE
) whencode in
351 make_exp expr
tgt arity (Ast0.Edots
(dots,whencode))
352 | Ast0.Ecircles
(dots,whencode) ->
353 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
354 let dots = mcode dots in
355 let whencode = get_option (expression
Ast0.NONE
) whencode in
356 make_exp expr
tgt arity (Ast0.Ecircles
(dots,whencode))
357 | Ast0.Estars
(dots,whencode) ->
358 let arity = exp_same (mcode2line dots) [mcode2arity dots] in
359 let dots = mcode dots in
360 let whencode = get_option (expression
Ast0.NONE
) whencode in
361 make_exp expr
tgt arity (Ast0.Estars
(dots,whencode))
362 | Ast0.Constructor
(lp,ty,rp,init
) ->
363 let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
365 let ty = typeC
arity ty in
367 let init = initialiser
arity init in
368 make_exp expr
tgt arity (Ast0.Constructor
(lp,ty,rp,init))
369 (* why does optexp exist???? *)
370 | Ast0.OptExp
(_
) | Ast0.UniqueExp
(_
) | Ast0.AsExpr _
->
371 failwith
"unexpected code"
373 and expression
tgt exp = top_expression false tgt exp
375 (* --------------------------------------------------------------------- *)
380 (function x
-> Ast0.OptType x
)
381 (function x
-> Ast0.UniqueType x
)
383 and top_typeC
tgt opt_allowed typ
=
384 match Ast0.unwrap typ
with
385 Ast0.ConstVol
(cv
,ty) ->
386 let arity = all_same opt_allowed
tgt (mcode2line cv
)
389 let ty = typeC
arity ty in
390 make_typeC typ
tgt arity (Ast0.ConstVol
(cv,ty))
391 | Ast0.BaseType
(ty,strings
) ->
393 all_same opt_allowed
tgt (mcode2line (List.hd strings
))
394 (List.map
mcode2arity strings
) in
395 let strings = List.map
mcode strings in
396 make_typeC typ
tgt arity (Ast0.BaseType
(ty,strings))
397 | Ast0.Signed
(sign
,ty) ->
399 all_same opt_allowed
tgt (mcode2line sign
) [mcode2arity sign
] in
400 let sign = mcode sign in
401 let ty = get_option (typeC
arity) ty in
402 make_typeC typ
tgt arity (Ast0.Signed
(sign,ty))
403 | Ast0.Pointer
(ty,star
) ->
405 all_same opt_allowed
tgt (mcode2line star
) [mcode2arity star
] in
406 let ty = typeC
arity ty in
407 let star = mcode star in
408 make_typeC typ
tgt arity (Ast0.Pointer
(ty,star))
409 | Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params
,rp2
) ->
411 all_same opt_allowed
tgt (mcode2line lp1
)
412 (List.map
mcode2arity [lp1
;star;rp1
;lp2
;rp2
]) in
413 let ty = typeC
arity ty in
414 let params = parameter_list
tgt params in
415 make_typeC typ
tgt arity
416 (Ast0.FunctionPointer
(ty,lp1
,star,rp1
,lp2
,params,rp2
))
417 | Ast0.FunctionType
(ty,lp1
,params,rp1
) ->
419 all_same opt_allowed
tgt (mcode2line lp1
)
420 (List.map
mcode2arity [lp1
;rp1
]) in
421 let ty = get_option (typeC
arity) ty in
422 let params = parameter_list
tgt params in
423 make_typeC typ
tgt arity (Ast0.FunctionType
(ty,lp1
,params,rp1
))
424 | Ast0.Array
(ty,lb,size
,rb) ->
426 all_same opt_allowed
tgt (mcode2line lb)
427 [mcode2arity lb;mcode2arity rb] in
428 let ty = typeC
arity ty in
430 let size = get_option (expression
arity) size in
432 make_typeC typ
tgt arity (Ast0.Array
(ty,lb,size,rb))
433 | Ast0.EnumName
(kind
,name) ->
435 all_same opt_allowed
tgt (mcode2line kind
) [mcode2arity kind
] in
436 let kind = mcode kind in
437 let name = get_option (ident false arity) name in
438 make_typeC typ
tgt arity (Ast0.EnumName
(kind,name))
439 | Ast0.EnumDef
(ty,lb,decls
,rb) ->
441 all_same opt_allowed
tgt (mcode2line lb)
442 (List.map
mcode2arity [lb;rb]) in
443 let ty = typeC
arity ty in
445 let ids = dots (expression
tgt) decls
in
447 make_typeC typ
tgt arity (Ast0.EnumDef
(ty,lb,ids,rb))
448 | Ast0.StructUnionName
(kind,name) ->
450 all_same opt_allowed
tgt (mcode2line kind)
451 [mcode2arity kind] in
452 let kind = mcode kind in
453 let name = get_option (ident false arity) name in
454 make_typeC typ
tgt arity (Ast0.StructUnionName
(kind,name))
455 | Ast0.StructUnionDef
(ty,lb,decls
,rb) ->
457 all_same opt_allowed
tgt (mcode2line lb)
458 (List.map
mcode2arity [lb;rb]) in
459 let ty = typeC
arity ty in
461 let decls = dots (declaration
tgt) decls in
463 make_typeC typ
tgt arity (Ast0.StructUnionDef
(ty,lb,decls,rb))
464 | Ast0.TypeName
(name) ->
466 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
467 let name = mcode name in
468 make_typeC typ
tgt arity (Ast0.TypeName
(name))
469 | Ast0.MetaType
(name,pure
) ->
471 all_same opt_allowed
tgt (mcode2line name) [mcode2arity name] in
472 let name = mcode name in
473 make_typeC typ
tgt arity (Ast0.MetaType
(name,pure
))
474 | Ast0.DisjType
(starter
,types
,mids
,ender
) ->
475 let types = List.map
(typeC
tgt) types in
476 (match List.rev
types with
478 if anyopt xs
(function Ast0.OptType
(_
) -> true | _
-> false)
479 then fail typ
"opt only allowed in the last disjunct"
481 let res = Ast0.DisjType
(starter
,types,mids
,ender
) in
483 | Ast0.OptType
(_
) | Ast0.UniqueType
(_
) | Ast0.AsType _
->
484 failwith
"unexpected code"
486 and typeC
tgt ty = top_typeC
tgt false ty
488 (* --------------------------------------------------------------------- *)
489 (* Variable declaration *)
490 (* Even if the Cocci program specifies a list of declarations, they are
491 split out into multiple declarations of a single variable each. *)
495 (function x
-> Ast0.OptDecl x
)
496 (function x
-> Ast0.UniqueDecl x
)
498 and declaration
tgt decl
=
499 match Ast0.unwrap decl
with
500 Ast0.MetaDecl
(name,pure
) ->
501 let arity = all_same true tgt (mcode2line name) [mcode2arity name] in
502 let name = mcode name in
503 make_decl decl
tgt arity (Ast0.MetaDecl
(name,pure
))
504 | Ast0.MetaField
(name,pure
) ->
505 let arity = all_same true tgt (mcode2line name) [mcode2arity name] in
506 let name = mcode name in
507 make_decl decl
tgt arity (Ast0.MetaField
(name,pure
))
508 | Ast0.MetaFieldList
(name,lenname
,pure
) ->
509 let arity = all_same true tgt (mcode2line name) [mcode2arity name] in
510 let name = mcode name in
511 make_decl decl
tgt arity (Ast0.MetaFieldList
(name,lenname
,pure
))
512 | Ast0.Init
(stg
,ty,id
,eq
,exp,sem
) ->
514 all_same true tgt (mcode2line eq
)
515 ((match stg
with None
-> [] | Some x
-> [mcode2arity x
]) @
516 (List.map
mcode2arity [eq
;sem
])) in
517 let stg = get_option mcode stg in
518 let ty = typeC
arity ty in
519 let id = ident false arity id in
521 let exp = initialiser
arity exp in
522 let sem = mcode sem in
523 make_decl decl
tgt arity (Ast0.Init
(stg,ty,id,eq,exp,sem))
524 | Ast0.UnInit
(stg,ty,id,sem) ->
526 all_same true tgt (mcode2line sem)
527 ((match stg with None
-> [] | Some x
-> [mcode2arity x
]) @
528 [mcode2arity sem]) in
529 let stg = get_option mcode stg in
530 let ty = typeC
arity ty in
531 let id = ident false arity id in
532 let sem = mcode sem in
533 make_decl decl
tgt arity (Ast0.UnInit
(stg,ty,id,sem))
534 | Ast0.MacroDecl
(name,lp,args,rp,sem) ->
536 all_same true tgt (mcode2line lp)
537 (List.map
mcode2arity [lp;rp;sem]) in
538 let name = ident false arity name in
540 let args = dots (expression
arity) args in
542 let sem = mcode sem in
543 make_decl decl
tgt arity (Ast0.MacroDecl
(name,lp,args,rp,sem))
544 | Ast0.MacroDeclInit
(name,lp,args,rp,eq,ini
,sem) ->
546 all_same true tgt (mcode2line lp)
547 (List.map
mcode2arity [lp;rp;eq;sem]) in
548 let name = ident false arity name in
550 let args = dots (expression
arity) args in
552 let ini = initialiser
arity ini in
553 let sem = mcode sem in
554 make_decl decl
tgt arity
555 (Ast0.MacroDeclInit
(name,lp,args,rp,eq,ini,sem))
556 | Ast0.TyDecl
(ty,sem) ->
558 all_same true tgt (mcode2line sem) [mcode2arity sem] in
559 let ty = typeC
arity ty in
560 let sem = mcode sem in
561 make_decl decl
tgt arity (Ast0.TyDecl
(ty,sem))
562 | Ast0.Typedef
(stg,ty,id,sem) ->
564 all_same true tgt (mcode2line sem)
565 [mcode2arity stg;mcode2arity sem] in
566 let stg = mcode stg in
567 let ty = typeC
arity ty in
568 let id = typeC
arity id in
569 let sem = mcode sem in
570 make_decl decl
tgt arity (Ast0.Typedef
(stg,ty,id,sem))
571 | Ast0.DisjDecl
(starter
,decls,mids
,ender
) ->
572 let decls = List.map
(declaration
tgt) decls in
573 (match List.rev
decls with
575 if anyopt xs
(function Ast0.OptDecl
(_
) -> true | _
-> false)
576 then fail decl
"opt only allowed in the last disjunct"
578 let res = Ast0.DisjDecl
(starter
,decls,mids
,ender
) in
580 | Ast0.Ddots
(dots,whencode) ->
581 let arity = all_same true tgt (mcode2line dots) [mcode2arity dots] in
582 let dots = mcode dots in
583 let whencode = get_option (declaration
Ast0.NONE
) whencode in
584 make_decl decl
tgt arity (Ast0.Ddots
(dots,whencode))
585 | Ast0.OptDecl
(_
) | Ast0.UniqueDecl
(_
) | Ast0.AsDecl _
->
586 failwith
"unexpected code"
588 (* --------------------------------------------------------------------- *)
593 (function x
-> Ast0.OptIni x
)
594 (function x
-> Ast0.UniqueIni x
)
596 and initialiser
tgt i
=
597 let init_same = all_same true tgt in
598 match Ast0.unwrap i
with
599 Ast0.MetaInit
(name,pure
) ->
600 let arity = init_same (mcode2line name) [mcode2arity name] in
601 let name = mcode name in
602 make_init i
tgt arity (Ast0.MetaInit
(name,pure
))
603 | Ast0.MetaInitList
(name,lenname
,pure
) ->
604 let arity = init_same (mcode2line name) [mcode2arity name] in
605 let name = mcode name in
606 make_init i
tgt arity (Ast0.MetaInitList
(name,lenname
,pure
))
607 | Ast0.InitExpr
(exp) ->
608 Ast0.rewrap i
(Ast0.InitExpr
(expression
tgt exp))
609 | Ast0.InitList
(lb,initlist
,rb,ordered
) ->
610 let arity = init_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
612 let initlist = dots (initialiser
arity) initlist in
614 make_init i
tgt arity (Ast0.InitList
(lb,initlist,rb,ordered
))
615 | Ast0.InitGccExt
(designators
,eq,ini) ->
616 let arity = init_same (mcode2line eq) [mcode2arity eq] in
617 let designators = List.map
(designator
arity) designators in
619 let ini = initialiser
arity ini in
620 make_init i
tgt arity (Ast0.InitGccExt
(designators,eq,ini))
621 | Ast0.InitGccName
(name,eq,ini) ->
622 let arity = init_same (mcode2line eq) [mcode2arity eq] in
623 let name = ident true arity name in
625 let ini = initialiser
arity ini in
626 make_init i
tgt arity (Ast0.InitGccName
(name,eq,ini))
628 let arity = init_same (mcode2line cm) [mcode2arity cm] in
630 make_init i
tgt arity (Ast0.IComma
(cm))
631 | Ast0.Idots
(dots,whencode) ->
632 let arity = init_same (mcode2line dots) [mcode2arity dots] in
633 let dots = mcode dots in
634 let whencode = get_option (initialiser
Ast0.NONE
) whencode in
635 make_init i
tgt arity (Ast0.Idots
(dots,whencode))
636 | Ast0.OptIni
(_
) | Ast0.UniqueIni
(_
) | Ast0.AsInit _
->
637 failwith
"unexpected code"
639 and designator
tgt d
=
640 let dsame = all_same false tgt in
642 Ast0.DesignatorField
(dot
,id) ->
643 let arity = dsame (mcode2line dot
) [mcode2arity dot
] in
644 let dot = mcode dot in
645 let id = ident false arity id in
646 Ast0.DesignatorField
(dot,id)
647 | Ast0.DesignatorIndex
(lb,exp,rb) ->
648 let arity = dsame (mcode2line lb) [mcode2arity lb;mcode2arity rb] in
650 let exp = top_expression false arity exp in
652 Ast0.DesignatorIndex
(lb,exp,rb)
653 | Ast0.DesignatorRange
(lb,min
,dots,max
,rb) ->
655 dsame (mcode2line lb)
656 [mcode2arity lb;mcode2arity dots;mcode2arity rb] in
658 let min = top_expression false arity min in
659 let dots = mcode dots in
660 let max = top_expression false arity max in
662 Ast0.DesignatorRange
(lb,min,dots,max,rb)
664 (* --------------------------------------------------------------------- *)
669 (function x
-> Ast0.OptParam x
)
670 (function x
-> Ast0.UniqueParam x
)
672 and parameterTypeDef
tgt param
=
673 let param_same = all_same true tgt in
674 match Ast0.unwrap param
with
675 Ast0.VoidParam
(ty) -> Ast0.rewrap param
(Ast0.VoidParam
(typeC
tgt ty))
676 | Ast0.Param
(ty,Some
id) ->
677 let ty = top_typeC
tgt true ty in
678 let id = ident true tgt id in
680 (match (Ast0.unwrap
ty,Ast0.unwrap
id) with
681 (Ast0.OptType
(ty),Ast0.OptIdent
(id)) ->
682 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
683 | (Ast0.UniqueType
(ty),Ast0.UniqueIdent
(id)) ->
684 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,Some
id)))
685 | (Ast0.OptType
(ty),_
) ->
686 fail param
"arity mismatch in param declaration"
687 | (_
,Ast0.OptIdent
(id)) ->
688 fail param
"arity mismatch in param declaration"
689 | _
-> Ast0.Param
(ty,Some
id))
690 | Ast0.Param
(ty,None
) ->
691 let ty = top_typeC
tgt true ty in
693 (match Ast0.unwrap
ty with
695 Ast0.OptParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
696 | Ast0.UniqueType
(ty) ->
697 Ast0.UniqueParam
(Ast0.rewrap param
(Ast0.Param
(ty,None
)))
698 | _
-> Ast0.Param
(ty,None
))
699 | Ast0.MetaParam
(name,pure
) ->
700 let arity = param_same (mcode2line name) [mcode2arity name] in
701 let name = mcode name in
702 make_param param
tgt arity (Ast0.MetaParam
(name,pure
))
703 | Ast0.MetaParamList
(name,lenname
,pure
) ->
704 let arity = param_same (mcode2line name) [mcode2arity name] in
705 let name = mcode name in
706 make_param param
tgt arity (Ast0.MetaParamList
(name,lenname
,pure
))
708 let arity = param_same (mcode2line cm) [mcode2arity cm] in
710 make_param param
tgt arity (Ast0.PComma
(cm))
711 | Ast0.Pdots
(dots) ->
712 let arity = param_same (mcode2line dots) [mcode2arity dots] in
713 let dots = mcode dots in
714 make_param param
tgt arity (Ast0.Pdots
(dots))
715 | Ast0.Pcircles
(dots) ->
716 let arity = param_same (mcode2line dots) [mcode2arity dots] in
717 let dots = mcode dots in
718 make_param param
tgt arity (Ast0.Pcircles
(dots))
719 | Ast0.OptParam
(_
) | Ast0.UniqueParam
(_
) ->
720 failwith
"unexpected code"
722 and parameter_list
tgt = dots (parameterTypeDef
tgt)
724 (* --------------------------------------------------------------------- *)
727 and make_rule_elem x
=
729 (function x
-> Ast0.OptStm x
)
730 (function x
-> Ast0.UniqueStm x
)
733 and statement
tgt stm
=
734 let stm_same = all_same true tgt in
735 match Ast0.unwrap stm
with
736 Ast0.Decl
(bef
,decl
) ->
737 let new_decl = declaration
tgt decl
in
739 (match Ast0.unwrap
new_decl with
740 Ast0.OptDecl
(decl
) ->
741 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
742 | Ast0.UniqueDecl
(decl
) ->
743 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Decl
(bef
,decl
)))
744 | _
-> Ast0.Decl
(bef
,new_decl))
745 | Ast0.Seq
(lbrace
,body
,rbrace
) ->
747 stm_same (mcode2line lbrace
)
748 [mcode2arity lbrace
; mcode2arity rbrace
] in
749 let lbrace = mcode lbrace in
750 let body = dots (statement
arity) body in
751 let rbrace = mcode rbrace in
752 make_rule_elem stm
tgt arity (Ast0.Seq
(lbrace,body,rbrace))
753 | Ast0.ExprStatement
(exp,sem) ->
754 let arity = stm_same (mcode2line sem) [mcode2arity sem] in
755 let exp = get_option (expression
arity) exp in
756 let sem = mcode sem in
757 make_rule_elem stm
tgt arity (Ast0.ExprStatement
(exp,sem))
758 | Ast0.IfThen
(iff
,lp,exp,rp,branch
,aft
) ->
760 stm_same (mcode2line iff
) (List.map
mcode2arity [iff
;lp;rp]) in
761 let iff = mcode iff in
763 let exp = expression
arity exp in
765 let branch = statement
arity branch in
766 make_rule_elem stm
tgt arity (Ast0.IfThen
(iff,lp,exp,rp,branch,aft
))
767 | Ast0.IfThenElse
(iff,lp,exp,rp,branch1
,els
,branch2
,aft
) ->
769 stm_same (mcode2line iff) (List.map
mcode2arity [iff;lp;rp;els
]) in
770 let iff = mcode iff in
772 let exp = expression
arity exp in
774 let branch1 = statement
arity branch1 in
775 let els = mcode els in
776 let branch2 = statement
arity branch2 in
777 make_rule_elem stm
tgt arity
778 (Ast0.IfThenElse
(iff,lp,exp,rp,branch1,els,branch2,aft
))
779 | Ast0.While
(wh
,lp,exp,rp,body,aft
) ->
781 stm_same (mcode2line wh
)
782 (List.map
mcode2arity [wh
;lp;rp]) in
785 let exp = expression
arity exp in
787 let body = statement
arity body in
788 make_rule_elem stm
tgt arity (Ast0.While
(wh,lp,exp,rp,body,aft
))
789 | Ast0.Do
(d
,body,wh,lp,exp,rp,sem) ->
791 stm_same (mcode2line wh) (List.map
mcode2arity [d
;wh;lp;rp;sem]) in
793 let body = statement
arity body in
796 let exp = expression
arity exp in
798 let sem = mcode sem in
799 make_rule_elem stm
tgt arity (Ast0.Do
(d,body,wh,lp,exp,rp,sem))
800 | Ast0.For
(fr
,lp,exp1,sem1
,exp2,sem2
,exp3,rp,body,aft
) ->
802 stm_same (mcode2line fr
) (List.map
mcode2arity [fr
;lp;sem1
;sem2
;rp]) in
805 let exp1 = get_option (expression
arity) exp1 in
806 let sem1 = mcode sem1 in
807 let exp2 = get_option (expression
arity) exp2 in
808 let sem2= mcode sem2 in
809 let exp3 = get_option (expression
arity) exp3 in
811 let body = statement
arity body in
812 make_rule_elem stm
tgt arity
813 (Ast0.For
(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft
))
814 | Ast0.Iterator
(nm
,lp,args,rp,body,aft
) ->
815 let arity = stm_same (mcode2line lp) (List.map
mcode2arity [lp;rp]) in
816 let nm = ident false arity nm in
818 let args = dots (expression
arity) args in
820 let body = statement
arity body in
821 make_rule_elem stm
tgt arity (Ast0.Iterator
(nm,lp,args,rp,body,aft
))
822 | Ast0.Switch
(switch
,lp,exp,rp,lb,decls,cases
,rb) ->
824 stm_same (mcode2line switch
)
825 (List.map
mcode2arity [switch
;lp;rp;lb;rb]) in
826 let switch = mcode switch in
828 let exp = expression
arity exp in
831 let decls = dots (statement
arity) decls in
832 let cases = dots (case_line
arity) cases in
834 make_rule_elem stm
tgt arity
835 (Ast0.Switch
(switch,lp,exp,rp,lb,decls,cases,rb))
836 | Ast0.Break
(br
,sem) ->
837 let arity = stm_same (mcode2line br
) (List.map
mcode2arity [br
;sem]) in
839 let sem = mcode sem in
840 make_rule_elem stm
tgt arity (Ast0.Break
(br,sem))
841 | Ast0.Continue
(cont
,sem) ->
843 stm_same (mcode2line cont
) (List.map
mcode2arity [cont
;sem]) in
844 let cont = mcode cont in
845 let sem = mcode sem in
846 make_rule_elem stm
tgt arity (Ast0.Continue
(cont,sem))
847 | Ast0.Label
(l,dd
) ->
848 let arity = mcode2arity dd
in
849 let l = ident false tgt l in
851 make_rule_elem stm
tgt arity (Ast0.Label
(l,dd))
852 | Ast0.Goto
(goto
,l,sem) ->
854 stm_same (mcode2line goto
) (List.map
mcode2arity [goto
;sem]) in
855 let goto = mcode goto in
856 let l = ident false arity l in
857 let sem = mcode sem in
858 make_rule_elem stm
tgt arity (Ast0.Goto
(goto,l,sem))
859 | Ast0.Return
(ret
,sem) ->
860 let arity = stm_same (mcode2line ret
) (List.map
mcode2arity [ret
;sem]) in
861 let ret = mcode ret in
862 let sem = mcode sem in
863 make_rule_elem stm
tgt arity (Ast0.Return
(ret,sem))
864 | Ast0.ReturnExpr
(ret,exp,sem) ->
865 let arity = stm_same (mcode2line ret) (List.map
mcode2arity [ret;sem]) in
866 let ret = mcode ret in
867 let exp = expression
arity exp in
868 let sem = mcode sem in
869 make_rule_elem stm
tgt arity (Ast0.ReturnExpr
(ret,exp,sem))
870 | Ast0.MetaStmt
(name,pure
) ->
871 let arity = stm_same (mcode2line name) [mcode2arity name] in
872 let name = mcode name in
873 make_rule_elem stm
tgt arity (Ast0.MetaStmt
(name,pure
))
874 | Ast0.MetaStmtList
(name,pure
) ->
875 let arity = stm_same (mcode2line name) [mcode2arity name] in
876 let name = mcode name in
877 make_rule_elem stm
tgt arity (Ast0.MetaStmtList
(name,pure
))
879 let new_exp = top_expression true tgt exp in
881 (match Ast0.unwrap
new_exp with
883 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
884 | Ast0.UniqueExp
(exp) ->
885 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Exp
(exp)))
886 | _
-> Ast0.Exp
(new_exp))
887 | Ast0.TopExp
(exp) ->
888 let new_exp = top_expression true tgt exp in
890 (match Ast0.unwrap
new_exp with
892 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
893 | Ast0.UniqueExp
(exp) ->
894 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopExp
(exp)))
895 | _
-> Ast0.TopExp
(new_exp))
897 let new_ty = typeC
tgt ty in (* opt makes no sense alone at top level *)
899 (match Ast0.unwrap
new_ty with
901 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
902 | Ast0.UniqueType
(ty) ->
903 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.Ty
(ty)))
904 | _
-> Ast0.Ty
(new_ty))
905 | Ast0.TopInit
(init) ->
906 let new_init = initialiser
tgt init in
908 (match Ast0.unwrap
new_init with
910 Ast0.OptStm
(Ast0.rewrap stm
(Ast0.TopInit
(init)))
911 | Ast0.UniqueIni
(init) ->
912 Ast0.UniqueStm
(Ast0.rewrap stm
(Ast0.TopInit
(init)))
913 | _
-> Ast0.TopInit
(new_init))
914 | Ast0.Disj
(starter
,rule_elem_dots_list
,mids
,ender
) ->
916 List.map
(function x
-> concat_dots (statement
tgt) x
)
917 rule_elem_dots_list
in
918 let (found_opt
,unopt
) =
920 (function (found_opt
,lines
) ->
923 (* previously just checked the last thing in the list,
924 but everything should be optional for the whole thing to
927 match Ast0.unwrap x
with
928 Ast0.OptStm
(x
) -> true
931 match Ast0.unwrap x
with
934 if List.for_all
is_opt l
935 then (true,List.map
unopt l)
938 match Ast0.unwrap x
with
940 (l,function l -> Ast0.rewrap x
(Ast0.DOTS
l))
942 (l,function l -> Ast0.rewrap x
(Ast0.CIRCLES
l))
944 (l,function l -> Ast0.rewrap x
(Ast0.STARS
l)) in
945 let (found_opt
,l) = rebuild l in
946 (found_opt
,(k
l)::lines
))
948 let unopt = List.rev
unopt in
951 make_rule_elem stm
tgt Ast0.OPT
(Ast0.Disj
(starter
,unopt,mids
,ender
))
952 else Ast0.rewrap stm
(Ast0.Disj
(starter
,stms,mids
,ender
))
953 | Ast0.Nest
(starter
,rule_elem_dots
,ender
,whn
,multi
) ->
954 let new_rule_elem_dots =
955 concat_dots (statement
Ast0.NONE
) rule_elem_dots
in
958 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
959 (expression
Ast0.NONE
))
962 (Ast0.Nest
(starter
,new_rule_elem_dots,ender
,whn,multi
))
963 | Ast0.Dots
(dots,whn) ->
964 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
965 let dots = mcode dots in
968 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
969 (expression
Ast0.NONE
))
971 make_rule_elem stm
tgt arity (Ast0.Dots
(dots,whn))
972 | Ast0.Circles
(dots,whn) ->
973 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
974 let dots = mcode dots in
977 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
978 (expression
Ast0.NONE
))
980 make_rule_elem stm
tgt arity (Ast0.Circles
(dots,whn))
981 | Ast0.Stars
(dots,whn) ->
982 let arity = stm_same (mcode2line dots) [mcode2arity dots] in
983 let dots = mcode dots in
986 (whencode (concat_dots (statement
Ast0.NONE
)) (statement
Ast0.NONE
)
987 (expression
Ast0.NONE
))
989 make_rule_elem stm
tgt arity (Ast0.Stars
(dots,whn))
990 | Ast0.FunDecl
(bef
,fi
,name,lp,params,rp,lbrace,body,rbrace) ->
992 all_same true tgt (mcode2line lp)
993 ((List.map
mcode2arity [lp;rp;lbrace;rbrace]) @ (fninfo2arity fi
)) in
994 let fi = List.map
(fninfo
arity) fi in
995 let name = ident false arity name in
997 let params = parameter_list
arity params in
999 let lbrace = mcode lbrace in
1000 let body = dots (statement
arity) body in
1001 let rbrace = mcode rbrace in
1002 make_rule_elem stm
tgt arity
1003 (Ast0.FunDecl
(bef
,fi,name,lp,params,rp,lbrace,body,rbrace))
1004 | Ast0.Include
(inc
,s
) ->
1006 all_same true tgt (mcode2line inc
) [mcode2arity inc
; mcode2arity s
] in
1007 let inc = mcode inc in
1009 make_rule_elem stm
tgt arity (Ast0.Include
(inc,s))
1010 | Ast0.Undef
(def
,id) ->
1011 let arity = all_same true tgt (mcode2line def
) [mcode2arity def
] in
1012 let def = mcode def in
1013 let id = ident false arity id in
1014 make_rule_elem stm
tgt arity (Ast0.Undef
(def,id))
1015 | Ast0.Define
(def,id,params,body) ->
1016 let arity = all_same true tgt (mcode2line def) [mcode2arity def] in
1017 let def = mcode def in
1018 let id = ident false arity id in
1019 let params = define_parameters
arity params in
1020 let body = dots (statement
arity) body in
1021 make_rule_elem stm
tgt arity (Ast0.Define
(def,id,params,body))
1022 | Ast0.OptStm
(_
) | Ast0.UniqueStm
(_
) | Ast0.AsStmt _
->
1023 failwith
"unexpected code"
1025 and define_parameters
tgt params =
1026 match Ast0.unwrap
params with
1027 Ast0.NoParams
-> params
1028 | Ast0.DParams
(lp,params,rp) ->
1030 all_same true tgt (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
1031 let lp = mcode lp in
1032 let params = dots (define_param
arity) params in
1033 let rp = mcode rp in
1034 Ast0.rewrap
params (Ast0.DParams
(lp,params,rp))
1036 and make_define_param x
=
1038 (function x
-> Ast0.OptDParam x
)
1039 (function x
-> Ast0.UniqueDParam x
)
1042 and define_param
tgt param
=
1043 match Ast0.unwrap param
with
1045 let new_id = ident true tgt id in
1047 (match Ast0.unwrap
new_id with
1048 Ast0.OptIdent
(id) ->
1049 Ast0.OptDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
1050 | Ast0.UniqueIdent
(decl
) ->
1051 Ast0.UniqueDParam
(Ast0.rewrap param
(Ast0.DParam
(id)))
1052 | _
-> Ast0.DParam
(new_id))
1053 | Ast0.DPComma
(cm) ->
1055 all_same true tgt (mcode2line cm) [mcode2arity cm] in
1056 let cm = mcode cm in
1057 make_define_param param
tgt arity (Ast0.DPComma
(cm))
1058 | Ast0.DPdots
(dots) ->
1060 all_same true tgt (mcode2line dots) [mcode2arity dots] in
1061 let dots = mcode dots in
1062 make_define_param param
tgt arity (Ast0.DPdots
(dots))
1063 | Ast0.DPcircles
(circles
) ->
1065 all_same true tgt (mcode2line circles
) [mcode2arity circles
] in
1066 let circles = mcode circles in
1067 make_define_param param
tgt arity (Ast0.DPcircles
(circles))
1068 | Ast0.OptDParam
(dp
) | Ast0.UniqueDParam
(dp
) ->
1069 failwith
"unexpected code"
1071 and fninfo
arity = function
1072 Ast0.FStorage
(stg) -> Ast0.FStorage
(mcode stg)
1073 | Ast0.FType
(ty) -> Ast0.FType
(typeC
arity ty)
1074 | Ast0.FInline
(inline
) -> Ast0.FInline
(mcode inline
)
1075 | Ast0.FAttr
(attr
) -> Ast0.FAttr
(mcode attr
)
1077 and fninfo2arity fninfo
=
1081 Ast0.FStorage
(stg) -> [mcode2arity stg]
1082 | Ast0.FType
(ty) -> []
1083 | Ast0.FInline
(inline
) -> [mcode2arity inline
]
1084 | Ast0.FAttr
(attr
) -> [mcode2arity attr
])
1087 and whencode notfn alwaysfn expression
= function
1088 Ast0.WhenNot a
-> Ast0.WhenNot
(notfn a
)
1089 | Ast0.WhenAlways a
-> Ast0.WhenAlways
(alwaysfn a
)
1090 | Ast0.WhenModifier
(x
) -> Ast0.WhenModifier
(x
)
1091 | Ast0.WhenNotTrue a
-> Ast0.WhenNotTrue
(expression a
)
1092 | Ast0.WhenNotFalse a
-> Ast0.WhenNotFalse
(expression a
)
1094 and make_case_line
=
1096 (function x
-> Ast0.OptCase x
)
1097 (function x
-> failwith
"unique not allowed for case_line")
1099 and case_line
tgt c
=
1100 match Ast0.unwrap c
with
1101 Ast0.Default
(def,colon,code
) ->
1103 all_same true tgt (mcode2line def)
1104 [mcode2arity def; mcode2arity colon] in
1105 let def = mcode def in
1106 let colon = mcode colon in
1107 let code = dots (statement
arity) code in
1108 make_case_line c
tgt arity (Ast0.Default
(def,colon,code))
1109 | Ast0.Case
(case
,exp,colon,code) ->
1111 all_same true tgt (mcode2line case
)
1112 [mcode2arity case
; mcode2arity colon] in
1113 let case = mcode case in
1114 let exp = expression
arity exp in
1115 let colon = mcode colon in
1116 let code = dots (statement
arity) code in
1117 make_case_line c
tgt arity (Ast0.Case
(case,exp,colon,code))
1118 | Ast0.DisjCase
(starter
,case_lines
,mids
,ender
) ->
1119 let case_lines = List.map
(case_line
tgt) case_lines in
1120 (match List.rev
case_lines with
1122 if anyopt xs
(function Ast0.OptCase
(_
) -> true | _
-> false)
1123 then fail c
"opt only allowed in the last disjunct"
1125 Ast0.rewrap c
(Ast0.DisjCase
(starter
,case_lines,mids
,ender
))
1126 | Ast0.OptCase
(_
) -> failwith
"unexpected OptCase"
1128 (* --------------------------------------------------------------------- *)
1129 (* Function declaration *)
1130 (* Haven't thought much about arity here... *)
1132 let top_level tgt t
=
1134 (match Ast0.unwrap t
with
1135 Ast0.FILEINFO
(old_file
,new_file
) ->
1136 if mcode2arity old_file
= Ast0.NONE
&& mcode2arity new_file
= Ast0.NONE
1137 then Ast0.FILEINFO
(mcode old_file
,mcode new_file
)
1138 else fail t
"unexpected arity for file info"
1139 | Ast0.NONDECL
(stmt
) ->
1140 Ast0.NONDECL
(statement
tgt stmt
)
1141 | Ast0.CODE
(rule_elem_dots
) ->
1142 Ast0.CODE
(concat_dots (statement
tgt) rule_elem_dots
)
1143 | Ast0.TOPCODE
(rule_elem_dots
) -> fail t
"eliminated by top_level"
1144 | Ast0.ERRORWORDS
(exps) ->
1145 Ast0.ERRORWORDS
(List.map
(top_expression false Ast0.NONE
) exps)
1146 | Ast0.OTHER
(_
) -> fail t
"eliminated by top_level")
1148 let rule tgt = List.map
(top_level tgt)
1150 (* --------------------------------------------------------------------- *)
1153 let minus_arity code =