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