parsing_c/unparse_cocci.ml

   1 (*
   2  * Copyright (C) 2010, University of Copenhagen DIKU and INRIA.
   3  * Copyright (C) 2006, 2007 Julia Lawall
   4  *
   5  * This program is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU General Public License (GPL)
   7  * version 2 as published by the Free Software Foundation.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * file license.txt for more details.
  13  *
  14  * This file was part of Coccinelle.
  15  *)
  16 open Common
  17
  18 (*****************************************************************************)
  19 (* mostly a copy paste of parsing_cocci/pretty_print_cocci.ml
  20  * todo?: try to factorize ?
  21  *)
  22 (*****************************************************************************)
  23
  24 module Ast = Ast_cocci
  25
  26 let term s = Ast.unwrap_mcode s
  27
  28 (* or perhaps can have in plus, for instance a Disj, but those Disj must be
  29  *  handled by interactive tool (by proposing alternatives)
  30  *)
  31 exception CantBeInPlus
  32
  33 (*****************************************************************************)
  34
  35 type pos = Before | After | InPlace
  36 type nlhint = StartBox | EndBox | SpaceOrNewline of string ref
  37
  38 let get_string_info = function
  39     Ast.Noindent s | Ast.Indent s | Ast.Space s -> s
  40
  41 let unknown = -1
  42
  43 let rec do_all
  44     (env, pr, pr_celem, pr_cspace, pr_space, pr_arity, pr_barrier,
  45      indent, unindent, eatspace)
  46     generating xxs before =
  47
  48 (* Just to be able to copy paste the code from pretty_print_cocci.ml. *)
  49 let print_string s line lcol =
  50   let rcol = if lcol = unknown then unknown else lcol + (String.length s) in
  51   pr s line lcol rcol None in
  52 let print_string_with_hint hint s line lcol =
  53   let rcol = if lcol = unknown then unknown else lcol + (String.length s) in
  54   pr s line lcol rcol (Some hint) in
  55 let print_text s = pr s unknown unknown unknown None in
  56 let close_box _ = () in
  57 let force_newline _ = print_text "\n" in
  58
  59 let start_block () = force_newline(); indent() in
  60 let end_block () = unindent true; force_newline () in
  61 let print_string_box s = print_string s in
  62
  63 let print_option = Common.do_option in
  64 let print_option_prespace fn = function
  65     None -> ()
  66   | Some x -> pr_space(); fn x in
  67 let print_option_space fn = function
  68     None -> ()
  69   | Some x -> fn x; pr_space() in
  70 let print_between = Common.print_between in
  71
  72 let outdent _ = () (* should go to leftmost col, does nothing now *) in
  73
  74 let pretty_print_c =
  75   Pretty_print_c.mk_pretty_printers pr_celem pr_cspace
  76     force_newline indent outdent (function _ -> unindent true) in
  77
  78 (* --------------------------------------------------------------------- *)
  79 (* Only for make_hrule, print plus code, unbound metavariables *)
  80
  81 (* avoid polyvariance problems *)
  82 let anything : (Ast.anything -> unit) ref = ref (function _ -> ()) in
  83
  84 let rec print_anything = function
  85     [] -> ()
  86   | stream ->
  87       start_block();
  88       print_between force_newline print_anything_list stream;
  89       end_block()
  90
  91 and print_anything_list = function
  92     [] -> ()
  93   | [x] -> !anything x
  94   | bef::((aft::_) as rest) ->
  95       !anything bef;
  96       let space =
  97         (match bef with
  98           Ast.Rule_elemTag(_) | Ast.AssignOpTag(_) | Ast.BinaryOpTag(_)
  99         | Ast.ArithOpTag(_) | Ast.LogicalOpTag(_)
 100         | Ast.Token("if",_) | Ast.Token("while",_) -> true | _ -> false) or
 101         (match aft with
 102           Ast.Rule_elemTag(_) | Ast.AssignOpTag(_) | Ast.BinaryOpTag(_)
 103         | Ast.ArithOpTag(_) | Ast.LogicalOpTag(_) | Ast.Token("{",_) -> true
 104         | _ -> false) in
 105       if space then pr_space ();
 106       print_anything_list rest in
 107
 108 let print_around printer term = function
 109     Ast.NOTHING -> printer term
 110   | Ast.BEFORE(bef,_) -> print_anything bef; printer term
 111   | Ast.AFTER(aft,_) -> printer term; print_anything aft
 112   | Ast.BEFOREAFTER(bef,aft,_) ->
 113       print_anything bef; printer term; print_anything aft in
 114
 115 let print_string_befaft fn fn1 x info =
 116   let print ln col s = print_string (get_string_info s) ln col in
 117   List.iter
 118     (function (s,ln,col) -> fn1(); print ln col s; force_newline())
 119     info.Ast.strbef;
 120   fn x;
 121   List.iter
 122     (function (s,ln,col) -> force_newline(); fn1(); print ln col s)
 123     info.Ast.straft in
 124 let print_meta (r,x) = print_text x in
 125
 126 let print_pos l =
 127   List.iter
 128     (function
 129         Ast.MetaPos(name,_,_,_,_) ->
 130           let name = Ast.unwrap_mcode name in
 131           print_text "@"; print_meta name)
 132     l in
 133
 134 (* --------------------------------------------------------------------- *)
 135
 136 let mcode fn (s,info,mc,pos) =
 137   let line = info.Ast.line in
 138   let lcol = info.Ast.column in
 139   match (generating,mc) with
 140     (false,_) ->
 141     (* printing for transformation *)
 142     (* Here we don't care about the annotation on s. *)
 143       let print_comments lb comments =
 144         List.fold_left
 145           (function line_before ->
 146             function (str,line,col) ->
 147               match line_before with
 148                 None ->
 149                   let str =
 150                     match str with
 151                       Ast.Noindent s -> unindent false; s
 152                     | Ast.Indent s -> s
 153                     | Ast.Space s -> s in
 154                   print_string str line col; Some line
 155               | Some lb when line =|= lb ->
 156                   print_string (get_string_info str) line col; Some line
 157               | _ ->
 158                   force_newline();
 159                   (* not super elegant to put side-effecting unindent in a let
 160                      expression... *)
 161                   let str =
 162                     match str with
 163                       Ast.Noindent s -> unindent false; s
 164                     | Ast.Indent s -> s
 165                     | Ast.Space s -> s in
 166                   print_string str line col; Some line)
 167           lb comments in
 168       let line_before = print_comments None info.Ast.strbef in
 169       (match line_before with
 170         None -> ()
 171       | Some lb when lb =|= info.Ast.line -> ()
 172       | _ -> force_newline());
 173       fn s line lcol;
 174       let _ = print_comments (Some info.Ast.line) info.Ast.straft in
 175       (* newline after a pragma
 176          should really store parsed versions of the strings, but make a cheap
 177          effort here
 178          print_comments takes care of interior newlines *)
 179       ()
 180       (* printing for rule generation *)
 181   | (true, Ast.MINUS(_,_,_,plus_stream)) ->
 182       force_newline();
 183       print_text "- ";
 184       fn s line lcol; print_pos pos;
 185       (match plus_stream with
 186         Ast.NOREPLACEMENT -> ()
 187       | Ast.REPLACEMENT(plus_stream,ct) -> print_anything plus_stream)
 188   | (true, Ast.CONTEXT(_,plus_streams)) ->
 189       let fn s = force_newline(); fn s line lcol; print_pos pos in
 190       print_around fn s plus_streams
 191   | (true,Ast.PLUS Ast.ONE) ->
 192       let fn s =
 193         force_newline(); print_text "+ "; fn s line lcol; print_pos pos in
 194       print_string_befaft fn (function _ -> print_text "+ ") s info
 195   | (true,Ast.PLUS Ast.MANY) ->
 196       let fn s =
 197         force_newline(); print_text "++ "; fn s line lcol; print_pos pos in
 198       print_string_befaft fn (function _ -> print_text "++ ") s info
 199 in
 200
 201
 202 (* --------------------------------------------------------------------- *)
 203
 204 let handle_metavar name fn =
 205   let ((_,b) as s,info,mc,pos) = name in
 206   let line = info.Ast.line in
 207   let lcol = info.Ast.column in
 208   match Common.optionise (fun () -> List.assoc s env) with
 209     None ->
 210       let name_string (_,s) = s in
 211       if generating
 212       then
 213         mcode (function _ -> print_string (name_string s)) name
 214       else
 215         failwith
 216           (Printf.sprintf "SP line %d: Not found a value in env for: %s"
 217              line (name_string s))
 218   | Some e  ->
 219       pr_barrier line lcol;
 220       (if generating
 221       then
 222         (* call mcode to preserve the -+ annotation *)
 223         mcode (fun _ _ _ -> fn e) name
 224       else fn e);
 225       let rcol =
 226         if lcol = unknown then unknown else lcol + (String.length b) in
 227       pr_barrier line rcol
 228 in
 229 (* --------------------------------------------------------------------- *)
 230 let dots between fn d =
 231   match Ast.unwrap d with
 232     Ast.DOTS(l) -> print_between between fn l
 233   | Ast.CIRCLES(l) -> print_between between fn l
 234   | Ast.STARS(l) -> print_between between fn l
 235 in
 236
 237 let nest_dots starter ender fn f d =
 238   mcode print_string starter;
 239   f(); start_block();
 240   (match Ast.unwrap d with
 241     Ast.DOTS(l)    -> print_between force_newline fn l
 242   | Ast.CIRCLES(l) -> print_between force_newline fn l
 243   | Ast.STARS(l)   -> print_between force_newline fn l);
 244   end_block();
 245   mcode print_string ender
 246 in
 247
 248 let print_disj_list fn l =
 249   print_text "\n(\n";
 250   print_between (function _ -> print_text "\n|\n") fn l;
 251   print_text "\n)\n" in
 252
 253 (* --------------------------------------------------------------------- *)
 254 (* Identifier *)
 255
 256 let rec ident i =
 257   match Ast.unwrap i with
 258       Ast.Id(name) -> mcode print_string name
 259     | Ast.MetaId(name,_,_,_) ->
 260         handle_metavar name (function
 261                                | (Ast_c.MetaIdVal (id,_)) -> print_text id
 262                                | _ -> raise Impossible
 263                             )
 264     | Ast.MetaFunc(name,_,_,_) ->
 265         handle_metavar name (function
 266                                | (Ast_c.MetaFuncVal id) -> print_text id
 267                                | _ -> raise Impossible
 268                             )
 269     | Ast.MetaLocalFunc(name,_,_,_) ->
 270         handle_metavar name (function
 271                                | (Ast_c.MetaLocalFuncVal id) -> print_text id
 272                                | _ -> raise Impossible
 273                             )
 274
 275     | Ast.DisjId(id_list) ->
 276         if generating
 277         then print_disj_list ident id_list
 278         else raise CantBeInPlus
 279     | Ast.OptIdent(_) | Ast.UniqueIdent(_) ->
 280         raise CantBeInPlus
 281
 282 in
 283
 284 (* --------------------------------------------------------------------- *)
 285 (* Expression *)
 286
 287 let rec expression e =
 288   match Ast.unwrap e with
 289     Ast.Ident(id) -> ident id
 290   | Ast.Constant(const) -> mcode constant const
 291   | Ast.FunCall(fn,lp,args,rp) ->
 292       expression fn; mcode (print_string_with_hint StartBox) lp;
 293       dots (function _ -> ()) arg_expression args;
 294       mcode (print_string_with_hint EndBox) rp
 295   | Ast.Assignment(left,op,right,_) ->
 296       expression left; pr_space(); mcode assignOp op;
 297       pr_space(); expression right
 298   | Ast.Sequence(left,op,right) ->
 299       expression left; mcode print_string op;
 300       pr_space(); expression right
 301   | Ast.CondExpr(exp1,why,exp2,colon,exp3) ->
 302       expression exp1; pr_space(); mcode print_string why;
 303       print_option (function e -> pr_space(); expression e) exp2;
 304       pr_space(); mcode print_string colon; pr_space(); expression exp3
 305   | Ast.Postfix(exp,op) -> expression exp; mcode fixOp op
 306   | Ast.Infix(exp,op) -> mcode fixOp op; expression exp
 307   | Ast.Unary(exp,op) -> mcode unaryOp op; expression exp
 308   | Ast.Binary(left,op,right) ->
 309       expression left; pr_space(); mcode binaryOp op; pr_space();
 310       expression right
 311   | Ast.Nested(left,op,right) -> failwith "nested only in minus code"
 312   | Ast.Paren(lp,exp,rp) ->
 313       mcode print_string_box lp; expression exp; close_box();
 314       mcode print_string rp
 315   | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
 316       expression exp1; mcode print_string_box lb; expression exp2; close_box();
 317       mcode print_string rb
 318   | Ast.RecordAccess(exp,pt,field) ->
 319       expression exp; mcode print_string pt; ident field
 320   | Ast.RecordPtAccess(exp,ar,field) ->
 321       expression exp; mcode print_string ar; ident field
 322   | Ast.Cast(lp,ty,rp,exp) ->
 323       mcode print_string_box lp; fullType ty; close_box();
 324       mcode print_string rp; expression exp
 325   | Ast.SizeOfExpr(sizeof,exp) ->
 326       mcode print_string sizeof; expression exp
 327   | Ast.SizeOfType(sizeof,lp,ty,rp) ->
 328       mcode print_string sizeof;
 329       mcode print_string_box lp; fullType ty; close_box();
 330       mcode print_string rp
 331   | Ast.TypeExp(ty) -> fullType ty
 332   | Ast.Constructor(lp,ty,rp,init) ->
 333       mcode print_string_box lp; fullType ty; close_box();
 334       mcode print_string rp; initialiser true init
 335
 336   | Ast.MetaErr(name,_,_,_) ->
 337       failwith "metaErr not handled"
 338
 339   | Ast.MetaExpr (name,_,_,_typedontcare,_formdontcare,_) ->
 340       handle_metavar name  (function
 341         | Ast_c.MetaExprVal (exp,_) ->
 342             pretty_print_c.Pretty_print_c.expression exp
 343         | _ -> raise Impossible
 344       )
 345
 346   | Ast.MetaExprList (name,_,_,_) ->
 347       handle_metavar name  (function
 348         | Ast_c.MetaExprListVal args ->
 349             pretty_print_c.Pretty_print_c.arg_list args
 350         | Ast_c.MetaParamListVal _ ->
 351             failwith "have meta param list matching meta exp list\n";
 352         | _ -> raise Impossible
 353       )
 354
 355   | Ast.AsExpr(expr,asexpr) -> expression expr
 356
 357   | Ast.EComma(cm) -> mcode print_string cm
 358
 359   | Ast.DisjExpr(exp_list) ->
 360       if generating
 361       then print_disj_list expression exp_list
 362       else raise CantBeInPlus
 363   | Ast.NestExpr(starter,expr_dots,ender,Some whencode,multi)
 364     when generating ->
 365       nest_dots starter ender expression
 366         (function _ -> print_text "   when != "; expression whencode)
 367         expr_dots
 368   | Ast.NestExpr(starter,expr_dots,ender,None,multi) when generating ->
 369       nest_dots starter ender expression (function _ -> ()) expr_dots
 370   | Ast.NestExpr _ -> raise CantBeInPlus
 371   | Ast.Edots(dots,Some whencode)
 372   | Ast.Ecircles(dots,Some whencode)
 373   | Ast.Estars(dots,Some whencode) ->
 374       if generating
 375       then
 376         (mcode print_string dots;
 377          print_text "   when != ";
 378          expression whencode)
 379       else raise CantBeInPlus
 380   | Ast.Edots(dots,None)
 381   | Ast.Ecircles(dots,None)
 382   | Ast.Estars(dots,None) ->
 383       if generating
 384       then mcode print_string dots
 385       else raise CantBeInPlus
 386
 387   | Ast.OptExp(exp) | Ast.UniqueExp(exp) ->
 388       raise CantBeInPlus
 389
 390 and arg_expression e =
 391   match Ast.unwrap e with
 392     Ast.EComma(cm) ->
 393       (* space is only used by add_newline, and only if not using SMPL
 394          spacing.  pr_cspace uses a " " in unparse_c.ml.  Not so nice... *)
 395       mcode (print_string_with_hint (SpaceOrNewline (ref " ")))  cm
 396   | _ -> expression e
 397
 398 and  unaryOp = function
 399     Ast.GetRef -> print_string "&"
 400   | Ast.GetRefLabel -> print_string "&&"
 401   | Ast.DeRef -> print_string "*"
 402   | Ast.UnPlus -> print_string "+"
 403   | Ast.UnMinus -> print_string "-"
 404   | Ast.Tilde -> print_string "~"
 405   | Ast.Not -> print_string "!"
 406
 407 and  assignOp = function
 408     Ast.SimpleAssign -> print_string "="
 409   | Ast.OpAssign(aop) ->
 410       (function line -> function lcol ->
 411         arithOp aop line lcol; print_string "=" line lcol)
 412
 413 and  fixOp = function
 414     Ast.Dec -> print_string "--"
 415   | Ast.Inc -> print_string "++"
 416
 417 and  binaryOp = function
 418     Ast.Arith(aop) -> arithOp aop
 419   | Ast.Logical(lop) -> logicalOp lop
 420
 421 and  arithOp = function
 422    Ast.Plus -> print_string "+"
 423   | Ast.Minus -> print_string "-"
 424   | Ast.Mul -> print_string "*"
 425   | Ast.Div -> print_string "/"
 426   | Ast.Mod -> print_string "%"
 427   | Ast.DecLeft -> print_string "<<"
 428   | Ast.DecRight -> print_string ">>"
 429   | Ast.And -> print_string "&"
 430   | Ast.Or -> print_string "|"
 431   | Ast.Xor -> print_string "^"
 432
 433 and  logicalOp = function
 434     Ast.Inf -> print_string "<"
 435   | Ast.Sup -> print_string ">"
 436   | Ast.InfEq -> print_string "<="
 437   | Ast.SupEq -> print_string ">="
 438   | Ast.Eq -> print_string "=="
 439   | Ast.NotEq -> print_string "!="
 440   | Ast.AndLog -> print_string "&&"
 441   | Ast.OrLog -> print_string "||"
 442
 443 and constant = function
 444     Ast.String(s) -> print_string ("\""^s^"\"")
 445   | Ast.Char(s) -> print_string ("\'"^s^"\'")
 446   | Ast.Int(s) -> print_string s
 447   | Ast.Float(s) -> print_string s
 448
 449 (* --------------------------------------------------------------------- *)
 450 (* Types *)
 451
 452
 453 and fullType ft =
 454   match Ast.unwrap ft with
 455     Ast.Type(_,cv,ty) -> print_option_space (mcode const_vol) cv; typeC ty
 456   | Ast.AsType(ty, asty) -> fullType ty
 457   | Ast.DisjType _ -> failwith "can't be in plus"
 458   | Ast.OptType(_) | Ast.UniqueType(_) ->
 459       raise CantBeInPlus
 460
 461 and print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2) fn =
 462   fullType ty; mcode print_string lp1; mcode print_string star; fn();
 463   mcode print_string rp1; mcode print_string lp1;
 464   parameter_list params; mcode print_string rp2
 465
 466 and print_function_type (ty,lp1,params,rp1) fn =
 467   print_option fullType ty; fn(); mcode print_string lp1;
 468   parameter_list params; mcode print_string rp1
 469
 470 and typeC ty =
 471   match Ast.unwrap ty with
 472     Ast.BaseType(ty,strings) ->
 473       print_between pr_space (mcode print_string) strings
 474   | Ast.SignedT(sgn,ty) -> mcode sign sgn; print_option_prespace typeC ty
 475   | Ast.Pointer(ty,star) ->
 476       fullType ty; ft_space ty; mcode print_string star; eatspace()
 477   | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
 478       print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
 479         (function _ -> ())
 480   | Ast.FunctionType (am,ty,lp1,params,rp1) ->
 481       print_function_type (ty,lp1,params,rp1) (function _ -> ())
 482   | Ast.Array(ty,lb,size,rb) ->
 483       fullType ty; mcode print_string lb; print_option expression size;
 484       mcode print_string rb
 485   | Ast.EnumName(kind,name) ->
 486       mcode print_string kind;
 487       print_option_prespace ident name
 488   | Ast.EnumDef(ty,lb,ids,rb) ->
 489       fullType ty; ft_space ty;
 490       mcode print_string lb;
 491       dots force_newline expression ids;
 492       mcode print_string rb
 493   | Ast.StructUnionName(kind,name) ->
 494       mcode structUnion kind; print_option_prespace ident name
 495   | Ast.StructUnionDef(ty,lb,decls,rb) ->
 496       fullType ty; ft_space ty;
 497       mcode print_string lb;
 498       dots force_newline declaration decls;
 499       mcode print_string rb
 500   | Ast.TypeName(name)-> mcode print_string name
 501   | Ast.MetaType(name,_,_) ->
 502       handle_metavar name  (function
 503           Ast_c.MetaTypeVal exp ->
 504             pretty_print_c.Pretty_print_c.ty exp
 505         | _ -> raise Impossible)
 506
 507 and baseType = function
 508     Ast.VoidType -> print_string "void"
 509   | Ast.CharType -> print_string "char"
 510   | Ast.ShortType -> print_string "short"
 511   | Ast.ShortIntType -> print_string "short int"
 512   | Ast.IntType -> print_string "int"
 513   | Ast.DoubleType -> print_string "double"
 514   | Ast.LongDoubleType -> print_string "long double"
 515   | Ast.FloatType -> print_string "float"
 516   | Ast.LongType -> print_string "long"
 517   | Ast.LongIntType -> print_string "long int"
 518   | Ast.LongLongType -> print_string "long long"
 519   | Ast.LongLongIntType -> print_string "long long int"
 520   | Ast.SizeType -> print_string "size_t "
 521   | Ast.SSizeType -> print_string "ssize_t "
 522   | Ast.PtrDiffType -> print_string "ptrdiff_t "
 523
 524 and structUnion = function
 525     Ast.Struct -> print_string "struct"
 526   | Ast.Union -> print_string "union"
 527
 528 and sign = function
 529     Ast.Signed -> print_string "signed"
 530   | Ast.Unsigned -> print_string "unsigned"
 531
 532
 533 and const_vol = function
 534     Ast.Const -> print_string "const"
 535   | Ast.Volatile -> print_string "volatile"
 536
 537 (* --------------------------------------------------------------------- *)
 538 (* Function declaration *)
 539
 540 and storage = function
 541     Ast.Static -> print_string "static"
 542   | Ast.Auto -> print_string "auto"
 543   | Ast.Register -> print_string "register"
 544   | Ast.Extern -> print_string "extern"
 545
 546 (* --------------------------------------------------------------------- *)
 547 (* Variable declaration *)
 548
 549 and print_named_type ty id =
 550   match Ast.unwrap ty with
 551     Ast.Type(_,None,ty1) ->
 552       (match Ast.unwrap ty1 with
 553         Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
 554           print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
 555             (function _ -> pr_space(); ident id)
 556       | Ast.FunctionType(am,ty,lp1,params,rp1) ->
 557           print_function_type (ty,lp1,params,rp1)
 558             (function _ -> pr_space(); ident id)
 559       | Ast.Array(_,_,_,_) ->
 560           let rec loop ty k =
 561             match Ast.unwrap ty with
 562               Ast.Array(ty,lb,size,rb) ->
 563                 (match Ast.unwrap ty with
 564                   Ast.Type(_,cv,ty) ->
 565                     print_option_space (mcode const_vol) cv;
 566                     loop ty
 567                       (function _ ->
 568                         k ();
 569                         mcode print_string lb;
 570                         print_option expression size;
 571                         mcode print_string rb)
 572                 | _ -> failwith "complex array types not supported")
 573             | _ -> typeC ty; ty_space ty; ident id; k () in
 574           loop ty1 (function _ -> ())
 575     (*| should have a case here for pointer to array or function type
 576         that would put ( * ) around the variable.  This makes one wonder
 577         why we really need a special case for function pointer *)
 578       | _ -> fullType ty; ft_space ty; ident id)
 579   | _ -> fullType ty; ft_space ty; ident id
 580
 581 and ty_space ty =
 582   match Ast.unwrap ty with
 583     Ast.Pointer(_,_) -> ()
 584   | _ -> pr_space()
 585
 586 and ft_space ty =
 587   match Ast.unwrap ty with
 588     Ast.Type(_,cv,ty) ->
 589       (match Ast.unwrap ty with
 590         Ast.Pointer(_,_) -> ()
 591       | Ast.MetaType(name,_,_) ->
 592           (match List.assoc (Ast.unwrap_mcode name) env with
 593             Ast_c.MetaTypeVal (tq,ty) ->
 594               (match Ast_c.unwrap ty with
 595                 Ast_c.Pointer(_,_) -> ()
 596               | _ -> pr_space())
 597           | _ -> pr_space())
 598       | _ -> pr_space())
 599   | _ -> pr_space()
 600
 601 and declaration d =
 602   match Ast.unwrap d with
 603     Ast.MetaDecl(name,_,_) ->
 604       handle_metavar name
 605         (function
 606             Ast_c.MetaDeclVal d ->
 607               pretty_print_c.Pretty_print_c.decl d
 608           | _ -> raise Impossible)
 609   | Ast.MetaField(name,_,_) ->
 610       handle_metavar name
 611         (function
 612             Ast_c.MetaFieldVal f ->
 613               pretty_print_c.Pretty_print_c.field f
 614           | _ -> raise Impossible)
 615
 616   | Ast.MetaFieldList(name,_,_,_) ->
 617       handle_metavar name
 618         (function
 619             Ast_c.MetaFieldListVal f ->
 620               print_between force_newline pretty_print_c.Pretty_print_c.field f
 621           | _ -> raise Impossible)
 622
 623   | Ast.AsDecl(decl,asdecl) -> declaration decl
 624
 625   | Ast.Init(stg,ty,id,eq,ini,sem) ->
 626       print_option (mcode storage) stg;
 627       print_option (function _ -> pr_space()) stg;
 628       print_named_type ty id;
 629       pr_space(); mcode print_string eq;
 630       pr_space(); initialiser true ini; mcode print_string sem
 631   | Ast.UnInit(stg,ty,id,sem) ->
 632       print_option (mcode storage) stg;
 633       print_option (function _ -> pr_space()) stg;
 634       print_named_type ty id;
 635       mcode print_string sem
 636   | Ast.MacroDecl(name,lp,args,rp,sem) ->
 637       ident name; mcode print_string_box lp;
 638       dots (function _ -> ()) expression args;
 639       close_box(); mcode print_string rp; mcode print_string sem
 640   | Ast.MacroDeclInit(name,lp,args,rp,eq,ini,sem) ->
 641       ident name; mcode print_string_box lp;
 642       dots (function _ -> ()) expression args;
 643       close_box(); mcode print_string rp;
 644       pr_space(); mcode print_string eq;
 645       pr_space(); initialiser true ini; mcode print_string sem
 646   | Ast.TyDecl(ty,sem) -> fullType ty; mcode print_string sem
 647   | Ast.Typedef(stg,ty,id,sem) ->
 648       mcode print_string stg;
 649       fullType ty; typeC id;
 650       mcode print_string sem
 651   | Ast.DisjDecl(_) -> raise CantBeInPlus
 652   | Ast.Ddots(_,_) -> raise CantBeInPlus
 653   | Ast.OptDecl(decl)  | Ast.UniqueDecl(decl) ->
 654       raise CantBeInPlus
 655
 656 (* --------------------------------------------------------------------- *)
 657 (* Initialiser *)
 658
 659 and initialiser nlcomma i =
 660   match Ast.unwrap i with
 661     Ast.MetaInit(name,_,_) ->
 662       handle_metavar name  (function
 663           Ast_c.MetaInitVal ini ->
 664             pretty_print_c.Pretty_print_c.init ini
 665         | _ -> raise Impossible)
 666   | Ast.MetaInitList(name,_,_,_) ->
 667       handle_metavar name  (function
 668           Ast_c.MetaInitListVal ini ->
 669             pretty_print_c.Pretty_print_c.init_list ini
 670         | _ -> raise Impossible)
 671   | Ast.AsInit(init,asinit) -> initialiser nlcomma init
 672   | Ast.InitExpr(exp) -> expression exp
 673   | Ast.ArInitList(lb,initlist,rb) ->
 674       (match Ast.undots initlist with
 675         [] -> mcode print_string lb; mcode print_string rb
 676       | lst ->
 677           mcode print_string lb; start_block();
 678           initialiser_list nlcomma lst;
 679           end_block(); mcode print_string rb)
 680   | Ast.StrInitList(_,lb,[],rb,[]) ->
 681       mcode print_string lb; mcode print_string rb
 682   | Ast.StrInitList(_,lb,initlist,rb,[]) ->
 683       mcode print_string lb; start_block();
 684       initialiser_list nlcomma initlist;
 685       end_block(); mcode print_string rb
 686   | Ast.StrInitList(_,lb,initlist,rb,_) ->
 687       failwith "unexpected whencode in plus"
 688   | Ast.InitGccExt(designators,eq,ini) ->
 689       List.iter designator designators; pr_space();
 690       mcode print_string eq; pr_space(); initialiser nlcomma ini
 691   | Ast.InitGccName(name,eq,ini) ->
 692       ident name; mcode print_string eq; initialiser nlcomma ini
 693   | Ast.IComma(comma) ->
 694       mcode print_string comma;
 695       if nlcomma then force_newline() else pr_space()
 696   | Ast.Idots(dots,Some whencode) ->
 697       if generating
 698       then
 699         (mcode print_string dots;
 700          print_text "   when != ";
 701          initialiser nlcomma whencode)
 702       else raise CantBeInPlus
 703   | Ast.Idots(dots,None) ->
 704       if generating
 705       then mcode print_string dots
 706       else raise CantBeInPlus
 707   | Ast.OptIni(ini) | Ast.UniqueIni(ini) ->
 708       raise CantBeInPlus
 709
 710 and initialiser_list nlcomma = function
 711   (* awkward, because the comma is separate from the initialiser *)
 712     [] -> ()
 713   | [x] -> initialiser false x
 714   | x::xs -> initialiser nlcomma x; initialiser_list nlcomma xs
 715
 716 and designator = function
 717     Ast.DesignatorField(dot,id) -> mcode print_string dot; ident id
 718   | Ast.DesignatorIndex(lb,exp,rb) ->
 719       mcode print_string lb; expression exp; mcode print_string rb
 720   | Ast.DesignatorRange(lb,min,dots,max,rb) ->
 721       mcode print_string lb; expression min; mcode print_string dots;
 722       expression max; mcode print_string rb
 723
 724 (* --------------------------------------------------------------------- *)
 725 (* Parameter *)
 726
 727 and parameterTypeDef p =
 728   match Ast.unwrap p with
 729     Ast.VoidParam(ty) -> fullType ty
 730   | Ast.Param(ty,Some id) -> print_named_type ty id
 731   | Ast.Param(ty,None) -> fullType ty
 732
 733   | Ast.MetaParam(name,_,_) ->
 734       handle_metavar name
 735         (function
 736             Ast_c.MetaParamVal p ->
 737               pretty_print_c.Pretty_print_c.param p
 738           | _ -> raise Impossible)
 739   | Ast.MetaParamList(name,_,_,_) ->
 740       handle_metavar name
 741         (function
 742             Ast_c.MetaParamListVal p ->
 743               pretty_print_c.Pretty_print_c.paramlist p
 744           | _ -> raise Impossible)
 745
 746   | Ast.PComma(cm) -> mcode print_string cm
 747   | Ast.Pdots(dots) | Ast.Pcircles(dots) when generating ->
 748       mcode print_string dots
 749   | Ast.Pdots(dots) | Ast.Pcircles(dots) -> raise CantBeInPlus
 750   | Ast.OptParam(param) | Ast.UniqueParam(param) -> raise CantBeInPlus
 751
 752 and parameter_list l =
 753   let comma p =
 754     parameterTypeDef p;
 755     match Ast.unwrap p with
 756       Ast.PComma(cm) -> pr_space()
 757     | _ -> () in
 758   dots (function _ -> ()) comma l
 759 in
 760
 761
 762 (* --------------------------------------------------------------------- *)
 763 (* CPP code *)
 764
 765 let rec inc_file = function
 766     Ast.Local(elems) ->
 767       print_string ("\""^(String.concat "/" (List.map inc_elem elems))^"\"")
 768   | Ast.NonLocal(elems) ->
 769       print_string ("<"^(String.concat "/" (List.map inc_elem elems))^">")
 770
 771 and inc_elem = function
 772     Ast.IncPath s -> s
 773   | Ast.IncDots -> "..."
 774
 775 (* --------------------------------------------------------------------- *)
 776 (* Top-level code *)
 777
 778 and rule_elem arity re =
 779   match Ast.unwrap re with
 780     Ast.FunHeader(_,_,fninfo,name,lp,params,rp) ->
 781       pr_arity arity; List.iter print_fninfo fninfo;
 782       ident name; mcode print_string_box lp;
 783       parameter_list params; close_box(); mcode print_string rp;
 784       pr_space()
 785   | Ast.Decl(_,_,decl) -> pr_arity arity; declaration decl
 786
 787   | Ast.SeqStart(brace) ->
 788       pr_arity arity; mcode print_string brace; start_block()
 789   | Ast.SeqEnd(brace) ->
 790       end_block(); pr_arity arity; mcode print_string brace
 791
 792   | Ast.ExprStatement(exp,sem) ->
 793       pr_arity arity; print_option expression exp; mcode print_string sem
 794
 795   | Ast.IfHeader(iff,lp,exp,rp) ->
 796       pr_arity arity;
 797       mcode print_string iff; pr_space(); mcode print_string_box lp;
 798       expression exp; close_box(); mcode print_string rp
 799   | Ast.Else(els) ->
 800       pr_arity arity; mcode print_string els
 801
 802   | Ast.WhileHeader(whl,lp,exp,rp) ->
 803       pr_arity arity;
 804       mcode print_string whl; pr_space(); mcode print_string_box lp;
 805       expression exp; close_box(); mcode print_string rp
 806   | Ast.DoHeader(d) ->
 807       pr_arity arity; mcode print_string d
 808   | Ast.WhileTail(whl,lp,exp,rp,sem) ->
 809       pr_arity arity;
 810       mcode print_string whl; pr_space(); mcode print_string_box lp;
 811       expression exp; close_box(); mcode print_string rp;
 812       mcode print_string sem
 813   | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
 814       pr_arity arity;
 815       mcode print_string fr; mcode print_string_box lp;
 816       print_option expression e1; mcode print_string sem1;
 817       print_option expression e2; mcode print_string sem2;
 818       print_option expression e3; close_box();
 819       mcode print_string rp
 820   | Ast.IteratorHeader(nm,lp,args,rp) ->
 821       pr_arity arity;
 822       ident nm; pr_space(); mcode print_string_box lp;
 823       dots (function _ -> ()) expression args; close_box();
 824       mcode print_string rp
 825
 826   | Ast.SwitchHeader(switch,lp,exp,rp) ->
 827       pr_arity arity;
 828       mcode print_string switch; pr_space(); mcode print_string_box lp;
 829       expression exp; close_box(); mcode print_string rp
 830
 831   | Ast.Break(br,sem) ->
 832       pr_arity arity; mcode print_string br; mcode print_string sem
 833   | Ast.Continue(cont,sem) ->
 834       pr_arity arity; mcode print_string cont; mcode print_string sem
 835   | Ast.Label(l,dd) -> ident l; mcode print_string dd
 836   | Ast.Goto(goto,l,sem) ->
 837       mcode print_string goto; ident l; mcode print_string sem
 838   | Ast.Return(ret,sem) ->
 839       pr_arity arity; mcode print_string ret;
 840       mcode print_string sem
 841   | Ast.ReturnExpr(ret,exp,sem) ->
 842       pr_arity arity; mcode print_string ret; pr_space();
 843       expression exp; mcode print_string sem
 844
 845   | Ast.Exp(exp) -> pr_arity arity; expression exp
 846   | Ast.TopExp(exp) -> pr_arity arity; expression exp
 847   | Ast.Ty(ty) -> pr_arity arity; fullType ty
 848   | Ast.TopInit(init) -> initialiser false init
 849   | Ast.Include(inc,s) ->
 850       mcode print_string inc; print_text " "; mcode inc_file s
 851   | Ast.Undef(def,id) ->
 852       mcode print_string def; pr_space(); ident id
 853   | Ast.DefineHeader(def,id,params) ->
 854       mcode print_string def; pr_space(); ident id;
 855       print_define_parameters params
 856   | Ast.Default(def,colon) ->
 857       mcode print_string def; mcode print_string colon; pr_space()
 858   | Ast.Case(case,exp,colon) ->
 859       mcode print_string case; pr_space(); expression exp;
 860       mcode print_string colon; pr_space()
 861   | Ast.DisjRuleElem(res) ->
 862       if generating
 863       then
 864         (pr_arity arity; print_text "\n(\n";
 865          print_between (function _ -> print_text "\n|\n") (rule_elem arity)
 866            res;
 867          print_text "\n)")
 868       else raise CantBeInPlus
 869
 870   | Ast.MetaRuleElem(name,_,_) ->
 871       raise Impossible
 872
 873   | Ast.MetaStmt(name,_,_,_) ->
 874       handle_metavar name  (function
 875         | Ast_c.MetaStmtVal stm ->
 876             pretty_print_c.Pretty_print_c.statement stm
 877         | _ -> raise Impossible
 878                            )
 879   | Ast.MetaStmtList(name,_,_) ->
 880       failwith
 881         "MetaStmtList not supported (not even in ast_c metavars binding)"
 882
 883 and print_define_parameters params =
 884   match Ast.unwrap params with
 885     Ast.NoParams -> ()
 886   | Ast.DParams(lp,params,rp) ->
 887       mcode print_string lp;
 888       dots (function _ -> ()) print_define_param params; mcode print_string rp
 889
 890 and print_define_param param =
 891   match Ast.unwrap param with
 892     Ast.DParam(id) -> ident id
 893   | Ast.DPComma(comma) -> mcode print_string comma
 894   | Ast.DPdots(dots) -> mcode print_string dots
 895   | Ast.DPcircles(circles) -> mcode print_string circles
 896   | Ast.OptDParam(dp) -> print_text "?"; print_define_param dp
 897   | Ast.UniqueDParam(dp) -> print_text "!"; print_define_param dp
 898
 899 and print_fninfo = function
 900     Ast.FStorage(stg) -> mcode storage stg
 901   | Ast.FType(ty) -> fullType ty
 902   | Ast.FInline(inline) -> mcode print_string inline; pr_space()
 903   | Ast.FAttr(attr) -> mcode print_string attr; pr_space() in
 904
 905 let indent_if_needed s f =
 906   match Ast.unwrap s with
 907     Ast.Seq(lbrace,body,rbrace) -> pr_space(); f()
 908   | _ ->
 909       (*no newline at the end - someone else will do that*)
 910       start_block(); f(); unindent true in
 911
 912 let rec statement arity s =
 913   match Ast.unwrap s with
 914     Ast.Seq(lbrace,body,rbrace) ->
 915       rule_elem arity lbrace;
 916       dots force_newline (statement arity) body;
 917       rule_elem arity rbrace
 918
 919   | Ast.IfThen(header,branch,_) ->
 920       rule_elem arity header;
 921       indent_if_needed branch (function _ -> statement arity branch)
 922   | Ast.IfThenElse(header,branch1,els,branch2,_) ->
 923       rule_elem arity header;
 924       indent_if_needed branch1 (function _ -> statement arity branch1);
 925       force_newline();
 926       rule_elem arity els;
 927       indent_if_needed branch2 (function _ -> statement arity branch2)
 928   | Ast.While(header,body,_) ->
 929       rule_elem arity header;
 930       indent_if_needed body (function _ -> statement arity body)
 931   | Ast.Do(header,body,tail) ->
 932       rule_elem arity header;
 933       indent_if_needed body (function _ -> statement arity body);
 934       rule_elem arity tail
 935   | Ast.For(header,body,_) ->
 936       rule_elem arity header;
 937       indent_if_needed body (function _ -> statement arity body)
 938   | Ast.Iterator(header,body,(_,_,_,aft)) ->
 939       rule_elem arity header;
 940       indent_if_needed body (function _ -> statement arity body);
 941       mcode (fun _ _ _ -> ()) ((),Ast.no_info,aft,[])
 942
 943   | Ast.Switch(header,lb,decls,cases,rb) ->
 944       rule_elem arity header; pr_space(); rule_elem arity lb;
 945       dots force_newline (statement arity) decls;
 946       List.iter (function x -> case_line arity x; force_newline()) cases;
 947       rule_elem arity rb
 948
 949   | Ast.Atomic(re) -> rule_elem arity re
 950
 951   | Ast.FunDecl(header,lbrace,body,rbrace) ->
 952       rule_elem arity header; rule_elem arity lbrace;
 953       dots force_newline (statement arity) body; rule_elem arity rbrace
 954
 955   | Ast.Define(header,body) ->
 956       rule_elem arity header; pr_space();
 957       dots force_newline (statement arity) body
 958
 959   | Ast.AsStmt(stmt,asstmt) -> statement arity stmt
 960
 961   | Ast.Disj([stmt_dots]) ->
 962       if generating
 963       then
 964         (pr_arity arity;
 965          dots force_newline (statement arity) stmt_dots)
 966       else raise CantBeInPlus
 967   | Ast.Disj(stmt_dots_list) -> (* ignores newline directive for readability *)
 968       if generating
 969       then
 970         (pr_arity arity; print_text "\n(\n";
 971          print_between (function _ -> print_text "\n|\n")
 972            (dots force_newline (statement arity))
 973            stmt_dots_list;
 974          print_text "\n)")
 975       else raise CantBeInPlus
 976   | Ast.Nest(starter,stmt_dots,ender,whn,multi,_,_) when generating ->
 977       pr_arity arity;
 978       nest_dots starter ender (statement arity)
 979         (function _ ->
 980           print_between force_newline
 981             (whencode (dots force_newline (statement "")) (statement "")) whn;
 982           force_newline())
 983         stmt_dots
 984   | Ast.Nest(_) -> raise CantBeInPlus
 985   | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
 986       if generating
 987       then
 988         (pr_arity arity; mcode print_string d;
 989          print_between force_newline
 990            (whencode (dots force_newline (statement "")) (statement "")) whn;
 991          force_newline())
 992       else raise CantBeInPlus
 993
 994   | Ast.OptStm(s) | Ast.UniqueStm(s) ->
 995       raise CantBeInPlus
 996
 997 and whencode notfn alwaysfn = function
 998     Ast.WhenNot a ->
 999       print_text "   WHEN != "; notfn a
1000   | Ast.WhenAlways a ->
1001       print_text "   WHEN = "; alwaysfn a
1002   | Ast.WhenModifier x -> print_text "   WHEN "; print_when_modif x
1003   | Ast.WhenNotTrue a ->
1004       print_text "   WHEN != TRUE "; rule_elem "" a
1005   | Ast.WhenNotFalse a ->
1006       print_text "   WHEN != FALSE "; rule_elem "" a
1007
1008 and print_when_modif = function
1009   | Ast.WhenAny    -> print_text "ANY"
1010   | Ast.WhenStrict -> print_text "STRICT"
1011   | Ast.WhenForall -> print_text "FORALL"
1012   | Ast.WhenExists -> print_text "EXISTS"
1013
1014 and case_line arity c =
1015   match Ast.unwrap c with
1016     Ast.CaseLine(header,code) ->
1017       rule_elem arity header; pr_space();
1018       dots force_newline (statement arity) code
1019   | Ast.OptCase(case) -> raise CantBeInPlus in
1020
1021 let top_level t =
1022   match Ast.unwrap t with
1023     Ast.FILEINFO(old_file,new_file) -> raise CantBeInPlus
1024   | Ast.NONDECL(stmt) -> statement "" stmt
1025   | Ast.CODE(stmt_dots) -> dots force_newline (statement "") stmt_dots
1026   | Ast.ERRORWORDS(exps) -> raise CantBeInPlus
1027 in
1028
1029 (*
1030 let rule =
1031   print_between (function _ -> force_newline(); force_newline()) top_level
1032 in
1033 *)
1034
1035 let if_open_brace  = function "{" -> true | _ -> false in
1036
1037 (* boolean result indicates whether an indent is needed *)
1038 let rec pp_any = function
1039   (* assert: normally there is only CONTEXT NOTHING tokens in any *)
1040     Ast.FullTypeTag(x) -> fullType x; false
1041   | Ast.BaseTypeTag(x) -> baseType x unknown unknown; false
1042   | Ast.StructUnionTag(x) -> structUnion x unknown unknown; false
1043   | Ast.SignTag(x) -> sign x unknown unknown; false
1044
1045   | Ast.IdentTag(x) -> ident x; false
1046
1047   | Ast.ExpressionTag(x) -> expression x; false
1048
1049   | Ast.ConstantTag(x) -> constant x unknown unknown; false
1050   | Ast.UnaryOpTag(x) -> unaryOp x unknown unknown; false
1051   | Ast.AssignOpTag(x) -> assignOp x unknown unknown; false
1052   | Ast.FixOpTag(x) -> fixOp x unknown unknown; false
1053   | Ast.BinaryOpTag(x) -> binaryOp x unknown unknown; false
1054   | Ast.ArithOpTag(x) -> arithOp x unknown unknown; false
1055   | Ast.LogicalOpTag(x) -> logicalOp x unknown unknown; false
1056
1057   | Ast.InitTag(x) -> initialiser false x; false
1058   | Ast.DeclarationTag(x) -> declaration x; false
1059
1060   | Ast.StorageTag(x) -> storage x unknown unknown; false
1061   | Ast.IncFileTag(x) -> inc_file x unknown unknown; false
1062
1063   | Ast.Rule_elemTag(x) -> rule_elem "" x; false
1064   | Ast.StatementTag(x) -> statement "" x; false
1065   | Ast.CaseLineTag(x) -> case_line "" x; false
1066
1067   | Ast.ConstVolTag(x) -> const_vol x unknown unknown; false
1068   | Ast.Pragma(xs) ->
1069       (match xs with (Ast.Space s)::_ -> pr_space() | _ -> ());
1070       let rec loop = function
1071           [] -> ()
1072         | [Ast.Noindent s] -> unindent false; print_text s
1073         | [Ast.Indent s] -> print_text s
1074         | (Ast.Space s) :: (((Ast.Indent _ | Ast.Noindent _) :: _) as rest) ->
1075             print_text s; force_newline(); loop rest
1076         | (Ast.Space s) :: rest -> print_text s; pr_space(); loop rest
1077         | Ast.Noindent s :: rest ->
1078             unindent false; print_text s; force_newline(); loop rest
1079         | Ast.Indent s :: rest ->
1080             print_text s; force_newline(); loop rest in
1081       loop xs; false
1082   | Ast.Token(x,None) -> print_text x; if_open_brace x
1083   | Ast.Token(x,Some info) ->
1084       mcode
1085         (fun x line lcol ->
1086           (match x with
1087             "else" -> force_newline()
1088           | _ -> ());
1089           print_string x line lcol)
1090         (let nomcodekind = Ast.CONTEXT(Ast.DontCarePos,Ast.NOTHING) in
1091         (x,info,nomcodekind,[]));
1092       if_open_brace x
1093
1094   | Ast.Code(x) -> let _ = top_level x in false
1095
1096   (* this is not '...', but a list of expr/statement/params, and
1097      normally there should be no '...' inside them *)
1098   | Ast.ExprDotsTag(x) -> dots (function _ -> ()) expression x; false
1099   | Ast.ParamDotsTag(x) -> parameter_list x; false
1100   | Ast.StmtDotsTag(x) -> dots force_newline (statement "") x; false
1101   | Ast.DeclDotsTag(x) -> dots force_newline declaration x; false
1102
1103   | Ast.TypeCTag(x) -> typeC x; false
1104   | Ast.ParamTag(x) -> parameterTypeDef x; false
1105   | Ast.SgrepStartTag(x) -> failwith "unexpected start tag"
1106   | Ast.SgrepEndTag(x) -> failwith "unexpected end tag"
1107 in
1108
1109 (*Printf.printf "start of the function\n";*)
1110
1111   anything := (function x -> let _ = pp_any x in ());
1112
1113   (* todo? imitate what is in pretty_print_cocci ? *)
1114   match xxs with
1115     [] -> ()
1116   | x::xs ->
1117       (* for many tags, we must not do a newline before the first '+' *)
1118       let isfn s =
1119         match Ast.unwrap s with Ast.FunDecl _ -> true | _ -> false in
1120       let unindent_before = function
1121         (* need to get unindent before newline for } *)
1122           (Ast.Token ("}",_)::_) -> true
1123         | _ -> false in
1124       let prnl x =
1125         (if unindent_before x then unindent true);
1126         force_newline() in
1127       let newline_before _ =
1128         if before =*= After
1129         then
1130           let hd = List.hd xxs in
1131           match hd with
1132             (Ast.Pragma l::_)
1133               when List.for_all (function Ast.Space x -> true | _ -> false) l ->
1134                 ()
1135           | (Ast.StatementTag s::_) when isfn s ->
1136               force_newline(); force_newline()
1137           | (Ast.Pragma _::_)
1138           | (Ast.Rule_elemTag _::_) | (Ast.StatementTag _::_)
1139           | (Ast.InitTag _::_)
1140           | (Ast.DeclarationTag _::_) | (Ast.Token ("}",_)::_) -> prnl hd
1141           | _ -> () in
1142       let newline_after _ =
1143         if before =*= Before
1144         then
1145           match List.rev(List.hd(List.rev xxs)) with
1146             (Ast.StatementTag s::_) ->
1147               (if isfn s then force_newline());
1148               force_newline()
1149           | (Ast.Pragma _::_)
1150           | (Ast.Rule_elemTag _::_) | (Ast.InitTag _::_)
1151           | (Ast.DeclarationTag _::_) | (Ast.Token ("{",_)::_) ->
1152               force_newline()
1153           | _ -> () in
1154       (* print a newline at the beginning, if needed *)
1155       newline_before();
1156       (* print a newline before each of the rest *)
1157       let rec loop leading_newline indent_needed = function
1158           [] -> ()
1159         | x::xs ->
1160             (if leading_newline
1161             then
1162               match (indent_needed,unindent_before x) with
1163                 (true,true) -> force_newline()
1164               | (true,false) -> force_newline(); indent()
1165               | (false,true) -> unindent true; force_newline()
1166               | (false,false) -> force_newline());
1167             let space_needed_before = function
1168                 Ast.ParamTag(x) ->
1169                   (match Ast.unwrap x with
1170                     Ast.PComma _ -> false
1171                   | _ -> true)
1172               | Ast.ExpressionTag(x) ->
1173                   (match Ast.unwrap x with
1174                     Ast.EComma _ -> false
1175                   | _ -> true)
1176               | Ast.InitTag(x) ->
1177                   (match Ast.unwrap x with
1178                     Ast.IComma _ -> false
1179                   | _ -> true)
1180               | Ast.Token(t,_) when List.mem t [",";";";"(";")";".";"->"] ->
1181                   false
1182               | _ -> true in
1183             let space_needed_after = function
1184                 Ast.Token(t,_)
1185                 when List.mem t ["(";".";"->"] -> (*never needed*) false
1186               | Ast.Token(t,_) when List.mem t ["if";"for";"while";"do"] ->
1187                   (* space always needed *)
1188                   pr_space(); false
1189               | Ast.ExpressionTag(e) ->
1190                   (match Ast.unwrap e with
1191                     Ast.EComma _ ->
1192                       (* space always needed *)
1193                       pr_space(); false
1194                   | _ -> true)
1195               | t -> true in
1196             let indent_needed =
1197               let rec loop space_after indent_needed = function
1198                   [] -> indent_needed
1199                 | x::xs ->
1200                     (if space_after && space_needed_before x
1201                     then pr_space());
1202                     let indent_needed = pp_any x in
1203                     let space_after = space_needed_after x in
1204                     loop space_after indent_needed xs in
1205               loop false false x in
1206             loop true indent_needed xs in
1207       loop false false (x::xs);
1208       (* print a newline at the end, if needed *)
1209       newline_after()
1210
1211 let rec pp_list_list_any (envs, pr, pr_celem, pr_cspace, pr_space, pr_arity,
1212                           pr_barrier, indent, unindent, eatspace)
1213     generating xxs before =
1214   List.iter
1215     (function env ->
1216       do_all (env, pr, pr_celem, pr_cspace, pr_space, pr_arity, pr_barrier,
1217               indent, unindent, eatspace)
1218         generating xxs before)
1219     envs