mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 09:50:42 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Bob Duff 2009-04-17 14:11:04 +02:00 committed by Arnaud Charlet
parent e31f581411
commit b1b543d2c0
4 changed files with 214 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
gcc/ada/output.adb
View File

@ -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;

15
gcc/ada/output.ads
View File

@ -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;

81
gcc/ada/sem_ch6.adb
View File

@ -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;
--------------------------------------

74
gcc/ada/sem_ch7.adb
View File

@ -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;
-----------------------------------