output.ads (Indent,Outdent): New procedures for indenting the output.

2009-04-17  Bob Duff  <duff@adacore.com>

	* output.ads (Indent,Outdent): New procedures for indenting the output.
	(Write_Char): Correct comment -- LF _is_ allowed.

	* output.adb (Indent,Outdent): New procedures for indenting the output.
	Keep track of the indentation level, and make sure it doesn't get too
	high.
	(Flush_Buffer): Insert spaces at the beginning of each line, if
	indentation level is nonzero.
	(Save_Output_Buffer,Restore_Output_Buffer): Save and restore the current
	indentation level.
	(Set_Standard_Error,Set_Standard_Output): Remove superfluous
	"Next_Col := 1;".  Flush_Buffer does that.

	* sem_ch6.adb, sem_ch7.adb (Debug_Flag_C): Reorganize the output
	controlled by the -gnatdc switch. It now occurs on entry/exit to the
	relevant analysis routines, and calls Indent/Outdent to make the
	indentation reflect the nesting level.  Add "helper" routines, since
	otherwise lots of "return;" statements would skip the debugging output.

From-SVN: r146253

gcc/ada/output.adb

@@ -40,6 +40,17 @@ package body Output is
    --  Record argument to last call to Set_Special_Output. If this is
    --  non-null, then we are in special output mode.
 
+   Indentation_Amount : constant Positive := 3;
+   --  Number of spaces to output for each indentation level
+
+   Indentation_Limit : constant Positive := 40;
+   --  Indentation beyond this number of spaces wraps around
+   pragma Assert (Indentation_Limit < Buffer_Max / 2);
+   --  Make sure this is substantially shorter than the line length
+
+   Cur_Indentation : Natural := 0;
+   --  Number of spaces to indent each line
+
    -----------------------
    -- Local_Subprograms --
    -----------------------
@@ -70,36 +81,73 @@ package body Output is
    ------------------
 
    procedure Flush_Buffer is
-      Len : constant Natural := Next_Col - 1;
+      Write_Error : exception;
+      --  Raised if Write fails
 
-   begin
-      if Len /= 0 then
+      ------------------
+      -- Write_Buffer --
+      ------------------
 
+      procedure Write_Buffer (Buf : String);
+      --  Write out Buf, either using Special_Output_Proc, or the normal way
+      --  using Write. Raise Write_Error if Write fails (presumably due to disk
+      --  full). Write_Error is not used in the case of Special_Output_Proc.
+
+      procedure Write_Buffer (Buf : String) is
+      begin
          --  If Special_Output_Proc has been set, then use it
 
          if Special_Output_Proc /= null then
-            Special_Output_Proc.all (Buffer (1 .. Len));
+            Special_Output_Proc.all (Buf);
 
          --  If output is not set, then output to either standard output
          --  or standard error.
 
-         elsif Len /= Write (Current_FD, Buffer'Address, Len) then
+         elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
+            raise Write_Error;
 
-            --  If there are errors with standard error, just quit
+         end if;
+      end Write_Buffer;
 
-            if Current_FD = Standerr then
-               OS_Exit (2);
+      Len : constant Natural := Next_Col - 1;
 
-            --  Otherwise, set the output to standard error before
-            --  reporting a failure and quitting.
+   begin
+      if Len /= 0 then
+         begin
+            --  If there's no indentation, or if the line is too long with
+            --  indentation, just write the buffer.
+
+            if Cur_Indentation = 0
+              or else Cur_Indentation + Len > Buffer_Max
+            then
+               Write_Buffer (Buffer (1 .. Len));
+
+            --  Otherwise, construct a new buffer with preceding spaces, and
+            --  write that.
 
             else
-               Current_FD := Standerr;
-               Next_Col := 1;
-               Write_Line ("fatal error: disk full");
-               OS_Exit (2);
+               declare
+                  Indented_Buffer : constant String
+                    := (1 .. Cur_Indentation => ' ') & Buffer (1 .. Len);
+               begin
+                  Write_Buffer (Indented_Buffer);
+               end;
             end if;
-         end if;
+
+         exception
+            when Write_Error =>
+               --  If there are errors with standard error, just quit.
+               --  Otherwise, set the output to standard error before reporting
+               --  a failure and quitting.
+
+               if Current_FD /= Standerr then
+                  Current_FD := Standerr;
+                  Next_Col := 1;
+                  Write_Line ("fatal error: disk full");
+               end if;
+
+               OS_Exit (2);
+         end;
 
          --  Buffer is now empty
 
@@ -107,6 +155,27 @@ package body Output is
       end if;
    end Flush_Buffer;
 
+   ------------
+   -- Indent --
+   ------------
+
+   procedure Indent is
+   begin
+      Cur_Indentation :=
+        (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
+      --  The "mod" is to wrap around in case there's too much indentation.
+   end Indent;
+
+   -------------
+   -- Outdent --
+   -------------
+
+   procedure Outdent is
+   begin
+      Cur_Indentation :=
+        (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
+   end Outdent;
+
    ---------------------------
    -- Restore_Output_Buffer --
    ---------------------------
@@ -114,6 +183,7 @@ package body Output is
    procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
    begin
       Next_Col := S.Next_Col;
+      Cur_Indentation := S.Cur_Indentation;
       Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
    end Restore_Output_Buffer;
 
@@ -126,7 +196,9 @@ package body Output is
    begin
       S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
       S.Next_Col := Next_Col;
+      S.Cur_Indentation := Cur_Indentation;
       Next_Col := 1;
+      Cur_Indentation := 0;
       return S;
    end Save_Output_Buffer;
 
@@ -147,7 +219,6 @@ package body Output is
    begin
       if Special_Output_Proc = null then
          Flush_Buffer;
-         Next_Col := 1;
       end if;
 
       Current_FD := Standerr;
@@ -161,7 +232,6 @@ package body Output is
    begin
       if Special_Output_Proc = null then
          Flush_Buffer;
-         Next_Col := 1;
       end if;
 
       Current_FD := Standout;

gcc/ada/output.ads

@@ -81,9 +81,17 @@ package Output is
    --  has been cancelled. Output to standard output is the default mode
    --  before any call to either of the Set procedures.
 
+   procedure Indent;
+   --  Increases the current indentation level. Whenever a line is written
+   --  (triggered by Eol), an appropriate amount of whitespace is added to the
+   --  beginning of the line, wrapping around if it gets to long.
+
+   procedure Outdent;
+   --  Decreases the current indentation level.
+
    procedure Write_Char (C : Character);
-   --  Write one character to the standard output file. Note that the
-   --  character should not be LF or CR (use Write_Eol for end of line)
+   --  Write one character to the standard output file. If the character is LF,
+   --  this is equivalent to Write_Eol.
 
    procedure Write_Erase_Char (C : Character);
    --  If last character in buffer matches C, erase it, otherwise no effect
@@ -177,7 +185,7 @@ private
    --  subprograms defined in this package, and cannot be directly modified or
    --  accessed by a client.
 
-   Buffer : String (1 .. Buffer_Max + 1);
+   Buffer : String (1 .. Buffer_Max + 1) := (others => '*');
    for Buffer'Alignment use 4;
    --  Buffer used to build output line. We do line buffering because it
    --  is needed for the support of the debug-generated-code option (-gnatD).
@@ -194,6 +202,7 @@ private
    type Saved_Output_Buffer is record
       Buffer   : String (1 .. Buffer_Max + 1);
       Next_Col : Positive;
+      Cur_Indentation : Natural;
    end record;
 
 end Output;

gcc/ada/sem_ch6.adb

@@ -107,6 +107,9 @@ package body Sem_Ch6 is
    --  specification, in a context where the formals are visible and hide
    --  outer homographs.
 
+   procedure Analyze_Subprogram_Body_Helper (N : Node_Id);
+   --  Does all the real work of Analyze_Subprogram_Body
+
    procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
    --  Analyze a generic subprogram body. N is the body to be analyzed, and
    --  Gen_Id is the defining entity Id for the corresponding spec.
@@ -1342,12 +1345,48 @@ package body Sem_Ch6 is
    -- Analyze_Subprogram_Body --
    -----------------------------
 
+   procedure Analyze_Subprogram_Body (N : Node_Id) is
+      Loc       : constant Source_Ptr := Sloc (N);
+      Body_Spec : constant Node_Id    := Specification (N);
+      Body_Id   : constant Entity_Id  := Defining_Entity (Body_Spec);
+
+   begin
+      if Debug_Flag_C then
+         Write_Str ("==> subprogram body ");
+         Write_Name (Chars (Body_Id));
+         Write_Str (" from ");
+         Write_Location (Loc);
+         Write_Eol;
+         Indent;
+      end if;
+
+      Trace_Scope (N, Body_Id, " Analyze subprogram: ");
+
+      --  The real work is split out into the helper, so it can do "return;"
+      --  without skipping the debug output:
+
+      Analyze_Subprogram_Body_Helper (N);
+
+      if Debug_Flag_C then
+         Outdent;
+         Write_Str ("<== subprogram body ");
+         Write_Name (Chars (Body_Id));
+         Write_Str (" from ");
+         Write_Location (Loc);
+         Write_Eol;
+      end if;
+   end Analyze_Subprogram_Body;
+
+   ------------------------------------
+   -- Analyze_Subprogram_Body_Helper --
+   ------------------------------------
+
    --  This procedure is called for regular subprogram bodies, generic bodies,
    --  and for subprogram stubs of both kinds. In the case of stubs, only the
    --  specification matters, and is used to create a proper declaration for
    --  the subprogram, or to perform conformance checks.
 
-   procedure Analyze_Subprogram_Body (N : Node_Id) is
+   procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
       Loc          : constant Source_Ptr := Sloc (N);
       Body_Deleted : constant Boolean    := False;
       Body_Spec    : constant Node_Id    := Specification (N);
@@ -1785,19 +1824,9 @@ package body Sem_Ch6 is
          end if;
       end Verify_Overriding_Indicator;
 
-   --  Start of processing for Analyze_Subprogram_Body
+   --  Start of processing for Analyze_Subprogram_Body_Helper
 
    begin
-      if Debug_Flag_C then
-         Write_Str ("====  Compiling subprogram body ");
-         Write_Name (Chars (Body_Id));
-         Write_Str (" from ");
-         Write_Location (Loc);
-         Write_Eol;
-      end if;
-
-      Trace_Scope (N, Body_Id, " Analyze subprogram: ");
-
       --  Generic subprograms are handled separately. They always have a
       --  generic specification. Determine whether current scope has a
       --  previous declaration.
@@ -2558,7 +2587,7 @@ package body Sem_Ch6 is
             Check_References (Body_Id);
          end if;
       end;
-   end Analyze_Subprogram_Body;
+   end Analyze_Subprogram_Body_Helper;
 
    ------------------------------------
    -- Analyze_Subprogram_Declaration --
@@ -2572,6 +2601,15 @@ package body Sem_Ch6 is
    --  Start of processing for Analyze_Subprogram_Declaration
 
    begin
+      if Debug_Flag_C then
+         Write_Str ("==> subprogram spec ");
+         Write_Name (Chars (Designator));
+         Write_Str (" from ");
+         Write_Location (Sloc (N));
+         Write_Eol;
+         Indent;
+      end if;
+
       Generate_Definition (Designator);
 
       --  Check for RCI unit subprogram declarations for illegal inlined
@@ -2585,14 +2623,6 @@ package body Sem_Ch6 is
          Defining_Entity (N),
          " Analyze subprogram spec: ");
 
-      if Debug_Flag_C then
-         Write_Str ("====  Compiling subprogram spec ");
-         Write_Name (Chars (Designator));
-         Write_Str (" from ");
-         Write_Location (Sloc (N));
-         Write_Eol;
-      end if;
-
       New_Overloaded_Entity (Designator);
       Check_Delayed_Subprogram (Designator);
 
@@ -2712,6 +2742,15 @@ package body Sem_Ch6 is
               ("protected operation cannot be a null procedure", N);
          end if;
       end if;
+
+      if Debug_Flag_C then
+         Outdent;
+         Write_Str ("<== subprogram spec ");
+         Write_Name (Chars (Designator));
+         Write_Str (" from ");
+         Write_Location (Sloc (N));
+         Write_Eol;
+      end if;
    end Analyze_Subprogram_Declaration;
 
    --------------------------------------

gcc/ada/sem_ch7.adb

@@ -90,6 +90,9 @@ package body Sem_Ch7 is
    -- Local Subprograms --
    -----------------------
 
+   procedure Analyze_Package_Body_Helper (N : Node_Id);
+   --  Does all the real work of Analyze_Package_Body
+
    procedure Check_Anonymous_Access_Types
      (Spec_Id : Entity_Id;
       P_Body  : Node_Id);
@@ -135,7 +138,38 @@ package body Sem_Ch7 is
    --------------------------
 
    procedure Analyze_Package_Body (N : Node_Id) is
-      Loc              : constant Source_Ptr := Sloc (N);
+      Loc : constant Source_Ptr := Sloc (N);
+
+   begin
+      if Debug_Flag_C then
+         Write_Str ("==> package body ");
+         Write_Name (Chars (Defining_Entity (N)));
+         Write_Str (" from ");
+         Write_Location (Loc);
+         Write_Eol;
+         Indent;
+      end if;
+
+      --  The real work is split out into the helper, so it can do "return;"
+      --  without skipping the debug output.
+
+      Analyze_Package_Body_Helper (N);
+
+      if Debug_Flag_C then
+         Outdent;
+         Write_Str ("<== package body ");
+         Write_Name (Chars (Defining_Entity (N)));
+         Write_Str (" from ");
+         Write_Location (Loc);
+         Write_Eol;
+      end if;
+   end Analyze_Package_Body;
+
+   ---------------------------------
+   -- Analyze_Package_Body_Helper --
+   ---------------------------------
+
+   procedure Analyze_Package_Body_Helper (N : Node_Id) is
       HSS              : Node_Id;
       Body_Id          : Entity_Id;
       Spec_Id          : Entity_Id;
@@ -172,7 +206,7 @@ package body Sem_Ch7 is
          end loop;
       end Install_Composite_Operations;
 
-   --  Start of processing for Analyze_Package_Body
+   --  Start of processing for Analyze_Package_Body_Helper
 
    begin
       --  Find corresponding package specification, and establish the current
@@ -182,14 +216,6 @@ package body Sem_Ch7 is
       --  the later is never used for name resolution. In this fashion there
       --  is only one visible entity that denotes the package.
 
-      if Debug_Flag_C then
-         Write_Str ("====  Compiling package body ");
-         Write_Name (Chars (Defining_Entity (N)));
-         Write_Str (" from ");
-         Write_Location (Loc);
-         Write_Eol;
-      end if;
-
       --  Set Body_Id. Note that this Will be reset to point to the generic
       --  copy later on in the generic case.
 
@@ -634,7 +660,7 @@ package body Sem_Ch7 is
             Qualify_Entity_Names (N);
          end if;
       end if;
-   end Analyze_Package_Body;
+   end Analyze_Package_Body_Helper;
 
    ---------------------------------
    -- Analyze_Package_Declaration --
@@ -664,6 +690,15 @@ package body Sem_Ch7 is
          return;
       end if;
 
+      if Debug_Flag_C then
+         Write_Str ("==> package spec ");
+         Write_Name (Chars (Id));
+         Write_Str (" from ");
+         Write_Location (Sloc (N));
+         Write_Eol;
+         Indent;
+      end if;
+
       Generate_Definition (Id);
       Enter_Name (Id);
       Set_Ekind (Id, E_Package);
@@ -676,14 +711,6 @@ package body Sem_Ch7 is
 
       Set_Categorization_From_Pragmas (N);
 
-      if Debug_Flag_C then
-         Write_Str ("====  Compiling package spec ");
-         Write_Name (Chars (Id));
-         Write_Str (" from ");
-         Write_Location (Sloc (N));
-         Write_Eol;
-      end if;
-
       Analyze (Specification (N));
       Validate_Categorization_Dependency (N, Id);
 
@@ -725,6 +752,15 @@ package body Sem_Ch7 is
       if Comp_Unit then
          Validate_RT_RAT_Component (N);
       end if;
+
+      if Debug_Flag_C then
+         Outdent;
+         Write_Str ("<== package spec ");
+         Write_Name (Chars (Id));
+         Write_Str (" from ");
+         Write_Location (Sloc (N));
+         Write_Eol;
+      end if;
    end Analyze_Package_Declaration;
 
    -----------------------------------