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.
28 module Ast
= Ast_cocci
30 let print_plus_flag = ref true
31 let print_minus_flag = ref true
32 let print_newlines_disj = ref true
35 force_newline
(); print_string
" "; open_box
0
38 close_box
(); force_newline
()
40 let print_string_box s
= print_string s
; open_box
0
43 let print_option = Common.do_option
44 let print_between = Common.print_between
46 (* --------------------------------------------------------------------- *)
49 (* avoid polyvariance problems *)
50 let anything : (Ast.anything -> unit) ref = ref (function _
-> ())
52 let rec print_anything str
= function
56 print_between force_newline
58 print_string str
; open_box
0; print_anything_list x
; close_box
())
62 and print_anything_list
= function
65 | bef
::((aft
::_
) as rest
) ->
69 Ast.Rule_elemTag
(_
) | Ast.AssignOpTag
(_
) | Ast.BinaryOpTag
(_
)
70 | Ast.ArithOpTag
(_
) | Ast.LogicalOpTag
(_
)
71 | Ast.Token
("if",_
) | Ast.Token
("while",_
) -> true | _
-> false) or
73 Ast.Rule_elemTag
(_
) | Ast.AssignOpTag
(_
) | Ast.BinaryOpTag
(_
)
74 | Ast.ArithOpTag
(_
) | Ast.LogicalOpTag
(_
) | Ast.Token
("{",_
) -> true
76 if space then print_string
" ";
77 print_anything_list rest
79 let print_around printer term
= function
80 Ast.NOTHING
-> printer term
81 | Ast.BEFORE
(bef
,_
) -> print_anything "<<< " bef
; printer term
82 | Ast.AFTER
(aft
,_
) -> printer term
; print_anything ">>> " aft
83 | Ast.BEFOREAFTER
(bef
,aft
,_
) ->
84 print_anything "<<< " bef
; printer term
; print_anything ">>> " aft
86 let print_string_befaft fn x info
=
88 Ast.Noindent s
| Ast.Indent s
| Ast.Space s
-> print_string s
in
89 List.iter
(function (s
,_
,_
) -> print s
; force_newline
()) info
.Ast.strbef
;
91 List.iter
(function (s
,_
,_
) -> force_newline
(); print s
) info
.Ast.straft
93 let print_meta (r
,x
) = print_string r
; print_string
":"; print_string x
98 Ast.MetaPos
(name
,_
,_
,_
,_
) ->
99 let name = Ast.unwrap_mcode
name in
100 print_string
"@"; print_meta name)
103 let mcode fn
= function
104 (x
, _
, Ast.MINUS
(_
,_
,adj
,plus_stream
), pos
) ->
106 then print_string
(if !Flag.sgrep_mode2
then "*" else "-");
110 (match plus_stream
with
111 Ast.NOREPLACEMENT
-> ()
112 | Ast.REPLACEMENT
(plus_stream
,_
) -> print_anything ">>> " plus_stream
)
113 | (x
, _
, Ast.CONTEXT
(_
,plus_streams
), pos
) ->
116 let fn x
= fn x
; print_pos pos
in
117 print_around fn x plus_streams
118 else (fn x
; print_pos pos
)
119 | (x
, info
, Ast.PLUS _
, pos
) ->
120 let fn x
= fn x
; print_pos pos
in
121 print_string_befaft fn x info
123 let print_mcodekind = function
124 Ast.MINUS
(_
,_
,_
,plus_stream
) ->
125 print_string
"MINUS";
126 (match plus_stream
with
127 Ast.NOREPLACEMENT
-> ()
128 | Ast.REPLACEMENT
(plus_stream
,_
) -> print_anything ">>> " plus_stream
)
129 | Ast.CONTEXT
(_
,plus_streams
) ->
130 print_around (function _
-> print_string
"CONTEXT") () plus_streams
131 | Ast.PLUS _
-> print_string
"PLUS"
133 (* --------------------------------------------------------------------- *)
134 (* --------------------------------------------------------------------- *)
137 let dots between
fn d
=
138 match Ast.unwrap d
with
139 Ast.DOTS
(l
) -> print_between between
fn l
140 | Ast.CIRCLES
(l
) -> print_between between
fn l
141 | Ast.STARS
(l
) -> print_between between
fn l
143 let nest_dots starter ender
fn f d
=
144 mcode print_string starter
;
146 (match Ast.unwrap d
with
147 Ast.DOTS
(l
) -> print_between force_newline
fn l
148 | Ast.CIRCLES
(l
) -> print_between force_newline
fn l
149 | Ast.STARS
(l
) -> print_between force_newline
fn l
);
151 mcode print_string ender
153 (* --------------------------------------------------------------------- *)
156 let print_disj_list fn l
=
157 if !print_newlines_disj
158 then (force_newline
(); print_string
"("; force_newline
())
159 else print_string
"(";
162 if !print_newlines_disj
163 then (force_newline
(); print_string
"|"; force_newline
())
164 else print_string
" | ")
166 if !print_newlines_disj
167 then (force_newline
(); print_string
")"; force_newline
())
168 else print_string
")"
170 (* --------------------------------------------------------------------- *)
172 let print_type keep info
= function
174 (* print_string "/* ";
175 print_string "keep:"; print_unitary keep;
176 print_string " inherited:"; print_bool inherited;
181 print_between (function _ -> print_string ", ") Type_cocci.typeC ty;(*
182 print_string "keep:"; print_unitary keep;
183 print_string " inherited:"; print_bool inherited;*)
186 (* --------------------------------------------------------------------- *)
187 (* Contraint on Identifier and Function *)
188 (* FIXME: Not called at the moment *)
190 let rec idconstraint = function
191 Ast.IdNoConstraint
-> print_string
"/* No constraint */"
192 | Ast.IdNegIdSet
(str
,meta
) ->
193 List.iter
(function s
-> print_string
(" "^s
)) str
;
194 List.iter
(function (r
,n
) -> print_string
" "; print_meta(r
,n
)) meta
195 | Ast.IdRegExpConstraint re
-> regconstraint re
197 and regconstraint
= function
198 Ast.IdRegExp
(re
,_
) ->
199 print_string
"~= \""; print_string re
; print_string
"\""
200 | Ast.IdNotRegExp
(re
,_
) ->
201 print_string
"~!= \""; print_string re
; print_string
"\""
203 (* --------------------------------------------------------------------- *)
207 match Ast.unwrap i
with
208 Ast.Id
(name) -> mcode print_string
name
209 | Ast.MetaId
(name,_
,keep
,inherited
) -> mcode print_meta name
210 | Ast.MetaFunc
(name,_
,_
,_
) -> mcode print_meta name
211 | Ast.MetaLocalFunc
(name,_
,_
,_
) -> mcode print_meta name
212 | Ast.DisjId
(id_list
) -> print_disj_list ident id_list
213 | Ast.OptIdent
(id
) -> print_string
"?"; ident id
214 | Ast.UniqueIdent
(id
) -> print_string
"!"; ident id
216 and print_unitary
= function
217 Type_cocci.Unitary
-> print_string
"unitary"
218 | Type_cocci.Nonunitary
-> print_string
"nonunitary"
219 | Type_cocci.Saved
-> print_string
"saved"
221 (* --------------------------------------------------------------------- *)
224 let rec expression e
=
225 match Ast.unwrap e
with
226 Ast.Ident
(id
) -> ident id
227 | Ast.Constant
(const
) -> mcode constant const
228 | Ast.FunCall
(fn,lp
,args
,rp
) ->
229 expression fn; mcode print_string_box lp
;
230 dots (function _
-> ()) expression args
;
231 close_box
(); mcode print_string rp
232 | Ast.Assignment
(left
,op
,right
,simple
) ->
233 expression left
; print_string
" "; mcode assignOp op
;
234 print_string
" "; expression right
235 | Ast.Sequence
(left
,op
,right
) ->
236 expression left
; mcode print_string op
;
237 print_string
" "; expression right
238 | Ast.CondExpr
(exp1
,why
,exp2
,colon
,exp3
) ->
239 expression exp1
; print_string
" "; mcode print_string why
;
240 print_option (function e
-> print_string
" "; expression e
) exp2
;
241 print_string
" "; mcode print_string colon
; expression exp3
242 | Ast.Postfix
(exp
,op
) -> expression exp
; mcode fixOp op
243 | Ast.Infix
(exp
,op
) -> mcode fixOp op
; expression exp
244 | Ast.Unary
(exp
,op
) -> mcode unaryOp op
; expression exp
245 | Ast.Binary
(left
,op
,right
) ->
246 expression left
; print_string
" "; mcode binaryOp op
; print_string
" ";
248 | Ast.Nested
(left
,op
,right
) ->
249 expression left
; print_string
" "; mcode binaryOp op
; print_string
" ";
251 | Ast.Paren
(lp
,exp
,rp
) ->
252 mcode print_string_box lp
; expression exp
; close_box
();
253 mcode print_string rp
254 | Ast.ArrayAccess
(exp1
,lb
,exp2
,rb
) ->
255 expression exp1
; mcode print_string_box lb
; expression exp2
; close_box
();
256 mcode print_string rb
257 | Ast.RecordAccess
(exp
,pt
,field
) ->
258 expression exp
; mcode print_string pt
; ident field
259 | Ast.RecordPtAccess
(exp
,ar
,field
) ->
260 expression exp
; mcode print_string ar
; ident field
261 | Ast.Cast
(lp
,ty
,rp
,exp
) ->
262 mcode print_string_box lp
; fullType ty
; close_box
();
263 mcode print_string rp
; expression exp
264 | Ast.SizeOfExpr
(sizeof
,exp
) ->
265 mcode print_string sizeof
; expression exp
266 | Ast.SizeOfType
(sizeof
,lp
,ty
,rp
) ->
267 mcode print_string sizeof
;
268 mcode print_string_box lp
; fullType ty
; close_box
();
269 mcode print_string rp
270 | Ast.TypeExp
(ty
) -> fullType ty
271 | Ast.Constructor
(lp
,ty
,rp
,init
) ->
272 mcode print_string_box lp
; fullType ty
; close_box
();
273 mcode print_string rp
; initialiser init
275 | Ast.MetaErr
(name,_
,_
,_
) -> mcode print_meta name
276 | Ast.MetaExpr
(name,_
,keep
,ty
,form
,inherited
) ->
277 mcode print_meta name; print_type keep inherited ty
278 | Ast.MetaExprList
(name,_
,_
,_
) -> mcode print_meta name
279 | Ast.AsExpr
(exp
,asexp
) -> expression exp
; print_string
"@"; expression asexp
280 | Ast.EComma
(cm
) -> mcode print_string cm
; print_space
()
281 | Ast.DisjExpr
(exp_list
) -> print_disj_list expression exp_list
282 | Ast.NestExpr
(starter
,expr_dots
,ender
,Some whencode
,multi
) ->
283 nest_dots starter ender
expression
284 (function _
-> print_string
" when != "; expression whencode
)
286 | Ast.NestExpr
(starter
,expr_dots
,ender
,None
,multi
) ->
287 nest_dots starter ender
expression (function _
-> ()) expr_dots
288 | Ast.Edots
(dots,Some whencode
)
289 | Ast.Ecircles
(dots,Some whencode
)
290 | Ast.Estars
(dots,Some whencode
) ->
291 mcode print_string
dots; print_string
" when != "; expression whencode
292 | Ast.Edots
(dots,None
)
293 | Ast.Ecircles
(dots,None
)
294 | Ast.Estars
(dots,None
) -> mcode print_string
dots
295 | Ast.OptExp
(exp
) -> print_string
"?"; expression exp
296 | Ast.UniqueExp
(exp
) -> print_string
"!"; expression exp
298 and unaryOp
= function
299 Ast.GetRef
-> print_string
"&"
300 | Ast.GetRefLabel
-> print_string
"&&"
301 | Ast.DeRef
-> print_string
"*"
302 | Ast.UnPlus
-> print_string
"+"
303 | Ast.UnMinus
-> print_string
"-"
304 | Ast.Tilde
-> print_string
"~"
305 | Ast.Not
-> print_string
"!"
307 and assignOp
= function
308 Ast.SimpleAssign
-> print_string
"="
309 | Ast.OpAssign
(aop
) -> arithOp aop
; print_string
"="
312 Ast.Dec
-> print_string
"--"
313 | Ast.Inc
-> print_string
"++"
315 and binaryOp
= function
316 Ast.Arith
(aop
) -> arithOp aop
317 | Ast.Logical
(lop
) -> logicalOp lop
319 and arithOp
= function
320 Ast.Plus
-> print_string
"+"
321 | Ast.Minus
-> print_string
"-"
322 | Ast.Mul
-> print_string
"*"
323 | Ast.Div
-> print_string
"/"
324 | Ast.Mod
-> print_string
"%"
325 | Ast.DecLeft
-> print_string
"<<"
326 | Ast.DecRight
-> print_string
">>"
327 | Ast.And
-> print_string
"&"
328 | Ast.Or
-> print_string
"|"
329 | Ast.Xor
-> print_string
"^"
331 and logicalOp
= function
332 Ast.Inf
-> print_string
"<"
333 | Ast.Sup
-> print_string
">"
334 | Ast.InfEq
-> print_string
"<="
335 | Ast.SupEq
-> print_string
">="
336 | Ast.Eq
-> print_string
"=="
337 | Ast.NotEq
-> print_string
"!="
338 | Ast.AndLog
-> print_string
"&&"
339 | Ast.OrLog
-> print_string
"||"
341 and constant
= function
342 Ast.String
(s
) -> print_string
"\""; print_string s
; print_string
"\""
343 | Ast.Char
(s
) -> print_string
"'"; print_string s
; print_string
"'"
344 | Ast.Int
(s
) -> print_string s
345 | Ast.Float
(s
) -> print_string s
347 (* --------------------------------------------------------------------- *)
350 and storage
= function
351 Ast.Static
-> print_string
"static "
352 | Ast.Auto
-> print_string
"auto "
353 | Ast.Register
-> print_string
"register "
354 | Ast.Extern
-> print_string
"extern "
356 (* --------------------------------------------------------------------- *)
360 match Ast.unwrap ft
with
362 print_option (function x
-> mcode const_vol x
; print_string
" ") cv
;
364 | Ast.AsType
(ty
,asty
) -> fullType ty
; print_string
"@"; fullType asty
365 | Ast.DisjType
(decls
) -> print_disj_list fullType decls
366 | Ast.OptType
(ty
) -> print_string
"?"; fullType ty
367 | Ast.UniqueType
(ty
) -> print_string
"!"; fullType ty
369 and print_function_pointer
(ty
,lp1
,star
,rp1
,lp2
,params
,rp2
) fn =
370 fullType ty
; mcode print_string lp1
; mcode print_string star
; fn();
371 mcode print_string rp1
; mcode print_string lp1
;
372 parameter_list params
; mcode print_string rp2
374 and print_function_type
(ty
,lp1
,params
,rp1
) fn =
375 print_option fullType ty
; fn(); mcode print_string lp1
;
376 parameter_list params
; mcode print_string rp1
378 and print_fninfo
= function
379 Ast.FStorage
(stg
) -> mcode storage stg
380 | Ast.FType
(ty
) -> fullType ty
381 | Ast.FInline
(inline
) -> mcode print_string inline
; print_string
" "
382 | Ast.FAttr
(attr
) -> mcode print_string attr
; print_string
" "
385 match Ast.unwrap ty
with
386 Ast.BaseType
(ty
,strings
) ->
387 List.iter
(function s
-> mcode print_string s
; print_string
" ") strings
388 | Ast.SignedT
(sgn
,ty
) -> mcode sign sgn
; print_option typeC ty
389 | Ast.Pointer
(ty
,star
) -> fullType ty
; mcode print_string star
390 | Ast.FunctionPointer
(ty
,lp1
,star
,rp1
,lp2
,params
,rp2
) ->
391 print_function_pointer
(ty
,lp1
,star
,rp1
,lp2
,params
,rp2
)
393 | Ast.FunctionType
(_
,ty
,lp1
,params
,rp1
) ->
394 print_function_type
(ty
,lp1
,params
,rp1
) (function _
-> ())
395 | Ast.Array
(ty
,lb
,size
,rb
) ->
396 fullType ty
; mcode print_string lb
; print_option expression size
;
397 mcode print_string rb
398 | Ast.EnumName
(kind
,name) ->
399 mcode print_string kind
;
400 print_option (function x
-> ident x
; print_string
" ") name
401 | Ast.EnumDef
(ty
,lb
,ids
,rb
) ->
402 fullType ty
; mcode print_string lb
;
403 dots force_newline
expression ids
;
404 mcode print_string rb
405 | Ast.StructUnionName
(kind
,name) ->
406 mcode structUnion kind
;
407 print_option (function x
-> ident x
; print_string
" ") name
408 | Ast.StructUnionDef
(ty
,lb
,decls
,rb
) ->
409 fullType ty
; mcode print_string lb
;
410 dots force_newline declaration decls
;
411 mcode print_string rb
412 | Ast.TypeName
(name) -> mcode print_string
name; print_string
" "
413 | Ast.MetaType
(name,_
,_
) ->
414 mcode print_meta name; print_string
" "
416 and baseType
= function
417 Ast.VoidType
-> print_string
"void "
418 | Ast.CharType
-> print_string
"char "
419 | Ast.ShortType
-> print_string
"short "
420 | Ast.ShortIntType
-> print_string
"short int "
421 | Ast.IntType
-> print_string
"int "
422 | Ast.DoubleType
-> print_string
"double "
423 | Ast.LongDoubleType
-> print_string
"long double "
424 | Ast.FloatType
-> print_string
"float "
425 | Ast.LongType
-> print_string
"long "
426 | Ast.LongIntType
-> print_string
"long int "
427 | Ast.LongLongType
-> print_string
"long long "
428 | Ast.LongLongIntType
-> print_string
"long long int "
429 | Ast.SizeType
-> print_string
"size_t "
430 | Ast.SSizeType
-> print_string
"ssize_t "
431 | Ast.PtrDiffType
-> print_string
"ptrdiff_t "
433 and structUnion
= function
434 Ast.Struct
-> print_string
"struct "
435 | Ast.Union
-> print_string
"union "
438 Ast.Signed
-> print_string
"signed "
439 | Ast.Unsigned
-> print_string
"unsigned "
441 and const_vol
= function
442 Ast.Const
-> print_string
"const"
443 | Ast.Volatile
-> print_string
"volatile"
445 (* --------------------------------------------------------------------- *)
446 (* Variable declaration *)
447 (* Even if the Cocci program specifies a list of declarations, they are
448 split out into multiple declarations of a single variable each. *)
450 and print_named_type ty id
=
451 match Ast.unwrap ty
with
452 Ast.Type
(_
,None
,ty1
) ->
453 (match Ast.unwrap ty1
with
454 Ast.FunctionPointer
(ty
,lp1
,star
,rp1
,lp2
,params
,rp2
) ->
455 print_function_pointer
(ty
,lp1
,star
,rp1
,lp2
,params
,rp2
)
456 (function _
-> print_string
" "; ident id
)
457 | Ast.FunctionType
(_
,ty
,lp1
,params
,rp1
) ->
458 print_function_type
(ty
,lp1
,params
,rp1
)
459 (function _
-> print_string
" "; ident id
)
460 | Ast.Array
(ty
,lb
,size
,rb
) ->
462 match Ast.unwrap ty
with
463 Ast.Array
(ty
,lb
,size
,rb
) ->
464 (match Ast.unwrap ty
with
467 (function x
-> mcode const_vol x
; print_string
" ")
472 mcode print_string lb
;
473 print_option expression size
;
474 mcode print_string rb
)
475 | _
-> failwith
"complex array types not supported")
476 | _
-> typeC ty
; ident id
; k
() in
477 loop ty1
(function _
-> ())
478 | _
-> fullType ty
; ident id
)
479 | _
-> fullType ty
; ident id
482 match Ast.unwrap d
with
483 Ast.MetaDecl
(name,_
,_
) | Ast.MetaField
(name,_
,_
)
484 | Ast.MetaFieldList
(name,_
,_
,_
) ->
485 mcode print_meta name
486 | Ast.AsDecl
(decl
,asdecl
) -> declaration decl
; print_string
"@";
488 | Ast.Init
(stg
,ty
,id
,eq
,ini
,sem
) ->
489 print_option (mcode storage
) stg
; print_named_type ty id
;
490 print_string
" "; mcode print_string eq
;
491 print_string
" "; initialiser ini
; mcode print_string sem
492 | Ast.UnInit
(stg
,ty
,id
,sem
) ->
493 print_option (mcode storage
) stg
; print_named_type ty id
;
494 mcode print_string sem
495 | Ast.MacroDecl
(name,lp
,args
,rp
,sem
) ->
496 ident name; mcode print_string_box lp
;
497 dots (function _
-> ()) expression args
;
498 close_box
(); mcode print_string rp
; mcode print_string sem
499 | Ast.MacroDeclInit
(name,lp
,args
,rp
,eq
,ini
,sem
) ->
500 ident name; mcode print_string_box lp
;
501 dots (function _
-> ()) expression args
;
502 close_box
(); mcode print_string rp
;
503 print_string
" "; mcode print_string eq
;
504 print_string
" "; initialiser ini
; mcode print_string sem
505 | Ast.TyDecl
(ty
,sem
) -> fullType ty
; mcode print_string sem
506 | Ast.Typedef
(stg
,ty
,id
,sem
) ->
507 mcode print_string stg
; print_string
" "; fullType ty
; typeC id
;
508 mcode print_string sem
509 | Ast.DisjDecl
(decls
) -> print_disj_list declaration decls
510 | Ast.Ddots
(dots,Some whencode
) ->
511 mcode print_string
dots; print_string
" when != "; declaration whencode
512 | Ast.Ddots
(dots,None
) -> mcode print_string
dots
513 | Ast.OptDecl
(decl
) -> print_string
"?"; declaration decl
514 | Ast.UniqueDecl
(decl
) -> print_string
"!"; declaration decl
516 (* --------------------------------------------------------------------- *)
520 match Ast.unwrap i
with
521 Ast.MetaInit
(name,_
,_
) ->
522 mcode print_meta name; print_string
" "
523 | Ast.MetaInitList
(name,_
,_
,_
) ->
524 mcode print_meta name; print_string
" "
525 | Ast.AsInit
(ini
,asini
) -> initialiser ini
; print_string
"@";
527 | Ast.InitExpr
(exp
) -> expression exp
528 | Ast.ArInitList
(lb
,initlist
,rb
) ->
529 mcode print_string lb
; open_box
0;
530 dots force_newline initialiser initlist
; close_box
();
531 mcode print_string rb
532 | Ast.StrInitList
(allminus
,lb
,initlist
,rb
,whencode
) ->
533 mcode print_string lb
; open_box
0;
534 if not
(whencode
= [])
536 (print_string
" WHEN != ";
537 print_between (function _
-> print_string
" v ")
538 initialiser whencode
;
540 List.iter initialiser initlist
; close_box
();
541 mcode print_string rb
542 | Ast.InitGccExt
(designators
,eq
,ini
) ->
543 List.iter designator designators
; print_string
" ";
544 mcode print_string eq
; print_string
" "; initialiser ini
545 | Ast.InitGccName
(name,eq
,ini
) ->
546 ident name; mcode print_string eq
; initialiser ini
547 | Ast.IComma
(comma
) -> mcode print_string comma
; force_newline
()
548 | Ast.Idots
(dots,Some whencode
) ->
549 mcode print_string
dots; print_string
" when != "; initialiser whencode
550 | Ast.Idots
(dots,None
) -> mcode print_string
dots
551 | Ast.OptIni
(ini
) -> print_string
"?"; initialiser ini
552 | Ast.UniqueIni
(ini
) -> print_string
"!"; initialiser ini
554 and designator
= function
555 Ast.DesignatorField
(dot
,id
) -> mcode print_string dot
; ident id
556 | Ast.DesignatorIndex
(lb
,exp
,rb
) ->
557 mcode print_string lb
; expression exp
; mcode print_string rb
558 | Ast.DesignatorRange
(lb
,min
,dots,max
,rb
) ->
559 mcode print_string lb
; expression min
; mcode print_string
dots;
560 expression max
; mcode print_string rb
562 (* --------------------------------------------------------------------- *)
565 and parameterTypeDef p
=
566 match Ast.unwrap p
with
567 Ast.VoidParam
(ty
) -> fullType ty
568 | Ast.Param
(ty
,Some id
) -> print_named_type ty id
569 | Ast.Param
(ty
,None
) -> fullType ty
570 | Ast.MetaParam
(name,_
,_
) -> mcode print_meta name
571 | Ast.MetaParamList
(name,_
,_
,_
) -> mcode print_meta name
572 | Ast.PComma
(cm
) -> mcode print_string cm
; print_space
()
573 | Ast.Pdots
(dots) -> mcode print_string
dots
574 | Ast.Pcircles
(dots) -> mcode print_string
dots
575 | Ast.OptParam
(param
) -> print_string
"?"; parameterTypeDef param
576 | Ast.UniqueParam
(param
) -> print_string
"!"; parameterTypeDef param
578 and parameter_list l
= dots (function _
-> ()) parameterTypeDef l
580 (* --------------------------------------------------------------------- *)
583 let rec rule_elem arity re
=
584 match Ast.unwrap re
with
585 Ast.FunHeader
(bef
,allminus
,fninfo
,name,lp
,params
,rp
) ->
586 mcode (function _
-> ()) ((),Ast.no_info
,bef
,[]);
587 print_string arity
; List.iter print_fninfo fninfo
;
588 ident name; mcode print_string_box lp
;
589 parameter_list params
; close_box
(); mcode print_string rp
;
591 | Ast.Decl
(bef
,allminus
,decl
) ->
592 mcode (function _
-> ()) ((),Ast.no_info
,bef
,[]);
595 | Ast.SeqStart
(brace
) ->
596 print_string arity
; mcode print_string brace
;
597 if !print_newlines_disj then start_block()
598 | Ast.SeqEnd
(brace
) ->
599 if !print_newlines_disj then end_block();
600 print_string arity
; mcode print_string brace
601 | Ast.ExprStatement
(exp
,sem
) ->
602 print_string arity
; print_option expression exp
; mcode print_string sem
603 | Ast.IfHeader
(iff
,lp
,exp
,rp
) ->
605 mcode print_string iff
; print_string
" "; mcode print_string_box lp
;
606 expression exp
; close_box
(); mcode print_string rp
; print_string
" "
608 print_string arity
; mcode print_string els
; print_string
" "
609 | Ast.WhileHeader
(whl
,lp
,exp
,rp
) ->
611 mcode print_string whl
; print_string
" "; mcode print_string_box lp
;
612 expression exp
; close_box
(); mcode print_string rp
; print_string
" "
614 print_string arity
; mcode print_string d
; print_string
" "
615 | Ast.WhileTail
(whl
,lp
,exp
,rp
,sem
) ->
617 mcode print_string whl
; print_string
" "; mcode print_string_box lp
;
618 expression exp
; close_box
(); mcode print_string rp
;
619 mcode print_string sem
620 | Ast.ForHeader
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
) ->
622 mcode print_string fr
; mcode print_string_box lp
;
623 print_option expression e1
; mcode print_string sem1
;
624 print_option expression e2
; mcode print_string sem2
;
625 print_option expression e3
; close_box
();
626 mcode print_string rp
; print_string
" "
627 | Ast.IteratorHeader
(nm
,lp
,args
,rp
) ->
629 ident nm
; print_string
" "; mcode print_string_box lp
;
630 dots (function _
-> ()) expression args
; close_box
();
631 mcode print_string rp
; print_string
" "
632 | Ast.SwitchHeader
(switch
,lp
,exp
,rp
) ->
634 mcode print_string switch
; print_string
" "; mcode print_string_box lp
;
635 expression exp
; close_box
(); mcode print_string rp
; print_string
" "
636 | Ast.Break
(br
,sem
) ->
637 print_string arity
; mcode print_string br
; mcode print_string sem
638 | Ast.Continue
(cont
,sem
) ->
639 print_string arity
; mcode print_string cont
; mcode print_string sem
640 | Ast.Label
(l
,dd
) -> ident l
; mcode print_string dd
641 | Ast.Goto
(goto
,l
,sem
) ->
642 mcode print_string goto
; ident l
; mcode print_string sem
643 | Ast.Return
(ret
,sem
) ->
644 print_string arity
; mcode print_string ret
; mcode print_string sem
645 | Ast.ReturnExpr
(ret
,exp
,sem
) ->
646 print_string arity
; mcode print_string ret
; print_string
" ";
647 expression exp
; mcode print_string sem
648 | Ast.MetaRuleElem
(name,_
,_
) ->
649 print_string arity
; mcode print_meta name
650 | Ast.MetaStmt
(name,_
,_
,_
) ->
651 print_string arity
; mcode print_meta name
652 | Ast.MetaStmtList
(name,_
,_
) ->
653 print_string arity
; mcode print_meta name
654 | Ast.Exp
(exp
) -> print_string arity
; expression exp
655 | Ast.TopExp
(exp
) -> print_string arity
; expression exp
656 | Ast.Ty
(ty
) -> print_string arity
; fullType ty
657 | Ast.TopInit
(init
) -> initialiser init
658 | Ast.Include
(inc
,s
) ->
659 mcode print_string inc
; print_string
" "; mcode inc_file s
660 | Ast.Undef
(def
,id
) ->
661 mcode print_string def
; print_string
" "; ident id
662 | Ast.DefineHeader
(def
,id
,params
) ->
663 mcode print_string def
; print_string
" "; ident id
;
664 print_define_parameters params
665 | Ast.Default
(def
,colon
) ->
666 mcode print_string def
; mcode print_string colon
; print_string
" "
667 | Ast.Case
(case
,exp
,colon
) ->
668 mcode print_string case
; print_string
" "; expression exp
;
669 mcode print_string colon
; print_string
" "
670 | Ast.DisjRuleElem
(res
) ->
672 force_newline
(); print_string
"("; force_newline
();
674 (function _
-> force_newline
();print_string
"|"; force_newline
())
677 force_newline
(); print_string
")"
680 and print_define_parameters params
=
681 match Ast.unwrap params
with
683 | Ast.DParams
(lp
,params
,rp
) ->
684 mcode print_string lp
;
685 dots (function _
-> ()) print_define_param params
; mcode print_string rp
687 and print_define_param param
=
688 match Ast.unwrap param
with
689 Ast.DParam
(id
) -> ident id
690 | Ast.DPComma
(comma
) -> mcode print_string comma
691 | Ast.DPdots
(dots) -> mcode print_string
dots
692 | Ast.DPcircles
(circles
) -> mcode print_string circles
693 | Ast.OptDParam
(dp
) -> print_string
"?"; print_define_param dp
694 | Ast.UniqueDParam
(dp
) -> print_string
"!"; print_define_param dp
696 and statement arity s
=
697 match Ast.unwrap s
with
698 Ast.Seq
(lbrace
,body
,rbrace
) ->
699 rule_elem arity lbrace
;
700 dots force_newline
(statement arity
) body
;
701 rule_elem arity rbrace
702 | Ast.IfThen
(header
,branch
,(_
,_
,_
,aft
)) ->
703 rule_elem arity header
; statement arity branch
;
704 mcode (function _
-> ()) ((),Ast.no_info
,aft
,[])
705 | Ast.IfThenElse
(header
,branch1
,els
,branch2
,(_
,_
,_
,aft
)) ->
706 rule_elem arity header
; statement arity branch1
; print_string
" ";
707 rule_elem arity els
; statement arity branch2
;
708 mcode (function _
-> ()) ((),Ast.no_info
,aft
,[])
709 | Ast.While
(header
,body
,(_
,_
,_
,aft
)) ->
710 rule_elem arity header
; statement arity body
;
711 mcode (function _
-> ()) ((),Ast.no_info
,aft
,[])
712 | Ast.Do
(header
,body
,tail
) ->
713 rule_elem arity header
; statement arity body
;
715 | Ast.For
(header
,body
,(_
,_
,_
,aft
)) ->
716 rule_elem arity header
; statement arity body
;
717 mcode (function _
-> ()) ((),Ast.no_info
,aft
,[])
718 | Ast.Iterator
(header
,body
,(_
,_
,_
,aft
)) ->
719 rule_elem arity header
; statement arity body
;
720 mcode (function _
-> ()) ((),Ast.no_info
,aft
,[])
721 | Ast.Switch
(header
,lb
,decls
,cases
,rb
) ->
722 rule_elem arity header
; rule_elem arity lb
;
723 dots force_newline
(statement arity
) decls
;
724 List.iter
(function x
-> case_line arity x
; force_newline
()) cases
;
726 | Ast.Atomic
(re
) -> rule_elem arity re
727 | Ast.FunDecl
(header
,lbrace
,body
,rbrace
) ->
728 rule_elem arity header
; rule_elem arity lbrace
;
729 dots force_newline
(statement arity
) body
;
730 rule_elem arity rbrace
731 | Ast.Disj
([stmt_dots
]) ->
733 dots (function _
-> if !print_newlines_disj then force_newline
())
734 (statement arity
) stmt_dots
735 | Ast.Disj
(stmt_dots_list
) -> (* ignores newline directive for readability *)
737 force_newline
(); print_string
"("; force_newline
();
739 (function _
-> force_newline
();print_string
"|"; force_newline
())
740 (dots force_newline
(statement arity
))
742 force_newline
(); print_string
")"
743 | Ast.Define
(header
,body
) ->
744 rule_elem arity header
; print_string
" ";
745 dots force_newline
(statement arity
) body
746 | Ast.AsStmt
(stm
,asstm
) ->
747 statement arity stm
; print_string
"@"; statement arity asstm
748 | Ast.Nest
(starter
,stmt_dots
,ender
,whn
,multi
,_
,_
) ->
750 nest_dots starter ender
(statement arity
)
753 print_between force_newline
754 (whencode
(dots force_newline
(statement
"")) (statement
"")) whn
;
755 close_box
(); force_newline
())
757 | Ast.Dots
(d
,whn
,_
,_
) | Ast.Circles
(d
,whn
,_
,_
) | Ast.Stars
(d
,whn
,_
,_
) ->
758 print_string arity
; mcode print_string d
;
760 print_between force_newline
761 (whencode
(dots force_newline
(statement
"")) (statement
"")) whn
;
762 close_box
(); force_newline
()
763 | Ast.OptStm
(s
) -> statement
"?" s
764 | Ast.UniqueStm
(s
) -> statement
"!" s
766 and print_statement_when whencode
=
767 print_string
" WHEN != ";
769 print_between (function _
-> print_string
" &"; force_newline
())
770 (dots force_newline
(statement
"")) whencode
;
774 and whencode notfn alwaysfn
= function
776 print_string
" WHEN != "; open_box
0; notfn a
; close_box
()
777 | Ast.WhenAlways a
->
778 print_string
" WHEN = "; open_box
0; alwaysfn a
; close_box
()
779 | Ast.WhenModifier x
-> print_string
" WHEN "; print_when_modif x
780 | Ast.WhenNotTrue a
->
781 print_string
" WHEN != TRUE "; open_box
0; rule_elem "" a
; close_box
()
782 | Ast.WhenNotFalse a
->
783 print_string
" WHEN != FALSE "; open_box
0; rule_elem "" a
; close_box
()
785 and print_when_modif
= function
786 | Ast.WhenAny
-> print_string
"ANY"
787 | Ast.WhenStrict
-> print_string
"STRICT"
788 | Ast.WhenForall
-> print_string
"FORALL"
789 | Ast.WhenExists
-> print_string
"EXISTS"
791 and case_line arity c
=
792 match Ast.unwrap c
with
793 Ast.CaseLine
(header
,code
) ->
794 rule_elem arity header
; print_string
" ";
795 dots force_newline
(statement arity
) code
796 | Ast.OptCase
(case
) -> case_line
"?" case
798 (* --------------------------------------------------------------------- *)
801 and inc_file
= function
804 print_between (function _
-> print_string
"/") inc_elem elems
;
806 | Ast.NonLocal
(elems
) ->
808 print_between (function _
-> print_string
"/") inc_elem elems
;
811 and inc_elem
= function
812 Ast.IncPath s
-> print_string s
813 | Ast.IncDots
-> print_string
"..."
815 (* for export only *)
816 let statement_dots l
= dots force_newline
(statement
"") l
819 match Ast.unwrap t
with
820 Ast.FILEINFO
(old_file
,new_file
) ->
821 print_string
"--- "; mcode print_string old_file
; force_newline
();
822 print_string
"+++ "; mcode print_string new_file
823 | Ast.NONDECL
(stmt
) -> statement
"" stmt
824 | Ast.CODE
(stmt_dots
) ->
825 dots force_newline
(statement
"") stmt_dots
826 | Ast.ERRORWORDS
(exps
) ->
827 print_string
"error words = [";
828 print_between (function _
-> print_string
", ") expression exps
;
832 print_between (function _
-> force_newline
(); force_newline
()) top_level
834 let pp_print_anything x
= !anything x
838 Ast.FullTypeTag
(x
) -> fullType x
839 | Ast.BaseTypeTag
(x
) -> baseType x
840 | Ast.StructUnionTag
(x
) -> structUnion x
841 | Ast.SignTag
(x
) -> sign x
842 | Ast.IdentTag
(x
) -> ident x
843 | Ast.ExpressionTag
(x
) -> expression x
844 | Ast.ConstantTag
(x
) -> constant x
845 | Ast.UnaryOpTag
(x
) -> unaryOp x
846 | Ast.AssignOpTag
(x
) -> assignOp x
847 | Ast.FixOpTag
(x
) -> fixOp x
848 | Ast.BinaryOpTag
(x
) -> binaryOp x
849 | Ast.ArithOpTag
(x
) -> arithOp x
850 | Ast.LogicalOpTag
(x
) -> logicalOp x
851 | Ast.InitTag
(x
) -> initialiser x
852 | Ast.DeclarationTag
(x
) -> declaration x
853 | Ast.StorageTag
(x
) -> storage x
854 | Ast.IncFileTag
(x
) -> inc_file x
855 | Ast.Rule_elemTag
(x
) -> rule_elem "" x
856 | Ast.StatementTag
(x
) -> statement
"" x
857 | Ast.CaseLineTag
(x
) -> case_line
"" x
858 | Ast.ConstVolTag
(x
) -> const_vol x
859 | Ast.Token
(x
,Some info
) -> print_string_befaft print_string x info
860 | Ast.Token
(x
,None
) -> print_string x
863 Ast.Noindent s
| Ast.Indent s
| Ast.Space s
-> print_string s
in
864 print_between force_newline
print xs
865 | Ast.Code
(x
) -> let _ = top_level x
in ()
866 | Ast.ExprDotsTag
(x
) -> dots (function _ -> ()) expression x
867 | Ast.ParamDotsTag
(x
) -> parameter_list x
868 | Ast.StmtDotsTag
(x
) -> dots (function _ -> ()) (statement
"") x
869 | Ast.DeclDotsTag
(x
) -> dots (function _ -> ()) declaration x
870 | Ast.TypeCTag
(x
) -> typeC x
871 | Ast.ParamTag
(x
) -> parameterTypeDef x
872 | Ast.SgrepStartTag
(x
) -> print_string x
873 | Ast.SgrepEndTag
(x
) -> print_string x
875 let rec dep in_and
= function
876 Ast.Dep
(s
) -> print_string s
877 | Ast.AntiDep
(s
) -> print_string
"!"; print_string s
878 | Ast.EverDep
(s
) -> print_string
"ever "; print_string s
879 | Ast.NeverDep
(s
) -> print_string
"never "; print_string s
880 | Ast.AndDep
(s1
,s2
) ->
881 let print_and _ = dep true s1
; print_string
" && "; dep true s2
in
884 else (print_string
"("; print_and(); print_string
")")
885 | Ast.OrDep
(s1
,s2
) ->
886 let print_or _ = dep false s1
; print_string
" || "; dep false s2
in
889 else (print_string
"("; print_or(); print_string
")")
890 | Ast.NoDep
-> print_string
"no_dep"
891 | Ast.FailDep
-> print_string
"fail_dep"
893 let script_header str lang deps code
=
896 print_string
(str ^
":" ^ lang
);
899 | _ -> print_string
" depends on "; dep true deps
);
908 Ast.InitialScriptRule
(name,lang
,deps
,code
) ->
909 script_header "initialize" lang deps code
910 | Ast.FinalScriptRule
(name,lang
,deps
,code
) ->
911 script_header "finalize" lang deps code
912 | Ast.ScriptRule
(name,lang
,deps
,bindings
,script_vars
,code
) ->
913 script_header "script" lang deps code
914 | Ast.CocciRule
(nm
, (deps
, drops
, exists
), x
, _, _) ->
920 | _ -> print_string
" depends on "; dep true deps
);
922 print_string "line ";
923 print_int (Ast.get_line (List.hd x));
927 print_newlines_disj := true;
933 let rule_elem_to_string x
=
934 print_newlines_disj := true;
935 Common.format_to_string
(function _ -> rule_elem "" x
)
937 let ident_to_string x
=
938 print_newlines_disj := true;
939 Common.format_to_string
(function _ -> ident x
)
941 let unparse_to_string x
=
942 print_newlines_disj := true;
943 Common.format_to_string
(function _ -> unparse x
)
945 let print_rule_elem re
=
946 let nl = !print_newlines_disj in
947 print_newlines_disj := false;
949 print_newlines_disj := nl