diff options
| -rw-r--r-- | gcc/ada/output.adb | 104 | ||||
| -rw-r--r-- | gcc/ada/output.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 81 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 74 |
4 files changed, 214 insertions, 60 deletions
diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index b33a74d..5208daf 100644 --- a/gcc/ada/output.adb +++ b/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; diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 559112c..2bb38fc 100644 --- a/gcc/ada/output.ads +++ b/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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 080b3e0..a9dd4af 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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; -------------------------------------- diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index ba005a3..e344a58 100644 --- a/gcc/ada/sem_ch7.adb +++ b/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; ----------------------------------- |