parsing_cocci/pretty_print_cocci.ml

   1 open Format
   2 module Ast = Ast_cocci
   3
   4 let print_plus_flag = ref true
   5 let print_minus_flag = ref true
   6 let print_newlines_disj = ref true
   7
   8 let start_block str =
   9   force_newline(); print_string "  "; open_box 0
  10
  11 let end_block str =
  12   close_box(); force_newline ()
  13
  14 let print_string_box s = print_string s; open_box 0
  15
  16
  17 let print_option = Common.do_option
  18 let print_between = Common.print_between
  19
  20 (* --------------------------------------------------------------------- *)
  21 (* Modified code *)
  22
  23 (* avoid polyvariance problems *)
  24 let anything : (Ast.anything -> unit) ref = ref (function _ -> ())
  25
  26 let rec print_anything str = function
  27     [] -> ()
  28   | stream ->
  29       start_block();
  30       print_between force_newline
  31         (function x ->
  32           print_string str; open_box 0; print_anything_list x; close_box())
  33         stream;
  34       end_block()
  35
  36 and print_anything_list = function
  37     [] -> ()
  38   | [x] -> !anything x
  39   | bef::((aft::_) as rest) ->
  40       !anything bef;
  41       let space =
  42         (match bef with
  43           Ast.Rule_elemTag(_) | Ast.AssignOpTag(_) | Ast.BinaryOpTag(_)
  44         | Ast.ArithOpTag(_) | Ast.LogicalOpTag(_)
  45         | Ast.Token("if",_) | Ast.Token("while",_) -> true | _ -> false) or
  46         (match aft with
  47           Ast.Rule_elemTag(_) | Ast.AssignOpTag(_) | Ast.BinaryOpTag(_)
  48         | Ast.ArithOpTag(_) | Ast.LogicalOpTag(_) | Ast.Token("{",_) -> true
  49         | _ -> false) in
  50       if space then print_string " ";
  51       print_anything_list rest
  52
  53 let print_around printer term = function
  54     Ast.NOTHING -> printer term
  55   | Ast.BEFORE(bef,_) -> print_anything "<<< " bef; printer term
  56   | Ast.AFTER(aft,_) -> printer term; print_anything ">>> " aft
  57   | Ast.BEFOREAFTER(bef,aft,_) ->
  58       print_anything "<<< " bef; printer term; print_anything ">>> " aft
  59
  60 let print_string_befaft fn x info =
  61   List.iter (function (s,_,_) -> print_string s; force_newline())
  62     info.Ast.strbef;
  63   fn x;
  64   List.iter (function (s,_,_) -> force_newline(); print_string s)
  65     info.Ast.straft
  66
  67 let print_meta (r,x) = print_string r; print_string ":"; print_string x
  68
  69 let print_pos = function
  70     Ast.MetaPos(name,_,_,_,_) ->
  71       let name = Ast.unwrap_mcode name in
  72       print_string "@"; print_meta name
  73   | _ -> ()
  74
  75 let mcode fn = function
  76     (x, _, Ast.MINUS(_,_,adj,plus_stream), pos) ->
  77       if !print_minus_flag
  78       then print_string (if !Flag.sgrep_mode2 then "*" else "-");
  79       fn x; print_pos pos;
  80       if !print_plus_flag
  81       then print_anything ">>> " plus_stream
  82   | (x, _, Ast.CONTEXT(_,plus_streams), pos) ->
  83       if !print_plus_flag
  84       then
  85         let fn x = fn x; print_pos pos in
  86         print_around fn x plus_streams
  87       else (fn x; print_pos pos)
  88   | (x, info, Ast.PLUS _, pos) ->
  89       let fn x = fn x; print_pos pos in
  90       print_string_befaft fn x info
  91
  92 let print_mcodekind = function
  93     Ast.MINUS(_,_,_,plus_stream) ->
  94       print_string "MINUS";
  95       print_anything ">>> " plus_stream
  96   | Ast.CONTEXT(_,plus_streams) ->
  97       print_around (function _ -> print_string "CONTEXT") () plus_streams
  98   | Ast.PLUS _ -> print_string "PLUS"
  99
 100 (* --------------------------------------------------------------------- *)
 101 (* --------------------------------------------------------------------- *)
 102 (* Dots *)
 103
 104 let dots between fn d =
 105   match Ast.unwrap d with
 106     Ast.DOTS(l) -> print_between between fn l
 107   | Ast.CIRCLES(l) -> print_between between fn l
 108   | Ast.STARS(l) -> print_between between fn l
 109
 110 let nest_dots multi fn f d =
 111   let mo s = if multi then "<+"^s else "<"^s in
 112   let mc s = if multi then s^"+>" else s^">" in
 113   match Ast.unwrap d with
 114     Ast.DOTS(l) ->
 115       print_string (mo "..."); f(); start_block();
 116       print_between force_newline fn l;
 117       end_block(); print_string (mc "...")
 118   | Ast.CIRCLES(l) ->
 119       print_string (mo "ooo"); f(); start_block();
 120       print_between force_newline fn l;
 121       end_block(); print_string (mc "ooo")
 122   | Ast.STARS(l) ->
 123       print_string (mo "***"); f(); start_block();
 124       print_between force_newline fn l;
 125       end_block(); print_string (mc "***")
 126
 127 (* --------------------------------------------------------------------- *)
 128
 129 let print_type keep info = function
 130     None -> ()
 131         (* print_string "/* ";
 132            print_string "keep:"; print_unitary keep;
 133            print_string " inherited:"; print_bool inherited;
 134            print_string " */"*)
 135   | Some ty -> ()
 136       (*;
 137       print_string "/* ";
 138       print_between (function _ -> print_string ", ") Type_cocci.typeC ty;(*
 139       print_string "keep:"; print_unitary keep;
 140       print_string " inherited:"; print_bool inherited;*)
 141       print_string " */"*)
 142
 143 (* --------------------------------------------------------------------- *)
 144 (* Contraint on Identifier and Function *)
 145 (* FIXME: Not called at the moment *)
 146
 147 let idconstraint c =
 148   match c with
 149       Ast.IdNoConstraint  -> print_string "/* No constraint */"
 150     | Ast.IdNegIdSet ids     -> List.iter (fun s -> print_string (" "^s)) ids
 151     | Ast.IdRegExp (re,_) -> print_string "~= \""; print_string re; print_string "\""
 152     | Ast.IdNotRegExp (re,_) -> print_string "~!= \""; print_string re; print_string "\""
 153
 154 (* --------------------------------------------------------------------- *)
 155 (* Identifier *)
 156
 157 let rec ident i =
 158   match Ast.unwrap i with
 159       Ast.Id(name) -> mcode print_string name
 160     | Ast.MetaId(name,_,keep,inherited) -> mcode print_meta name
 161     | Ast.MetaFunc(name,_,_,_) -> mcode print_meta name
 162     | Ast.MetaLocalFunc(name,_,_,_) -> mcode print_meta name
 163     | Ast.OptIdent(id) -> print_string "?"; ident id
 164     | Ast.UniqueIdent(id) -> print_string "!"; ident id
 165
 166 and print_unitary = function
 167     Type_cocci.Unitary -> print_string "unitary"
 168   | Type_cocci.Nonunitary -> print_string "nonunitary"
 169   | Type_cocci.Saved -> print_string "saved"
 170
 171 (* --------------------------------------------------------------------- *)
 172 (* Expression *)
 173
 174 let print_disj_list fn l =
 175   if !print_newlines_disj
 176   then (force_newline(); print_string "("; force_newline())
 177   else print_string "(";
 178   print_between
 179     (function _ ->
 180       if !print_newlines_disj
 181       then (force_newline(); print_string "|"; force_newline())
 182       else print_string " | ")
 183     fn l;
 184   if !print_newlines_disj
 185   then (force_newline(); print_string ")"; force_newline())
 186   else print_string ")"
 187
 188 let rec expression e =
 189   match Ast.unwrap e with
 190     Ast.Ident(id) -> ident id
 191   | Ast.Constant(const) -> mcode constant const
 192   | Ast.FunCall(fn,lp,args,rp) ->
 193       expression fn; mcode print_string_box lp;
 194       dots (function _ -> ()) expression args;
 195       close_box(); mcode print_string rp
 196   | Ast.Assignment(left,op,right,simple) ->
 197       expression left; print_string " "; mcode assignOp op;
 198       print_string " "; expression right
 199   | Ast.CondExpr(exp1,why,exp2,colon,exp3) ->
 200       expression exp1; print_string " "; mcode print_string why;
 201       print_option (function e -> print_string " "; expression e) exp2;
 202       print_string " "; mcode print_string colon; expression exp3
 203   | Ast.Postfix(exp,op) -> expression exp; mcode fixOp op
 204   | Ast.Infix(exp,op) -> mcode fixOp op; expression exp
 205   | Ast.Unary(exp,op) -> mcode unaryOp op; expression exp
 206   | Ast.Binary(left,op,right) ->
 207       expression left; print_string " "; mcode binaryOp op; print_string " ";
 208       expression right
 209   | Ast.Nested(left,op,right) ->
 210       expression left; print_string " "; mcode binaryOp op; print_string " ";
 211       expression right
 212   | Ast.Paren(lp,exp,rp) ->
 213       mcode print_string_box lp; expression exp; close_box();
 214       mcode print_string rp
 215   | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
 216       expression exp1; mcode print_string_box lb; expression exp2; close_box();
 217       mcode print_string rb
 218   | Ast.RecordAccess(exp,pt,field) ->
 219       expression exp; mcode print_string pt; ident field
 220   | Ast.RecordPtAccess(exp,ar,field) ->
 221       expression exp; mcode print_string ar; ident field
 222   | Ast.Cast(lp,ty,rp,exp) ->
 223       mcode print_string_box lp; fullType ty; close_box();
 224       mcode print_string rp; expression exp
 225   | Ast.SizeOfExpr(sizeof,exp) ->
 226       mcode print_string sizeof; expression exp
 227   | Ast.SizeOfType(sizeof,lp,ty,rp) ->
 228       mcode print_string sizeof;
 229       mcode print_string_box lp; fullType ty; close_box();
 230       mcode print_string rp
 231   | Ast.TypeExp(ty) -> fullType ty
 232
 233   | Ast.MetaErr(name,_,_,_) -> mcode print_meta name
 234   | Ast.MetaExpr(name,_,keep,ty,form,inherited) ->
 235       mcode print_meta name; print_type keep inherited ty
 236   | Ast.MetaExprList(name,_,_,_) -> mcode print_meta name
 237   | Ast.EComma(cm) -> mcode print_string cm; print_space()
 238   | Ast.DisjExpr(exp_list) -> print_disj_list expression exp_list
 239   | Ast.NestExpr(expr_dots,Some whencode,multi) ->
 240       nest_dots multi expression
 241         (function _ -> print_string "   when != "; expression whencode)
 242         expr_dots
 243   | Ast.NestExpr(expr_dots,None,multi) ->
 244       nest_dots multi expression (function _ -> ()) expr_dots
 245   | Ast.Edots(dots,Some whencode)
 246   | Ast.Ecircles(dots,Some whencode)
 247   | Ast.Estars(dots,Some whencode) ->
 248       mcode print_string dots; print_string "   when != "; expression whencode
 249   | Ast.Edots(dots,None)
 250   | Ast.Ecircles(dots,None)
 251   | Ast.Estars(dots,None) -> mcode print_string dots
 252   | Ast.OptExp(exp) -> print_string "?"; expression exp
 253   | Ast.UniqueExp(exp) -> print_string "!"; expression exp
 254
 255 and  unaryOp = function
 256     Ast.GetRef -> print_string "&"
 257   | Ast.DeRef -> print_string "*"
 258   | Ast.UnPlus -> print_string "+"
 259   | Ast.UnMinus -> print_string "-"
 260   | Ast.Tilde -> print_string "~"
 261   | Ast.Not -> print_string "!"
 262
 263 and  assignOp = function
 264     Ast.SimpleAssign -> print_string "="
 265   | Ast.OpAssign(aop) -> arithOp aop; print_string "="
 266
 267 and  fixOp = function
 268     Ast.Dec -> print_string "--"
 269   | Ast.Inc -> print_string "++"
 270
 271 and  binaryOp = function
 272     Ast.Arith(aop) -> arithOp aop
 273   | Ast.Logical(lop) -> logicalOp lop
 274
 275 and  arithOp = function
 276     Ast.Plus -> print_string "+"
 277   | Ast.Minus -> print_string "-"
 278   | Ast.Mul -> print_string "*"
 279   | Ast.Div -> print_string "/"
 280   | Ast.Mod -> print_string "%"
 281   | Ast.DecLeft -> print_string "<<"
 282   | Ast.DecRight -> print_string ">>"
 283   | Ast.And -> print_string "&"
 284   | Ast.Or -> print_string "|"
 285   | Ast.Xor -> print_string "^"
 286
 287 and  logicalOp = function
 288     Ast.Inf -> print_string "<"
 289   | Ast.Sup -> print_string ">"
 290   | Ast.InfEq -> print_string "<="
 291   | Ast.SupEq -> print_string ">="
 292   | Ast.Eq -> print_string "=="
 293   | Ast.NotEq -> print_string "!="
 294   | Ast.AndLog -> print_string "&&"
 295   | Ast.OrLog -> print_string "||"
 296
 297 and constant = function
 298     Ast.String(s) -> print_string "\""; print_string s; print_string "\""
 299   | Ast.Char(s) -> print_string "'"; print_string s; print_string "'"
 300   | Ast.Int(s) -> print_string s
 301   | Ast.Float(s) -> print_string s
 302
 303 (* --------------------------------------------------------------------- *)
 304 (* Declarations *)
 305
 306 and storage = function
 307     Ast.Static -> print_string "static "
 308   | Ast.Auto -> print_string "auto "
 309   | Ast.Register -> print_string "register "
 310   | Ast.Extern -> print_string "extern "
 311
 312 (* --------------------------------------------------------------------- *)
 313 (* Types *)
 314
 315 and fullType ft =
 316   match Ast.unwrap ft with
 317     Ast.Type(cv,ty) ->
 318       print_option (function x -> mcode const_vol x; print_string " ") cv;
 319       typeC ty
 320   | Ast.DisjType(decls) -> print_disj_list fullType decls
 321   | Ast.OptType(ty) -> print_string "?"; fullType ty
 322   | Ast.UniqueType(ty) -> print_string "!"; fullType ty
 323
 324 and print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2) fn =
 325   fullType ty; mcode print_string lp1; mcode print_string star; fn();
 326   mcode print_string rp1; mcode print_string lp1;
 327   parameter_list params; mcode print_string rp2
 328
 329 and print_function_type (ty,lp1,params,rp1) fn =
 330   print_option fullType ty; fn(); mcode print_string lp1;
 331   parameter_list params; mcode print_string rp1
 332
 333 and print_fninfo = function
 334     Ast.FStorage(stg) -> mcode storage stg
 335   | Ast.FType(ty) -> fullType ty
 336   | Ast.FInline(inline) -> mcode print_string inline; print_string " "
 337   | Ast.FAttr(attr) -> mcode print_string attr; print_string " "
 338
 339 and typeC ty =
 340   match Ast.unwrap ty with
 341     Ast.BaseType(ty,strings) ->
 342       List.iter (function s -> mcode print_string s; print_string " ") strings
 343   | Ast.SignedT(sgn,ty) -> mcode sign sgn; print_option typeC ty
 344   | Ast.Pointer(ty,star) -> fullType ty; mcode print_string star
 345   | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
 346       print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
 347         (function _ -> ())
 348   | Ast.FunctionType (_,ty,lp1,params,rp1) ->
 349       print_function_type (ty,lp1,params,rp1) (function _ -> ())
 350   | Ast.Array(ty,lb,size,rb) ->
 351       fullType ty; mcode print_string lb; print_option expression size;
 352       mcode print_string rb
 353   | Ast.EnumName(kind,name) -> mcode print_string kind; print_string " ";
 354       ident name
 355   | Ast.StructUnionName(kind,name) ->
 356       mcode structUnion kind;
 357       print_option (function x -> ident x; print_string " ") name
 358   | Ast.StructUnionDef(ty,lb,decls,rb) ->
 359       fullType ty; mcode print_string lb;
 360       dots force_newline declaration decls;
 361       mcode print_string rb
 362   | Ast.TypeName(name) -> mcode print_string name; print_string " "
 363   | Ast.MetaType(name,_,_) ->
 364       mcode print_meta name; print_string " "
 365
 366 and baseType = function
 367     Ast.VoidType -> print_string "void "
 368   | Ast.CharType -> print_string "char "
 369   | Ast.ShortType -> print_string "short "
 370   | Ast.IntType -> print_string "int "
 371   | Ast.DoubleType -> print_string "double "
 372   | Ast.FloatType -> print_string "float "
 373   | Ast.LongType -> print_string "long "
 374   | Ast.LongLongType -> print_string "long long "
 375
 376 and structUnion = function
 377     Ast.Struct -> print_string "struct "
 378   | Ast.Union -> print_string "union "
 379
 380 and sign = function
 381     Ast.Signed -> print_string "signed "
 382   | Ast.Unsigned -> print_string "unsigned "
 383
 384 and const_vol = function
 385     Ast.Const -> print_string "const"
 386   | Ast.Volatile -> print_string "volatile"
 387
 388 (* --------------------------------------------------------------------- *)
 389 (* Variable declaration *)
 390 (* Even if the Cocci program specifies a list of declarations, they are
 391    split out into multiple declarations of a single variable each. *)
 392
 393 and print_named_type ty id =
 394   match Ast.unwrap ty with
 395     Ast.Type(None,ty1) ->
 396       (match Ast.unwrap ty1 with
 397         Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
 398           print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
 399             (function _ -> print_string " "; ident id)
 400       | Ast.FunctionType(_,ty,lp1,params,rp1) ->
 401           print_function_type (ty,lp1,params,rp1)
 402             (function _ -> print_string " "; ident id)
 403       | Ast.Array(ty,lb,size,rb) ->
 404           let rec loop ty k =
 405             match Ast.unwrap ty with
 406               Ast.Array(ty,lb,size,rb) ->
 407                 (match Ast.unwrap ty with
 408                   Ast.Type(None,ty) ->
 409                     loop ty
 410                       (function _ ->
 411                         k ();
 412                         mcode print_string lb;
 413                         print_option expression size;
 414                         mcode print_string rb)
 415                 | _ -> failwith "complex array types not supported")
 416             | _ -> typeC ty; ident id; k () in
 417           loop ty1 (function _ -> ())
 418       | _ -> fullType ty; ident id)
 419   | _ -> fullType ty; ident id
 420
 421 and declaration d =
 422   match Ast.unwrap d with
 423     Ast.Init(stg,ty,id,eq,ini,sem) ->
 424       print_option (mcode storage) stg; print_named_type ty id;
 425       print_string " "; mcode print_string eq;
 426       print_string " "; initialiser ini; mcode print_string sem
 427   | Ast.UnInit(stg,ty,id,sem) ->
 428       print_option (mcode storage) stg; print_named_type ty id;
 429       mcode print_string sem
 430   | Ast.MacroDecl(name,lp,args,rp,sem) ->
 431       ident name; mcode print_string_box lp;
 432       dots (function _ -> ()) expression args;
 433       close_box(); mcode print_string rp; mcode print_string sem
 434   | Ast.TyDecl(ty,sem) -> fullType ty; mcode print_string sem
 435   | Ast.Typedef(stg,ty,id,sem) ->
 436       mcode print_string stg; print_string " "; fullType ty; typeC id;
 437       mcode print_string sem
 438   | Ast.DisjDecl(decls) -> print_disj_list declaration decls
 439   | Ast.Ddots(dots,Some whencode) ->
 440       mcode print_string dots; print_string "   when != "; declaration whencode
 441   | Ast.Ddots(dots,None) -> mcode print_string dots
 442   | Ast.MetaDecl(name,_,_) -> mcode print_meta name
 443   | Ast.OptDecl(decl) -> print_string "?"; declaration decl
 444   | Ast.UniqueDecl(decl) -> print_string "!"; declaration decl
 445
 446 (* --------------------------------------------------------------------- *)
 447 (* Initialiser *)
 448
 449 and initialiser i =
 450   match Ast.unwrap i with
 451     Ast.MetaInit(name,_,_) ->
 452       mcode print_meta name; print_string " "
 453   | Ast.InitExpr(exp) -> expression exp
 454   | Ast.InitList(lb,initlist,rb,whencode) ->
 455       mcode print_string lb; open_box 0;
 456       if not (whencode = [])
 457       then
 458         (print_string "   WHEN != ";
 459          print_between (function _ -> print_string " v ")
 460            initialiser whencode;
 461          force_newline());
 462       List.iter initialiser initlist; close_box();
 463       mcode print_string rb
 464   | Ast.InitGccExt(designators,eq,ini) ->
 465       List.iter designator designators; print_string " ";
 466       mcode print_string eq; print_string " "; initialiser ini
 467   | Ast.InitGccName(name,eq,ini) ->
 468       ident name; mcode print_string eq; initialiser ini
 469   | Ast.IComma(comma) -> mcode print_string comma; force_newline()
 470   | Ast.OptIni(ini) -> print_string "?"; initialiser ini
 471   | Ast.UniqueIni(ini) -> print_string "!"; initialiser ini
 472
 473 and designator = function
 474     Ast.DesignatorField(dot,id) -> mcode print_string dot; ident id
 475   | Ast.DesignatorIndex(lb,exp,rb) ->
 476       mcode print_string lb; expression exp; mcode print_string rb
 477   | Ast.DesignatorRange(lb,min,dots,max,rb) ->
 478       mcode print_string lb; expression min; mcode print_string dots;
 479       expression max; mcode print_string rb
 480
 481 (* --------------------------------------------------------------------- *)
 482 (* Parameter *)
 483
 484 and parameterTypeDef p =
 485   match Ast.unwrap p with
 486     Ast.VoidParam(ty) -> fullType ty
 487   | Ast.Param(ty,Some id) -> print_named_type ty id
 488   | Ast.Param(ty,None) -> fullType ty
 489   | Ast.MetaParam(name,_,_) -> mcode print_meta name
 490   | Ast.MetaParamList(name,_,_,_) -> mcode print_meta name
 491   | Ast.PComma(cm) -> mcode print_string cm; print_space()
 492   | Ast.Pdots(dots) -> mcode print_string dots
 493   | Ast.Pcircles(dots) -> mcode print_string dots
 494   | Ast.OptParam(param) -> print_string "?"; parameterTypeDef param
 495   | Ast.UniqueParam(param) -> print_string "!"; parameterTypeDef param
 496
 497 and parameter_list l = dots (function _ -> ()) parameterTypeDef l
 498
 499 (* --------------------------------------------------------------------- *)
 500 (* Top-level code *)
 501
 502 let rec rule_elem arity re =
 503   match Ast.unwrap re with
 504     Ast.FunHeader(bef,allminus,fninfo,name,lp,params,rp) ->
 505       mcode (function _ -> ()) ((),Ast.no_info,bef,Ast.NoMetaPos);
 506       print_string arity; List.iter print_fninfo fninfo;
 507       ident name; mcode print_string_box lp;
 508       parameter_list params; close_box(); mcode print_string rp;
 509       print_string " "
 510   | Ast.Decl(bef,allminus,decl) ->
 511       mcode (function _ -> ()) ((),Ast.no_info,bef,Ast.NoMetaPos);
 512       print_string arity;
 513       declaration decl
 514   | Ast.SeqStart(brace) ->
 515       print_string arity; mcode print_string brace;
 516       if !print_newlines_disj then start_block()
 517   | Ast.SeqEnd(brace) ->
 518       if !print_newlines_disj then end_block();
 519       print_string arity; mcode print_string brace
 520   | Ast.ExprStatement(exp,sem) ->
 521       print_string arity; expression exp; mcode print_string sem
 522   | Ast.IfHeader(iff,lp,exp,rp) ->
 523       print_string arity;
 524       mcode print_string iff; print_string " "; mcode print_string_box lp;
 525       expression exp; close_box(); mcode print_string rp; print_string " "
 526   | Ast.Else(els) ->
 527       print_string arity; mcode print_string els; print_string " "
 528   | Ast.WhileHeader(whl,lp,exp,rp) ->
 529       print_string arity;
 530       mcode print_string whl; print_string " "; mcode print_string_box lp;
 531       expression exp; close_box(); mcode print_string rp; print_string " "
 532   | Ast.DoHeader(d) ->
 533       print_string arity; mcode print_string d; print_string " "
 534   | Ast.WhileTail(whl,lp,exp,rp,sem) ->
 535       print_string arity;
 536       mcode print_string whl; print_string " "; mcode print_string_box lp;
 537       expression exp; close_box(); mcode print_string rp;
 538       mcode print_string sem
 539   | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
 540       print_string arity;
 541       mcode print_string fr; mcode print_string_box lp;
 542       print_option expression e1; mcode print_string sem1;
 543       print_option expression e2; mcode print_string sem2;
 544       print_option expression e3; close_box();
 545       mcode print_string rp; print_string " "
 546   | Ast.IteratorHeader(nm,lp,args,rp) ->
 547       print_string arity;
 548       ident nm; print_string " "; mcode print_string_box lp;
 549       dots (function _ -> ()) expression args; close_box();
 550       mcode print_string rp; print_string " "
 551   | Ast.SwitchHeader(switch,lp,exp,rp) ->
 552       print_string arity;
 553       mcode print_string switch; print_string " "; mcode print_string_box lp;
 554       expression exp; close_box(); mcode print_string rp; print_string " "
 555   | Ast.Break(br,sem) ->
 556       print_string arity; mcode print_string br; mcode print_string sem
 557   | Ast.Continue(cont,sem) ->
 558       print_string arity; mcode print_string cont; mcode print_string sem
 559   | Ast.Label(l,dd) -> ident l; mcode print_string dd
 560   | Ast.Goto(goto,l,sem) ->
 561       mcode print_string goto; ident l; mcode print_string sem
 562   | Ast.Return(ret,sem) ->
 563       print_string arity; mcode print_string ret; mcode print_string sem
 564   | Ast.ReturnExpr(ret,exp,sem) ->
 565       print_string arity; mcode print_string ret; print_string " ";
 566       expression exp; mcode print_string sem
 567   | Ast.MetaRuleElem(name,_,_) ->
 568       print_string arity; mcode print_meta name
 569   | Ast.MetaStmt(name,_,_,_) ->
 570       print_string arity; mcode print_meta name
 571   | Ast.MetaStmtList(name,_,_) ->
 572       print_string arity;  mcode print_meta name
 573   | Ast.Exp(exp) -> print_string arity; expression exp
 574   | Ast.TopExp(exp) -> print_string arity; expression exp
 575   | Ast.Ty(ty) -> print_string arity; fullType ty
 576   | Ast.TopInit(init) -> initialiser init
 577   | Ast.Include(inc,s) ->
 578       mcode print_string inc; print_string " "; mcode inc_file s
 579   | Ast.DefineHeader(def,id,params) ->
 580       mcode print_string def; print_string " "; ident id;
 581       print_define_parameters params
 582   | Ast.Default(def,colon) ->
 583       mcode print_string def; mcode print_string colon; print_string " "
 584   | Ast.Case(case,exp,colon) ->
 585       mcode print_string case; print_string " "; expression exp;
 586       mcode print_string colon; print_string " "
 587   | Ast.DisjRuleElem(res) ->
 588       print_string arity;
 589       force_newline(); print_string "("; force_newline();
 590       print_between
 591         (function _ -> force_newline();print_string "|"; force_newline())
 592         (rule_elem arity)
 593         res;
 594       force_newline(); print_string ")"
 595
 596
 597 and print_define_parameters params =
 598   match Ast.unwrap params with
 599     Ast.NoParams -> ()
 600   | Ast.DParams(lp,params,rp) ->
 601       mcode print_string lp;
 602       dots (function _ -> ()) print_define_param params; mcode print_string rp
 603
 604 and print_define_param param =
 605   match Ast.unwrap param with
 606     Ast.DParam(id) -> ident id
 607   | Ast.DPComma(comma) -> mcode print_string comma
 608   | Ast.DPdots(dots) -> mcode print_string dots
 609   | Ast.DPcircles(circles) -> mcode print_string circles
 610   | Ast.OptDParam(dp) -> print_string "?"; print_define_param dp
 611   | Ast.UniqueDParam(dp) -> print_string "!"; print_define_param dp
 612
 613 and statement arity s =
 614   match Ast.unwrap s with
 615     Ast.Seq(lbrace,body,rbrace) ->
 616       rule_elem arity lbrace;
 617       dots force_newline (statement arity) body;
 618       rule_elem arity rbrace
 619   | Ast.IfThen(header,branch,(_,_,_,aft)) ->
 620       rule_elem arity header; statement arity branch;
 621       mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
 622   | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) ->
 623       rule_elem arity header; statement arity branch1; print_string " ";
 624       rule_elem arity els; statement arity branch2;
 625       mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
 626   | Ast.While(header,body,(_,_,_,aft)) ->
 627       rule_elem arity header; statement arity body;
 628       mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
 629   | Ast.Do(header,body,tail) ->
 630       rule_elem arity header; statement arity body;
 631       rule_elem arity tail
 632   | Ast.For(header,body,(_,_,_,aft)) ->
 633       rule_elem arity header; statement arity body;
 634       mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
 635   | Ast.Iterator(header,body,(_,_,_,aft)) ->
 636       rule_elem arity header; statement arity body;
 637       mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
 638   | Ast.Switch(header,lb,decls,cases,rb) ->
 639       rule_elem arity header; rule_elem arity lb;
 640       dots force_newline (statement arity) decls;
 641       List.iter (function x -> case_line arity x; force_newline()) cases;
 642       rule_elem arity rb
 643   | Ast.Atomic(re) -> rule_elem arity re
 644   | Ast.FunDecl(header,lbrace,body,rbrace) ->
 645       rule_elem arity header; rule_elem arity lbrace;
 646       dots force_newline (statement arity) body;
 647       rule_elem arity rbrace
 648   | Ast.Disj([stmt_dots]) ->
 649       print_string arity;
 650       dots (function _ -> if !print_newlines_disj then force_newline())
 651         (statement arity) stmt_dots
 652   | Ast.Disj(stmt_dots_list) -> (* ignores newline directive for readability *)
 653       print_string arity;
 654       force_newline(); print_string "("; force_newline();
 655       print_between
 656         (function _ -> force_newline();print_string "|"; force_newline())
 657         (dots force_newline (statement arity))
 658         stmt_dots_list;
 659       force_newline(); print_string ")"
 660   | Ast.Define(header,body) ->
 661       rule_elem arity header; print_string " ";
 662       dots force_newline (statement arity) body
 663   | Ast.Nest(stmt_dots,whn,multi,_,_) ->
 664       print_string arity;
 665       nest_dots multi (statement arity)
 666         (function _ ->
 667           open_box 0;
 668           print_between force_newline
 669             (whencode (dots force_newline (statement "")) (statement "")) whn;
 670           close_box(); force_newline())
 671         stmt_dots
 672   | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
 673       print_string arity; mcode print_string d;
 674       open_box 0;
 675       print_between force_newline
 676         (whencode (dots force_newline (statement "")) (statement "")) whn;
 677       close_box(); force_newline()
 678   | Ast.OptStm(s) -> statement "?" s
 679   | Ast.UniqueStm(s) -> statement "!" s
 680
 681 and print_statement_when whencode =
 682   print_string "   WHEN != ";
 683   open_box 0;
 684   print_between (function _ -> print_string " &"; force_newline())
 685     (dots force_newline (statement "")) whencode;
 686   close_box()
 687
 688
 689 and whencode notfn alwaysfn = function
 690     Ast.WhenNot a ->
 691       print_string "   WHEN != "; open_box 0; notfn a; close_box()
 692   | Ast.WhenAlways a ->
 693       print_string "   WHEN = "; open_box 0; alwaysfn a; close_box()
 694   | Ast.WhenModifier x -> print_string "   WHEN "; print_when_modif x
 695   | Ast.WhenNotTrue a ->
 696       print_string "   WHEN != TRUE "; open_box 0; rule_elem "" a; close_box()
 697   | Ast.WhenNotFalse a ->
 698       print_string "   WHEN != FALSE "; open_box 0; rule_elem "" a; close_box()
 699
 700 and print_when_modif = function
 701   | Ast.WhenAny    -> print_string "ANY"
 702   | Ast.WhenStrict -> print_string "STRICT"
 703   | Ast.WhenForall -> print_string "FORALL"
 704   | Ast.WhenExists -> print_string "EXISTS"
 705
 706 and case_line arity c =
 707   match Ast.unwrap c with
 708     Ast.CaseLine(header,code) ->
 709       rule_elem arity header; print_string " ";
 710       dots force_newline (statement arity) code
 711   | Ast.OptCase(case) -> case_line "?" case
 712
 713 (* --------------------------------------------------------------------- *)
 714 (* CPP code *)
 715
 716 and inc_file = function
 717     Ast.Local(elems) ->
 718       print_string "\"";
 719       print_between (function _ -> print_string "/") inc_elem elems;
 720       print_string "\""
 721   | Ast.NonLocal(elems) ->
 722       print_string "<";
 723       print_between (function _ -> print_string "/") inc_elem elems;
 724       print_string ">"
 725
 726 and inc_elem = function
 727     Ast.IncPath s -> print_string s
 728   | Ast.IncDots -> print_string "..."
 729
 730 (* for export only *)
 731 let statement_dots l = dots force_newline (statement "") l
 732
 733 let top_level t =
 734   match Ast.unwrap t with
 735     Ast.FILEINFO(old_file,new_file) ->
 736       print_string "--- "; mcode print_string old_file; force_newline();
 737       print_string "+++ "; mcode print_string new_file
 738   | Ast.DECL(stmt) -> statement "" stmt
 739   | Ast.CODE(stmt_dots) ->
 740       dots force_newline (statement "") stmt_dots
 741   | Ast.ERRORWORDS(exps) ->
 742       print_string "error words = [";
 743       print_between (function _ -> print_string ", ") expression exps;
 744       print_string "]"
 745
 746 let rule =
 747   print_between (function _ -> force_newline(); force_newline()) top_level
 748
 749 let pp_print_anything x = !anything x
 750
 751 let _ =
 752   anything := function
 753       Ast.FullTypeTag(x) -> fullType x
 754     | Ast.BaseTypeTag(x) -> baseType x
 755     | Ast.StructUnionTag(x) -> structUnion x
 756     | Ast.SignTag(x) -> sign x
 757     | Ast.IdentTag(x) -> ident x
 758     | Ast.ExpressionTag(x) -> expression x
 759     | Ast.ConstantTag(x) -> constant x
 760     | Ast.UnaryOpTag(x) -> unaryOp x
 761     | Ast.AssignOpTag(x) -> assignOp x
 762     | Ast.FixOpTag(x) -> fixOp x
 763     | Ast.BinaryOpTag(x) -> binaryOp x
 764     | Ast.ArithOpTag(x) -> arithOp x
 765     | Ast.LogicalOpTag(x) -> logicalOp x
 766     | Ast.InitTag(x) -> initialiser x
 767     | Ast.DeclarationTag(x) -> declaration x
 768     | Ast.StorageTag(x) -> storage x
 769     | Ast.IncFileTag(x) -> inc_file x
 770     | Ast.Rule_elemTag(x) -> rule_elem "" x
 771     | Ast.StatementTag(x) -> statement "" x
 772     | Ast.CaseLineTag(x) -> case_line "" x
 773     | Ast.ConstVolTag(x) -> const_vol x
 774     | Ast.Token(x,Some info) -> print_string_befaft print_string x info
 775     | Ast.Token(x,None) -> print_string x
 776     | Ast.Pragma(xs) -> print_between force_newline print_string xs
 777     | Ast.Code(x) -> let _ = top_level x in ()
 778     | Ast.ExprDotsTag(x) -> dots (function _ -> ()) expression x
 779     | Ast.ParamDotsTag(x) -> parameter_list x
 780     | Ast.StmtDotsTag(x) -> dots (function _ -> ()) (statement "") x
 781     | Ast.DeclDotsTag(x) -> dots (function _ -> ()) declaration x
 782     | Ast.TypeCTag(x) -> typeC x
 783     | Ast.ParamTag(x) -> parameterTypeDef x
 784     | Ast.SgrepStartTag(x) -> print_string x
 785     | Ast.SgrepEndTag(x) -> print_string x
 786
 787 let rec dep in_and = function
 788     Ast.Dep(s) -> print_string s
 789   | Ast.AntiDep(s) -> print_string "!"; print_string s
 790   | Ast.EverDep(s) -> print_string "ever "; print_string s
 791   | Ast.NeverDep(s) -> print_string "never "; print_string s
 792   | Ast.AndDep(s1,s2) ->
 793       let print_and _ = dep true s1; print_string " && "; dep true s2 in
 794       if in_and
 795       then print_and ()
 796       else (print_string "("; print_and(); print_string ")")
 797   | Ast.OrDep(s1,s2) ->
 798       let print_or _ = dep false s1; print_string " || "; dep false s2 in
 799       if not in_and
 800       then print_or ()
 801       else (print_string "("; print_or(); print_string ")")
 802   | Ast.NoDep   -> print_string "no_dep"
 803   | Ast.FailDep -> print_string "fail_dep"
 804
 805 let unparse z =
 806   match z with
 807     Ast.InitialScriptRule (lang,code) ->
 808       print_string "@@";
 809       force_newline();
 810       print_string ("initialize:" ^ lang);
 811       force_newline();
 812       print_string "@@";
 813       force_newline();
 814       print_string code;
 815       force_newline()
 816   | Ast.FinalScriptRule (lang,code) ->
 817       print_string "@@";
 818       force_newline();
 819       print_string ("finalize:" ^ lang);
 820       force_newline();
 821       print_string "@@";
 822       force_newline();
 823       print_string code;
 824       force_newline()
 825   | Ast.ScriptRule (lang,deps,bindings,code) ->
 826       print_string "@@";
 827       force_newline();
 828       print_string ("script:" ^ lang);
 829       (match deps with
 830         Ast.NoDep -> ()
 831       | _ -> print_string " depends on "; dep true deps);
 832       force_newline();
 833       print_string "@@";
 834       force_newline();
 835       print_string code;
 836       force_newline()
 837   | Ast.CocciRule (nm, (deps, drops, exists), x, _, _) ->
 838       print_string "@@";
 839       force_newline();
 840       print_string nm;
 841       (match deps with
 842         Ast.NoDep -> ()
 843       | _ -> print_string " depends on "; dep true deps);
 844     (*
 845     print_string "line ";
 846     print_int (Ast.get_line (List.hd x));
 847     *)
 848       force_newline();
 849       print_string "@@";
 850       print_newlines_disj := true;
 851       force_newline();
 852       force_newline();
 853       rule x;
 854       force_newline()
 855
 856 let rule_elem_to_string x =
 857   print_newlines_disj := true;
 858   Common.format_to_string (function _ -> rule_elem "" x)
 859
 860 let ident_to_string x =
 861   print_newlines_disj := true;
 862   Common.format_to_string (function _ -> ident x)
 863
 864 let unparse_to_string x =
 865   print_newlines_disj := true;
 866   Common.format_to_string (function _ -> unparse x)
 867
 868 let print_rule_elem re =
 869   let nl = !print_newlines_disj in
 870   print_newlines_disj := false;
 871   rule_elem "" re;
 872   print_newlines_disj := nl
 873