#5741: make Pprintast available from the command-line (-dsource).

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13025 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

16 files changed, 36 insertions, 2 deletions

diff --git a/driver/compile.ml b/driver/compile.ml
index c3873d32f..f1aaaa9e7 100644
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -82,6 +82,7 @@ let interface ppf sourcefile outputprefix =
     let ast =
       Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
     if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+    if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
     let tsg = Typemod.transl_signature initial_env ast in
     let sg = tsg.sig_type in
     if !Clflags.print_types then
@@ -121,6 +122,7 @@ let implementation ppf sourcefile outputprefix =
     try ignore(
       Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+      ++ print_if ppf Clflags.dump_source Pprintast.structure
       ++ Typemod.type_implementation sourcefile outputprefix modulename env);
       Warnings.check_fatal ();
       Pparse.remove_preprocessed inputfile;
@@ -135,6 +137,7 @@ let implementation ppf sourcefile outputprefix =
     try
       Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+      ++ print_if ppf Clflags.dump_source Pprintast.structure
       ++ Typemod.type_implementation sourcefile outputprefix modulename env
       ++ Translmod.transl_implementation modulename
       ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
diff --git a/driver/main.ml b/driver/main.ml
index 8b895af63..b3d5842a0 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -138,6 +138,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _where = print_standard_library
   let _verbose = set verbose
   let _nopervasives = set nopervasives
+  let _dsource = set dump_source
   let _dparsetree = set dump_parsetree
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
diff --git a/driver/main_args.ml b/driver/main_args.ml
index c5fd7c8f3..3f3e063ae 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -330,6 +330,10 @@ let mk_drawlambda f =
   "-drawlambda", Arg.Unit f, " (undocumented)"
 ;;
 
+let mk_dsource f =
+  "-dsource", Arg.Unit f, " (undocumented)"
+;;
+
 let mk_dlambda f =
   "-dlambda", Arg.Unit f, " (undocumented)"
 ;;
@@ -450,6 +454,7 @@ module type Bytecomp_options = sig
 
   val _nopervasives : unit -> unit
   val _use_prims : string -> unit
+  val _dsource : unit -> unit
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
@@ -480,6 +485,7 @@ module type Bytetop_options = sig
   val _warn_error : string -> unit
   val _warn_help : unit -> unit
 
+  val _dsource : unit -> unit
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
@@ -539,6 +545,7 @@ module type Optcomp_options = sig
   val _where : unit -> unit
 
   val _nopervasives : unit -> unit
+  val _dsource : unit -> unit
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
@@ -585,6 +592,7 @@ module type Opttop_options = sig
   val _warn_error : string -> unit
   val _warn_help : unit -> unit
 
+  val _dsource : unit -> unit
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
@@ -669,6 +677,7 @@ struct
 
     mk_nopervasives F._nopervasives;
     mk_use_prims F._use_prims;
+    mk_dsource F._dsource;
     mk_dparsetree F._dparsetree;
     mk_drawlambda F._drawlambda;
     mk_dlambda F._dlambda;
@@ -702,6 +711,7 @@ struct
     mk_warn_error F._warn_error;
     mk_warn_help F._warn_help;
 
+    mk_dsource F._dsource;
     mk_dparsetree F._dparsetree;
     mk_drawlambda F._drawlambda;
     mk_dlambda F._dlambda;
@@ -765,6 +775,7 @@ struct
     mk_where F._where;
 
     mk_nopervasives F._nopervasives;
+    mk_dsource F._dsource;
     mk_dparsetree F._dparsetree;
     mk_drawlambda F._drawlambda;
     mk_dlambda F._dlambda;
@@ -813,6 +824,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_warn_error F._warn_error;
     mk_warn_help F._warn_help;
 
+    mk_dsource F._dsource;
     mk_dparsetree F._dparsetree;
     mk_drawlambda F._drawlambda;
     mk_dclambda F._dclambda;
diff --git a/driver/main_args.mli b/driver/main_args.mli
index bbdc8ec41..80e659e3f 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -62,6 +62,7 @@ module type Bytecomp_options =
 
     val _nopervasives : unit -> unit
     val _use_prims : string -> unit
+    val _dsource : unit -> unit
     val _dparsetree : unit -> unit
     val _drawlambda : unit -> unit
     val _dlambda : unit -> unit
@@ -93,6 +94,7 @@ module type Bytetop_options = sig
   val _warn_error : string -> unit
   val _warn_help : unit -> unit
 
+  val _dsource : unit -> unit
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
@@ -152,6 +154,7 @@ module type Optcomp_options = sig
   val _where : unit -> unit
 
   val _nopervasives : unit -> unit
+  val _dsource : unit -> unit
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
@@ -198,6 +201,7 @@ module type Opttop_options = sig
   val _warn_error : string -> unit
   val _warn_help : unit -> unit
 
+  val _dsource : unit -> unit
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
diff --git a/driver/optcompile.ml b/driver/optcompile.ml
index 9bd1d9b05..1c0a540ae 100644
--- a/driver/optcompile.ml
+++ b/driver/optcompile.ml
@@ -79,6 +79,7 @@ let interface ppf sourcefile outputprefix =
     let ast =
       Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
     if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+    if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
     let tsg = Typemod.transl_signature initial_env ast in
     let sg = tsg.sig_type in
     if !Clflags.print_types then
@@ -123,10 +124,12 @@ let implementation ppf sourcefile outputprefix =
     if !Clflags.print_types then ignore(
       Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+      ++ print_if ppf Clflags.dump_source Pprintast.structure
       ++ Typemod.type_implementation sourcefile outputprefix modulename env)
     else begin
       Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+      ++ print_if ppf Clflags.dump_source Pprintast.structure
       ++ Typemod.type_implementation sourcefile outputprefix modulename env
       ++ Translmod.transl_store_implementation modulename
       +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 9afdbb428..84d6fd02f 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -149,6 +149,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _where () = print_standard_library ()
 
   let _nopervasives = set nopervasives
+  let _dsource = set dump_source
   let _dparsetree = set dump_parsetree
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 98c73aad6..6ce6c31c9 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -2198,7 +2198,7 @@ let string_of_expression x =
   expression ppf x ;
   flush_str_formatter () ;;
 
-let toplevel_phrase ppf x =
+let top_phrase ppf x =
   pp_print_newline ppf () ;
   toplevel_phrase ppf x;
   fprintf ppf ";;" ;
diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
index ec89e3ad5..3a87faf4b 100644
--- a/parsing/pprintast.mli
+++ b/parsing/pprintast.mli
@@ -15,4 +15,4 @@ val signature: Format.formatter -> Parsetree.signature -> unit
 val expression: Format.formatter -> Parsetree.expression -> unit
 val pattern: Format.formatter -> Parsetree.pattern -> unit
 val core_type: Format.formatter -> Parsetree.core_type -> unit
-
+val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index eb9036bf6..b611094ca 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -90,6 +90,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _warn_help = option "-warn-help"
   let _where = option "-where"
   let _nopervasives = option "-nopervasives"
+  let _dsource = option "-dsource"
   let _dparsetree = option "-dparsetree"
   let _drawlambda = option "-drawlambda"
   let _dlambda = option "-dlambda"
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index 8eb08f440..57f7085de 100644
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -93,6 +93,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _where = option "-where"
 
   let _nopervasives = option "-nopervasives"
+  let _dsource = option "-dsource"
   let _dparsetree = option "-dparsetree"
   let _drawlambda = option "-drawlambda"
   let _dlambda = option "-dlambda"
diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index 5634b38af..f05414d55 100644
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -317,6 +317,7 @@ let use_file ppf name =
           List.iter
             (fun ph ->
               if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
+              if !Clflags.dump_source then Pprintast.top_phrase ppf ph;
               if not (execute_phrase !use_print_results ppf ph) then raise Exit)
             (!parse_use_file lb);
           true
@@ -430,6 +431,7 @@ let loop ppf =
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
       if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+      if !Clflags.dump_source then Pprintast.top_phrase ppf ph;
       ignore(execute_phrase true ppf phr)
     with
     | End_of_file -> exit 0
diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index f603981f6..4f5b29b72 100644
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -86,6 +86,7 @@ module Options = Main_args.Make_opttop_options (struct
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings
 
+  let _dsource = set dump_source
   let _dparsetree = set dump_parsetree
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index c528a5040..899ff307f 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -305,6 +305,7 @@ let use_file ppf name =
           List.iter
             (fun ph ->
               if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
+              if !Clflags.dump_source then Pprintast.top_phrase ppf ph;
               if not (execute_phrase !use_print_results ppf ph) then raise Exit)
             (!parse_use_file lb);
           true
@@ -420,6 +421,7 @@ let loop ppf =
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
       if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+      if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
       Env.reset_cache_toplevel ();
       ignore(execute_phrase true ppf phr)
     with
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index e173f53a1..09f9daee8 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -82,6 +82,7 @@ module Options = Main_args.Make_bytetop_options (struct
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings
   let _dparsetree = set dump_parsetree
+  let _dsource = set dump_source
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
   let _dinstr = set dump_instr
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 42ec3405b..30644c2ae 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -55,6 +55,7 @@ and dllpaths = ref ([] : string list)   (* -dllpath *)
 and make_package = ref false            (* -pack *)
 and for_package = ref (None: string option) (* -for-pack *)
 and error_size = ref 500                (* -error-size *)
+let dump_source = ref false             (* -dsource *)
 let dump_parsetree = ref false          (* -dparsetree *)
 and dump_rawlambda = ref false          (* -drawlambda *)
 and dump_lambda = ref false             (* -dlambda *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index 1560964b3..5164197b0 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -52,6 +52,7 @@ val dllpaths : string list ref
 val make_package : bool ref
 val for_package : string option ref
 val error_size : int ref
+val dump_source : bool ref
 val dump_parsetree : bool ref
 val dump_rawlambda : bool ref
 val dump_lambda : bool ref