-- 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 --
-----------------------
------------------
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
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 --
---------------------------
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;
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;
begin
if Special_Output_Proc = null then
Flush_Buffer;
- Next_Col := 1;
end if;
Current_FD := Standerr;
begin
if Special_Output_Proc = null then
Flush_Buffer;
- Next_Col := 1;
end if;
Current_FD := Standout;
-- 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
-- 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).
type Saved_Output_Buffer is record
Buffer : String (1 .. Buffer_Max + 1);
Next_Col : Positive;
+ Cur_Indentation : Natural;
end record;
end Output;
-- 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.
-- 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);
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.
Check_References (Body_Id);
end if;
end;
- end Analyze_Subprogram_Body;
+ end Analyze_Subprogram_Body_Helper;
------------------------------------
-- Analyze_Subprogram_Declaration --
-- 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
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);
("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;
--------------------------------------
-- 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);
--------------------------
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;
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
-- 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.
Qualify_Entity_Names (N);
end if;
end if;
- end Analyze_Package_Body;
+ end Analyze_Package_Body_Helper;
---------------------------------
-- Analyze_Package_Declaration --
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);
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);
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;
-----------------------------------
projects / thirdparty / gcc.git / commitdiff
