mcc-0.5.4rta03/arch/x86/moogle/mlprog/moogle_mlp_print.ml

   1 (*
   2    Print an ML program
   3    Copyright (C) 2002,2001 Justin David Smith, Caltech
   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
   7    as published by the Free Software Foundation; either version 2
   8    of the License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  *)
  19 open Format
  20 open Symbol
  21
  22 open Moogle_mlp_ocaml
  23 open Moogle_mlp_type
  24 open Moogle_util
  25
  26
  27 (***  Basic Printers  ***)
  28
  29
  30 (* pp_print_pragma
  31    Print out a pragma definition.  This will inherit the box of the caller,
  32    although line info pragmas will often significantly distort the boxes
  33    anywho...  *)
  34 let pp_print_pragma buf pragma =
  35    match pragma with
  36       Comment text ->
  37          fprintf buf "(* @[<v 0>";
  38          pp_print_ocaml_block_text buf text;
  39          fprintf buf "@] *)@ "
  40     | LineInfo (file_pos, mark) ->
  41          pp_print_ocaml_line_break buf file_pos mark
  42
  43
  44 (* pp_print_delim_space_list
  45    Print a list of elements, separated by delim followed by print_space.  *)
  46 let pp_print_delim_space_list buf delim f ls =
  47    let fold_fun first l =
  48       if not first then
  49          fprintf buf "%s@ " delim;
  50       f buf l;
  51       false
  52    in
  53       ignore (List.fold_left fold_fun true ls)
  54
  55
  56 (* pp_print_space_delim_list
  57    Print a list of elements, separated by print_space followed by delim.
  58    This prints the delimiter and space in the opposite order of above...  *)
  59 let pp_print_space_delim_list buf delim f ls =
  60    let fold_fun first l =
  61       if not first then
  62          fprintf buf "@ %s" delim;
  63       f buf l;
  64       false
  65    in
  66       ignore (List.fold_left fold_fun true ls)
  67
  68
  69 (***  Atom Printing  ***)
  70
  71
  72 (* atom_expr_type
  73    Determines the type of an atom expression, which is used to
  74    determine if a child atom can be printed without explicit
  75    parenthesization inside of a parent atom.  *)
  76 type atom_expr_type =
  77    ATSafe
  78  | ATDot
  79  | ATBinop of binop
  80  | ATList
  81  | ATListCons
  82  | ATTuple
  83  | ATConst
  84  | ATAs
  85  | ATFuncall
  86
  87
  88 (* safe_atom
  89    Returns true if an atom of type self can be printed within an
  90    atom of type parent without explicit parenthesization around a.  *)
  91 let safe_atom parent self =
  92    match parent, self with
  93       ATSafe, _
  94       (* Dot expressions bind very tightly *)
  95     | (ATDot | ATBinop _ | ATList | ATListCons | ATTuple | ATConst | ATFuncall), ATDot
  96       (* Binary operators must consider precedence *)
  97     | ATBinop BAndOp, ATBinop BAndOp
  98     | ATBinop BOrOp, ATBinop BOrOp
  99     | ATBinop (BAndOp | BOrOp), ATBinop (EqOp | NEqOp | LtOp)
 100     | ATBinop _, ATFuncall
 101       (* Structures which are permissible inside lists... *)
 102     | (ATList | ATListCons | ATTuple), (ATBinop _ | ATList | ATFuncall | ATConst)
 103     | ATList, (ATListCons | ATTuple)
 104       (* Tuples can contain lists (not vice versa) *)
 105     | ATTuple, ATListCons
 106       (* Single-argument constructors are not parenthesized, so if we
 107          have a constructor parent, we cannot accept arithmetic ops. *)
 108     | ATConst, ATList
 109     | ATFuncall, ATList ->
 110          true
 111
 112       (* Cases which are not safe *)
 113     | ATDot, (ATBinop _ | ATList | ATListCons | ATTuple | ATConst | ATFuncall)
 114     | ATBinop (EqOp | NEqOp | LtOp), ATBinop _
 115     | ATBinop BAndOp, ATBinop BOrOp
 116     | ATBinop BOrOp, ATBinop BAndOp
 117     | ATBinop _, (ATList | ATListCons | ATTuple | ATConst)
 118     | ATListCons, (ATListCons | ATTuple)
 119     | ATTuple, ATTuple
 120     | ATConst, (ATBinop _ | ATListCons | ATTuple | ATConst | ATFuncall)
 121     | ATFuncall, (ATBinop _ | ATListCons | ATTuple | ATConst | ATFuncall)
 122       (* Don't know where I need to be strict about as *)
 123     | ATAs, _
 124     | _, ATAs
 125     | _, ATSafe ->
 126          false
 127
 128
 129 (* pp_print_binop
 130    Print an infix binary operator.  *)
 131 let pp_print_binop buf op =
 132    match op with
 133       BAndOp ->
 134          fprintf buf "&&"
 135     | BOrOp ->
 136          fprintf buf "||"
 137     | EqOp ->
 138          fprintf buf "="
 139     | NEqOp ->
 140          fprintf buf "<>"
 141     | LtOp ->
 142          fprintf buf "<"
 143
 144
 145 (* pp_print_atom
 146    Prints an atom.  The parent indicates the type of the parent atom, and is
 147    used to determine if this atom expression must be parenthesized.  External
 148    calls to pp_print_atom should use ATSafe for the parent type.  *)
 149 let rec pp_print_atom buf parent atom =
 150    let parens_if_unsafe self f =
 151       let not_safe = not (safe_atom parent self) in
 152          if not_safe then
 153             pp_print_string buf "(";
 154          f ();
 155          if not_safe then
 156             pp_print_string buf ")"
 157    in
 158       match atom with
 159          AtomVar v ->
 160             fprintf buf "%s" (string_of_symbol v)
 161        | AtomBool b ->
 162             fprintf buf "%b" b
 163        | AtomInt i ->
 164             fprintf buf "%d" i
 165        | AtomInt32 i ->
 166             fprintf buf "%s" (string_of_int32 i)
 167        | AtomString s ->
 168             fprintf buf "\"%s\"" (String.escaped s)
 169        | AtomDot (a1, a2) ->
 170             pp_print_atom buf ATDot a1;
 171             fprintf buf ".";
 172             pp_print_atom buf ATDot a2;
 173        | AtomBinop (op, a1, a2) ->
 174             parens_if_unsafe (ATBinop op) (fun () ->
 175                fprintf buf "@[<hov 0>";
 176                pp_print_atom buf (ATBinop op) a1;
 177                fprintf buf "@ ";
 178                pp_print_binop buf op;
 179                fprintf buf "@ ";
 180                pp_print_atom buf (ATBinop op) a2;
 181                fprintf buf "@]")
 182        | AtomList atoms ->
 183             fprintf buf "[@[<hov 0>";
 184             pp_print_delim_space_list buf ";" (fun buf -> pp_print_atom buf ATList) atoms;
 185             fprintf buf "@]]";
 186        | AtomListCons (atoms, tl) ->
 187             parens_if_unsafe ATListCons (fun () ->
 188                fprintf buf "@[<hv 0>";
 189                pp_print_delim_space_list buf " ::" (fun buf -> pp_print_atom buf ATListCons) (atoms @ [tl]);
 190                fprintf buf "@]")
 191        | AtomTuple atoms ->
 192             parens_if_unsafe ATTuple (fun () ->
 193                fprintf buf "@[<hov 0>";
 194                pp_print_delim_space_list buf "," (fun buf -> pp_print_atom buf ATTuple) atoms;
 195                fprintf buf "@]")
 196        | AtomStruct fields ->
 197             fprintf buf "{ @[<v 0>";
 198             pp_print_delim_space_list buf ";" (fun buf (field, a) ->
 199                fprintf buf "%s = " (string_of_symbol field);
 200                pp_print_atom buf ATSafe a) fields;
 201             fprintf buf "@] }";
 202        | AtomConst (name, atoms) ->
 203             begin
 204             match atoms with
 205                [] ->
 206                   fprintf buf "%s" (string_of_symbol name)
 207              | [atom] ->
 208                   parens_if_unsafe ATConst (fun () ->
 209                      fprintf buf "@[<hov 3>%s" (string_of_symbol name);
 210                      fprintf buf "@ ";
 211                      pp_print_atom buf ATConst atom;
 212                      fprintf buf "@]")
 213              | _ ->
 214                   parens_if_unsafe ATConst (fun () ->
 215                      fprintf buf "@[<hov 3>%s" (string_of_symbol name);
 216                      fprintf buf "@ (";
 217                      pp_print_delim_space_list buf "," (fun buf -> pp_print_atom buf ATConst) atoms;
 218                      fprintf buf ")@]")
 219             end
 220        | AtomAs (a, name) ->
 221             parens_if_unsafe ATAs (fun () ->
 222                fprintf buf "@[<hov 0>";
 223                pp_print_atom buf ATAs a;
 224                fprintf buf "@ as %s@]" (string_of_symbol name))
 225        | AtomOCaml text ->
 226             fprintf buf "(@[<v -9999>";
 227             pp_print_ocaml_block_text buf text;
 228             fprintf buf "@])"
 229        | AtomFuncall (f, atoms) ->
 230             parens_if_unsafe ATFuncall (fun () ->
 231                fprintf buf "@[<hov 3>";
 232                pp_print_atom buf ATFuncall f;
 233                List.iter (fun a ->
 234                   fprintf buf "@ ";
 235                   pp_print_atom buf ATFuncall a) atoms;
 236                fprintf buf "@]")
 237        | AtomPragma (p, a) ->
 238             fprintf buf "@[<v 0>";
 239             pp_print_pragma buf p;
 240             pp_print_atom buf parent a;
 241             fprintf buf "@]"
 242
 243
 244 (***  Expression/Statement Printers  ***)
 245
 246
 247 (* pp_print_match_cases
 248    Print out the cases in a match statement.  *)
 249 let rec pp_print_match_cases buf cases =
 250    let pp_print_match_case buf (pattern, clause, e) =
 251       fprintf buf "@[<v 3>";
 252       (match clause with
 253          None ->
 254             pp_print_atom buf ATSafe pattern;
 255             fprintf buf " ->@ "
 256        | Some e ->
 257             fprintf buf "@[<v 0>";
 258             pp_print_atom buf ATSafe pattern;
 259             fprintf buf "@ @[<hv 3>when@ ";
 260             pp_print_expression buf e;
 261             fprintf buf "@]@ ->@]@ ");
 262       pp_print_expression buf e;
 263       fprintf buf "@]"
 264    in
 265       fprintf buf "   ";
 266       pp_print_space_delim_list buf " | " pp_print_match_case cases
 267
 268
 269 (* pp_print_expression
 270    Print out an entire expression.  This call may recurse.  *)
 271 and pp_print_expression buf expr =
 272    fprintf buf "@[<v 0>";
 273    (match expr with
 274       Value a ->
 275          pp_print_atom buf ATSafe a
 276     | Raise a ->
 277          fprintf buf "raise (";
 278          pp_print_atom buf ATSafe a;
 279          fprintf buf ")"
 280     | LetIn (v, args, e1, e2) ->
 281          fprintf buf "@[<hv 3>let@[<h>";
 282          List.iter (fun v -> fprintf buf "@ %s" (string_of_symbol v)) (v :: args);
 283          fprintf buf "@] =@ ";
 284          pp_print_expression buf e1;
 285          fprintf buf " in@]@ ";
 286          pp_print_expression buf e2
 287     | LetRec (v, args, e1, e2) ->
 288          fprintf buf "@[<hv 3>let rec@[<h>";
 289          List.iter (fun v -> fprintf buf "@ %s" (string_of_symbol v)) (v :: args);
 290          fprintf buf "@] =@ ";
 291          pp_print_expression buf e1;
 292          fprintf buf " in@]@ ";
 293          pp_print_expression buf e2
 294     | Match (a, cases) ->
 295          fprintf buf "@[<v 0>match ";
 296          pp_print_atom buf ATSafe a;
 297          fprintf buf " with@ ";
 298          pp_print_match_cases buf cases;
 299          fprintf buf "@]"
 300     | If (a, e1, e2) ->
 301          fprintf buf "@[<v 0>@[<hov 3>if@ ";
 302          pp_print_atom buf ATSafe a;
 303          fprintf buf "@]@ @[<v 3>then@ ";
 304          pp_print_expression buf e1;
 305          fprintf buf "@]@ @[<v 3>else@ ";
 306          pp_print_expression buf e2;
 307          fprintf buf "@]@]"
 308     | Block e ->
 309          fprintf buf "@[<v 0>begin@ ";
 310          pp_print_expression buf e;
 311          fprintf buf "@ end@]"
 312     | Pragma (p, e) ->
 313          pp_print_pragma buf p;
 314          pp_print_expression buf e);
 315    fprintf buf "@]"
 316
 317
 318 (* pp_print_statement
 319    Print out a top-level ML statement.  *)
 320 let pp_print_statement buf stmt =
 321    match stmt with
 322       Open name ->
 323          fprintf buf "open %s@ @ " (string_of_symbol name)
 324     | Let (v, args, e) ->
 325          fprintf buf "@[<hv 3>let@[<h>";
 326          List.iter (fun v -> fprintf buf "@ %s" (string_of_symbol v)) (v :: args);
 327          fprintf buf "@] =@ ";
 328          pp_print_expression buf e;
 329          fprintf buf "@]@ @ "
 330     | OCaml text ->
 331          pp_print_ocaml_block_text buf text;
 332     | Expression e ->
 333          pp_print_expression buf e;
 334          fprintf buf "@ "
 335     | TopPragma p ->
 336          pp_print_pragma buf p
 337
 338
 339 (***  Interface Statements  ***)
 340
 341
 342 (* pp_print_itype
 343    Print out a type for an MLI file.  *)
 344 let rec pp_print_itype buf ty =
 345    match ty with
 346       ITyName name ->
 347          fprintf buf "%s" (string_of_symbol name)
 348     | ITyFun (t1, t2) ->
 349          fprintf buf "@[<hov 0>(";
 350          pp_print_itype buf t1;
 351          fprintf buf ") ->@ ";
 352          pp_print_itype buf t2;
 353          fprintf buf "@]"
 354     | ITyDot (t1, t2) ->
 355          pp_print_itype buf t1;
 356          fprintf buf ".";
 357          pp_print_itype buf t2
 358     | ITyApply (t1, t2) ->
 359          fprintf buf "@[<hov 0>(";
 360          pp_print_itype buf t1;
 361          fprintf buf ")@ ";
 362          pp_print_itype buf t2;
 363          fprintf buf "@]"
 364
 365
 366 (* pp_print_istatement
 367    Print out a top-level MLI statement.  *)
 368 let pp_print_istatement buf stmt =
 369    match stmt with
 370       IOpen name ->
 371          fprintf buf "open %s@ @ " (string_of_symbol name)
 372     | IVal (v, ty) ->
 373          fprintf buf "@[<hv 3>val %s :@ " (string_of_symbol v);
 374          pp_print_itype buf ty;
 375          fprintf buf "@]@ @ "
 376     | ITopPragma p ->
 377          pp_print_pragma buf p
 378
 379
 380 (***  External Interface  ***)
 381
 382
 383 (* pp_print_program
 384    Print an ML file.  *)
 385 let pp_print_program buf prog =
 386    let prog = Listbuf.to_list prog in
 387       fprintf buf "@[<v 0>";
 388       List.iter (pp_print_statement buf) prog;
 389       fprintf buf "@]@."
 390
 391
 392 (* pp_print_interface
 393    Print an MLI file.  *)
 394 let pp_print_interface buf prog =
 395    let prog = Listbuf.to_list prog in
 396       fprintf buf "@[<v 0>";
 397       List.iter (pp_print_istatement buf) prog;
 398       fprintf buf "@]@."
 399
 400