OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2009-04-20  Thomas Quinot  <quinot@adacore.com>

	* sem_type.adb, ali.adb, erroutc.adb: Minor code reorganization
	(no behaviour change): Use Append instead of Increment_Last followed
	by assignment.

2009-04-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate the
	declarations of all primitives associated with dispatching asynchronous,
	conditional and timed selects when dispaching calls are forbidden and
	select statements are not allowed (such as in Ravenscar).
	(Predefined_Primitive_Bodies): Ditto for bodies.

	* exp_disp.ad (Make_DT): Do not create and populate the
	Select_Specific_Data of the dispatch table when dispatching calls are
	forbidden and select statements are not allowed (such as in Ravenscar).

2009-04-20  Robert Dewar  <dewar@adacore.com>

	* a-tifiio.adb: Minor reformatting

2009-04-20  Thomas Quinot  <quinot@adacore.com>

	* g-socthi-vms.adb, g-socket.adb, g-socket.ads: inet_aton(3), unlike
	other C library functions, report *failure* with a zero status, and
	success with a non-zero status.

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

	* sem.ads, sem.adb (Walk_Library_Items): New generic procedure.
	(Semantics): After analyzing each unit, Append it to the
	Comp_Unit_List, if appropriate.

	* gnat1drv.adb (Check_Library_Items): New procedure for debugging
	purposes.
	(Gnat1drv): Correct comment regarding Back_End_Mode.

2009-04-20  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat_ugn.texi: Add documentation for -fno-inline-small-functions.

From-SVN: r146389
This commit is contained in:
Arnaud Charlet 2009-04-20 12:04:20 +02:00
parent 7e728b0f0d
commit c09a557e3a
14 changed files with 362 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
gcc/ada/ChangeLog
View File

@ -1,3 +1,45 @@
2009-04-20 Thomas Quinot <quinot@adacore.com>
* sem_type.adb, ali.adb, erroutc.adb: Minor code reorganization
(no behaviour change): Use Append instead of Increment_Last followed
by assignment.
2009-04-20 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate the
declarations of all primitives associated with dispatching asynchronous,
conditional and timed selects when dispaching calls are forbidden and
select statements are not allowed (such as in Ravenscar).
(Predefined_Primitive_Bodies): Ditto for bodies.
* exp_disp.ad (Make_DT): Do not create and populate the
Select_Specific_Data of the dispatch table when dispatching calls are
forbidden and select statements are not allowed (such as in Ravenscar).
2009-04-20 Robert Dewar <dewar@adacore.com>
* a-tifiio.adb: Minor reformatting
2009-04-20 Thomas Quinot <quinot@adacore.com>
* g-socthi-vms.adb, g-socket.adb, g-socket.ads: inet_aton(3), unlike
other C library functions, report *failure* with a zero status, and
success with a non-zero status.
2009-04-20 Bob Duff <duff@adacore.com>
* sem.ads, sem.adb (Walk_Library_Items): New generic procedure.
(Semantics): After analyzing each unit, Append it to the
Comp_Unit_List, if appropriate.
* gnat1drv.adb (Check_Library_Items): New procedure for debugging
purposes.
(Gnat1drv): Correct comment regarding Back_End_Mode.
2009-04-20 Eric Botcazou <ebotcazou@adacore.com>
* gnat_ugn.texi: Add documentation for -fno-inline-small-functions.
2009-04-20 Thomas Quinot <quinot@adacore.com>
* s-taprop-irix.adb, s-taprop-tru64.adb, s-taprop-vms.adb,

63
gcc/ada/a-tifiio.adb
View File

@ -290,11 +290,11 @@ package body Ada.Text_IO.Fixed_IO is
and then Num'Small * 10.0**Scale < 10.0);
Exact : constant Boolean :=
Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
or Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)
or Num'Small >= 10.0**Max_Digits;
Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
or Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)
or Num'Small >= 10.0**Max_Digits;
-- True iff a numerator and denominator can be calculated such that
-- their ratio exactly represents the small of Num
-- their ratio exactly represents the small of Num.
procedure Put
(To : out String;
@ -315,10 +315,8 @@ package body Ada.Text_IO.Fixed_IO is
Width : Field := 0)
is
pragma Unsuppress (Range_Check);
begin
Aux.Get (File, Long_Long_Float (Item), Width);
exception
when Constraint_Error => raise Data_Error;
end Get;
@ -328,10 +326,8 @@ package body Ada.Text_IO.Fixed_IO is
Width : Field := 0)
is
pragma Unsuppress (Range_Check);
begin
Aux.Get (Current_In, Long_Long_Float (Item), Width);
exception
when Constraint_Error => raise Data_Error;
end Get;
@ -342,10 +338,8 @@ package body Ada.Text_IO.Fixed_IO is
Last : out Positive)
is
pragma Unsuppress (Range_Check);
begin
Aux.Gets (From, Long_Long_Float (Item), Last);
exception
when Constraint_Error => raise Data_Error;
end Get;
@ -387,11 +381,13 @@ package body Ada.Text_IO.Fixed_IO is
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
Fore : constant Integer := To'Length
- 1 -- Decimal point
- Field'Max (1, Aft) -- Decimal part
- Boolean'Pos (Exp /= 0) -- Exponent indicator
- Exp; -- Exponent
Fore : constant Integer :=
To'Length
- 1 -- Decimal point
- Field'Max (1, Aft) -- Decimal part
- Boolean'Pos (Exp /= 0) -- Exponent indicator
- Exp; -- Exponent
Last : Natural;
begin
@ -426,13 +422,13 @@ package body Ada.Text_IO.Fixed_IO is
-- Add C to the output string To, updating Last
procedure Put_Digit (X : Digit);
-- Add digit X to the output string (going from left to right),
-- updating Last and Pos, and inserting the sign, leading zeros
-- or a decimal point when necessary. After outputting the first
-- digit, Pos must not be changed outside Put_Digit anymore
-- Add digit X to the output string (going from left to right), updating
-- Last and Pos, and inserting the sign, leading zeros or a decimal
-- point when necessary. After outputting the first digit, Pos must not
-- be changed outside Put_Digit anymore.
procedure Put_Int64 (X : Int64; Scale : Integer);
-- Output the decimal number abs X * 10**Scale.
-- Output the decimal number abs X * 10**Scale
procedure Put_Scaled
(X, Y, Z : Int64;
@ -469,6 +465,7 @@ package body Ada.Text_IO.Fixed_IO is
begin
if Last = To'First - 1 then
if X /= 0 or Pos <= 0 then
-- Before outputting first digit, include leading space,
-- possible minus sign and, if the first digit is fractional,
-- decimal seperator and leading zeros.
@ -541,6 +538,7 @@ package body Ada.Text_IO.Fixed_IO is
-- If and only if more than one digit is output before the decimal
-- point, pos will be unequal to scale when outputting the first
-- digit.
pragma Assert (Pos = Scale or else Last = To'First - 1);
Pos := Scale;
@ -560,15 +558,15 @@ package body Ada.Text_IO.Fixed_IO is
pragma Assert (E >= -Max_Digits);
AA : constant Field := E + A;
N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1;
Q : array (0 .. N - 1) of Int64 := (others => 0);
-- Each element of Q has Max_Digits decimal digits, except
-- the last, which has eAA rem Max_Digits. Only Q (Q'First)
-- may have an absolute value equal to or larger than 10**Max_Digits.
-- Only the absolute value of the elements is not significant, not
-- the sign.
XX : Int64 := X;
YY : Int64 := Y;
Q : array (0 .. N - 1) of Int64 := (others => 0);
-- Each element of Q has Max_Digits decimal digits, except the
-- last, which has eAA rem Max_Digits. Only Q (Q'First) may have an
-- absolute value equal to or larger than 10**Max_Digits. Only the
-- absolute value of the elements is not significant, not the sign.
XX : Int64 := X;
YY : Int64 := Y;
begin
for J in Q'Range loop
@ -584,9 +582,9 @@ package body Ada.Text_IO.Fixed_IO is
if -E > A then
pragma Assert (N = 1);
Discard_Extra_Digits :
declare
Discard_Extra_Digits : declare
Factor : constant Int64 := 10**(-E - A);
begin
-- The scaling factors were such that the first division
-- produced more digits than requested. So divide away extra
@ -602,8 +600,9 @@ package body Ada.Text_IO.Fixed_IO is
end Discard_Extra_Digits;
end if;
-- At this point XX is a remainder and we need to determine if
-- the quotient in Q must be rounded away from zero.
-- At this point XX is a remainder and we need to determine if the
-- quotient in Q must be rounded away from zero.
-- As XX is less than the divisor, it is safe to take its absolute
-- without chance of overflow. The check to see if XX is at least
-- half the absolute value of the divisor must be done carefully to

12
gcc/ada/ali.adb
View File

@ -482,8 +482,7 @@ package body ALI is
end if;
loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Getc;
Add_Char_To_Name_Buffer (Getc);
exit when At_End_Of_Field and not Ignore_Spaces;
@ -936,8 +935,7 @@ package body ALI is
Name_Len := 0;
while not At_Eol loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Getc;
Add_Char_To_Name_Buffer (Getc);
end loop;
-- If -fstack-check, record that it occurred
@ -2000,8 +1998,7 @@ package body ALI is
if Nextc not in '0' .. '9' then
Name_Len := 0;
while not At_End_Of_Field loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Getc;
Add_Char_To_Name_Buffer (Getc);
end loop;
-- Set the subunit name. Note that we use Name_Find rather
@ -2022,8 +2019,7 @@ package body ALI is
Name_Len := 0;
while not At_End_Of_Field loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Getc;
Add_Char_To_Name_Buffer (Getc);
end loop;
Sdep.Table (Sdep.Last).Rfile := Name_Enter;

3
gcc/ada/erroutc.adb
View File

@ -926,8 +926,7 @@ package body Erroutc is
Name_Len := 0;
while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Text (J);
Add_Char_To_Name_Buffer (Text (J));
J := J + 1;
end loop;

17
gcc/ada/exp_ch3.adb
View File

@ -7818,12 +7818,13 @@ package body Exp_Ch3 is
-- Disp_Timed_Select
-- These operations cannot be implemented on VM targets, so we simply
-- disable their generation in this case. We also disable generation
-- of these bodies if No_Dispatching_Calls is active.
-- disable their generation in this case. Disable the generation of
-- these bodies if No_Dispatching_Calls or Ravenscar is active.
if Ada_Version >= Ada_05
and then VM_Target = No_VM
and then RTE_Available (RE_Select_Specific_Data)
and then not Restriction_Active (No_Dispatching_Calls)
and then not Restriction_Active (No_Select_Statements)
then
-- These primitives are defined abstract in interface types
@ -8311,19 +8312,19 @@ package body Exp_Ch3 is
-- The interface versions will have null bodies
-- These operations cannot be implemented on VM targets, so we simply
-- disable their generation in this case. We also disable generation
-- of these bodies if No_Dispatching_Calls is active.
-- disable their generation in this case. Disable the generation of
-- these bodies if No_Dispatching_Calls or Ravenscar is active.
if Ada_Version >= Ada_05
and then VM_Target = No_VM
and then not Restriction_Active (No_Dispatching_Calls)
and then not Is_Interface (Tag_Typ)
and then
((Is_Interface (Etype (Tag_Typ))
and then Is_Limited_Record (Etype (Tag_Typ)))
or else (Is_Concurrent_Record_Type (Tag_Typ)
and then Has_Interfaces (Tag_Typ)))
and then RTE_Available (RE_Select_Specific_Data)
and then Has_Interfaces (Tag_Typ)))
and then not Restriction_Active (No_Dispatching_Calls)
and then not Restriction_Active (No_Select_Statements)
then
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));

10
gcc/ada/exp_disp.adb
View File

@ -4749,6 +4749,7 @@ package body Exp_Disp is
and then not Is_Abstract_Type (Typ)
and then not Is_Controlled (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
and then not Restriction_Active (No_Select_Statements)
then
Append_To (Result,
Make_Object_Declaration (Loc,
@ -5545,13 +5546,16 @@ package body Exp_Disp is
Append_List_To (Result, Elab_Code);
end if;
-- Populate the two auxiliary tables used for dispatching
-- asynchronous, conditional and timed selects for synchronized
-- types that implement a limited interface.
-- Populate the two auxiliary tables used for dispatching asynchronous,
-- conditional and timed selects for synchronized types that implement
-- a limited interface. Skip this step in Ravenscar profile or when
-- general dispatching is forbidden.
if Ada_Version >= Ada_05
and then Is_Concurrent_Record_Type (Typ)
and then Has_Interfaces (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
and then not Restriction_Active (No_Select_Statements)
then
Append_List_To (Result,
Make_Select_Specific_Data_Table (Typ));

6
gcc/ada/g-socket.adb
View File

@ -179,6 +179,10 @@ package body GNAT.Sockets is
-- Reconstruct a Duration value from a Timeval record (seconds and
-- microseconds).
procedure Raise_Socket_Error (Error : Integer);
-- Raise Socket_Error with an exception message describing the error code
-- from errno.
procedure Raise_Host_Error (H_Error : Integer);
-- Raise Host_Error exception with message describing error code (note
-- hstrerror seems to be obsolete) from h_errno.
@ -1288,7 +1292,7 @@ package body GNAT.Sockets is
Res := Inet_Aton (To_Chars_Ptr (Img'Unchecked_Access), Addr'Address);
if Res = Failure then
if Res = 0 then
Raise_Socket_Error (SOSC.EINVAL);
end if;

4
gcc/ada/g-socket.ads
View File

@ -1108,10 +1108,6 @@ package GNAT.Sockets is
private
procedure Raise_Socket_Error (Error : Integer);
-- Raise Socket_Error with an exception message describing the error code
-- from errno.
type Socket_Type is new Integer;
No_Socket : constant Socket_Type := -1;

11
gcc/ada/g-socthi-vms.adb
View File

@ -358,7 +358,8 @@ package body GNAT.Sockets.Thin is
---------------
-- VMS does not support inet_aton(3), so emulate it here in terms of
-- inet_addr(3).
-- inet_addr(3). Note: unlike other C functions, inet_aton reports
-- failure with a 0 return, and success with a non-zero return.
function Inet_Aton
(Cp : C.Strings.chars_ptr;
@ -373,7 +374,7 @@ package body GNAT.Sockets.Thin is
pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR");
begin
if Cp = Null_Ptr or else Inp = Null_Address then
Raise_Socket_Error (SOSC.EINVAL);
return 0;
end if;
-- Special case for the all-ones broadcast address: this address has the
@ -382,16 +383,16 @@ package body GNAT.Sockets.Thin is
if String'(Value (Cp)) = "255.255.255.255" then
Conv.To_Pointer (Inp).all := -1;
return 0;
return 1;
end if;
Res := C_Inet_Addr (Cp);
if Res = -1 then
return Res;
return 0;
end if;
Conv.To_Pointer (Inp).all := Res;
return 0;
return 1;
end Inet_Aton;
----------------

34
gcc/ada/gnat1drv.adb
View File

@ -90,6 +90,9 @@ procedure Gnat1drv is
-- Called when we are not generating code, to check if -gnatR was requested
-- and if so, explain that we will not be honoring the request.
procedure Check_Library_Items;
-- For debugging -- checks the behavior of Walk_Library_Items
--------------------
-- Check_Bad_Body --
--------------------
@ -251,6 +254,29 @@ procedure Gnat1drv is
end if;
end Check_Rep_Info;
-------------------------
-- Check_Library_Items --
-------------------------
procedure Check_Library_Items is
-- Walk_Library_Items has plenty of assertions, so all we need to do is
-- call it.
procedure Action (Item : Node_Id);
-- Action passed to Walk_Library_Items to do nothing
procedure Action (Item : Node_Id) is
begin
null;
end Action;
procedure Walk is new Sem.Walk_Library_Items (Action);
-- Start of processing for Check_Library_Items
begin
Walk;
end Check_Library_Items;
-- Start of processing for Gnat1drv
begin
@ -578,9 +604,9 @@ begin
Back_End_Mode := Skip;
end if;
-- At this stage Call_Back_End is set to indicate if the backend should
-- be called to generate code. If it is not set, then code generation
-- has been turned off, even though code was requested by the original
-- At this stage Back_End_Mode is set to indicate if the backend should
-- be called to generate code. If it is Skip, then code generation has
-- been turned off, even though code was requested by the original
-- command. This is not an error from the user point of view, but it is
-- an error from the point of view of the gcc driver, so we must exit
-- with an error status.
@ -706,6 +732,8 @@ begin
Namet.Lock;
Stringt.Lock;
Check_Library_Items; -- For debugging
-- Here we call the back end to generate the output code
Generating_Code := True;

7
gcc/ada/gnat_ugn.texi
View File

@ -3802,9 +3802,14 @@ effect if this switch is present.
@item -fno-inline-functions
@cindex @option{-fno-inline-functions} (@command{gcc})
Suppresses automatic inlining of small subprograms, which is enabled
Suppresses automatic inlining of simple subprograms, which is enabled
if @option{-O3} is used.
@item -fno-inline-small-functions
@cindex @option{-fno-inline-small-functions} (@command{gcc})
Suppresses automatic inlining of small subprograms, which is enabled
if @option{-O2} is used.
@item -fno-inline-functions-called-once
@cindex @option{-fno-inline-functions-called-once} (@command{gcc})
Suppresses inlining of subprograms local to the unit and called once

202
gcc/ada/sem.adb
View File

@ -27,6 +27,7 @@
with Atree; use Atree;
with Debug; use Debug;
with Debug_A; use Debug_A;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Fname; use Fname;
@ -34,6 +35,7 @@ with HLO; use HLO;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Nlists; use Nlists;
with Output; use Output;
with Sem_Attr; use Sem_Attr;
with Sem_Ch2; use Sem_Ch2;
with Sem_Ch3; use Sem_Ch3;
@ -52,6 +54,7 @@ with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Uintp; use Uintp;
with Uname; use Uname;
with Unchecked_Deallocation;
@ -65,6 +68,16 @@ package body Sem is
-- generic context, it is empty. At the moment, it is only used
-- for avoiding freezing of external references in generics.
Comp_Unit_List : Elist_Id := No_Elist;
-- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
-- processed by Semantics, in an appropriate order. Initialized to
-- No_Elist, because it's too early to call New_Elmt_List; we will set it
-- to New_Elmt_List on first use.
Ignore_Comp_Units : Boolean := False;
-- If True, we suppress appending compilation units onto the
-- Comp_Unit_List.
-------------
-- Analyze --
-------------
@ -1384,7 +1397,44 @@ package body Sem is
New_Nodes_OK := 0;
end if;
Do_Analyze;
-- Do analysis, and then append the compilation unit onto the
-- Comp_Unit_List, if appropriate. This is done after analysis, so if
-- this unit depends on some others, they have already been
-- appended. We ignore bodies, except for the main unit itself, and
-- everything those bodies depend upon.
if Ignore_Comp_Units then
Do_Analyze;
pragma Assert (Ignore_Comp_Units); -- still
elsif Nkind (Unit (Comp_Unit)) in N_Proper_Body
and then not In_Extended_Main_Source_Unit (Comp_Unit)
then
Ignore_Comp_Units := True;
Do_Analyze;
pragma Assert (Ignore_Comp_Units);
Ignore_Comp_Units := False;
else
Do_Analyze;
-- pragma Assert (not Ignore_Comp_Units);
-- The above assertion is *almost* true. It fails only when a
-- subunit with's its parent procedure body, which has no explicit
-- spec.
if No (Comp_Unit_List) then -- Initialize if first time
Comp_Unit_List := New_Elmt_List;
end if;
if not Ignore_Comp_Units then -- See above commented-out Assert
Append_Elmt (Comp_Unit, Comp_Unit_List);
end if;
-- Ignore all units after main unit
if Comp_Unit = Cunit (Main_Unit) then
Ignore_Comp_Units := True;
end if;
end if;
end if;
-- Save indication of dynamic elaboration checks for ALI file
@ -1405,4 +1455,154 @@ package body Sem is
Restore_Opt_Config_Switches (Save_Config_Switches);
Expander_Mode_Restore;
end Semantics;
------------------------
-- Walk_Library_Items --
------------------------
procedure Walk_Library_Items is
Enable_Output : constant Boolean := False;
-- Set to True to print out the items as we go (for debugging)
procedure Do_Action (CU : Node_Id; Item : Node_Id);
-- Calls Action, with some validity checks
---------------
-- Do_Action --
---------------
procedure Do_Action (CU : Node_Id; Item : Node_Id) is
begin
-- This calls Action at the end. All the preceding code is just
-- assertions and debugging output.
case Nkind (Item) is
when N_Generic_Subprogram_Declaration |
N_Generic_Package_Declaration |
N_Package_Declaration |
N_Subprogram_Declaration |
N_Subprogram_Renaming_Declaration |
N_Package_Renaming_Declaration |
N_Generic_Function_Renaming_Declaration |
N_Generic_Package_Renaming_Declaration |
N_Generic_Procedure_Renaming_Declaration =>
null; -- Specs are OK
when N_Package_Body | N_Subprogram_Body =>
-- A body must be the main unit
pragma Assert (CU = Cunit (Main_Unit));
null;
-- All other cases cannot happen
when N_Function_Instantiation |
N_Procedure_Instantiation |
N_Package_Instantiation =>
pragma Assert (False, "instantiation");
null;
when N_Subunit =>
pragma Assert (False, "subunit");
null;
when others =>
pragma Assert (False);
null;
end case;
if Present (CU) then
pragma Assert (Item /= Stand.Standard_Package_Node);
if Enable_Output then
Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (CU)));
Write_Str (", Unit_Number = ");
Write_Int (Int (Get_Cunit_Unit_Number (CU)));
Write_Str (", ");
Write_Str (Node_Kind'Image (Nkind (Item)));
if Item /= Original_Node (Item) then
Write_Str (", orig = ");
Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
end if;
Write_Eol;
end if;
else -- Must be Standard
pragma Assert (Item = Stand.Standard_Package_Node);
if Enable_Output then
Write_Line ("Standard");
end if;
end if;
Action (Item);
end Do_Action;
Cur : Elmt_Id := First_Elmt (Comp_Unit_List);
-- Start of processing for Walk_Library_Items
begin
if Enable_Output then
Write_Line ("Walk_Library_Items:");
Indent;
end if;
-- Do Standard first, then walk the Comp_Unit_List
Do_Action (Empty, Standard_Package_Node);
while Present (Cur) loop
declare
CU : constant Node_Id := Node (Cur);
N : constant Node_Id := Unit (CU);
begin
pragma Assert (Nkind (CU) = N_Compilation_Unit);
case Nkind (N) is
-- If it's a body, then ignore it, unless it's an instance (in
-- which case we do the spec), or it's the main unit (in which
-- case we do it). Note that it could be both.
when N_Package_Body | N_Subprogram_Body =>
declare
Entity : Node_Id := N;
begin
if Nkind (N) = N_Subprogram_Body then
Entity := Specification (Entity);
end if;
Entity := Defining_Unit_Name (Entity);
if Nkind (Entity) not in N_Entity then
-- Must be N_Defining_Program_Unit_Name
Entity := Defining_Identifier (Entity);
end if;
if Is_Generic_Instance (Entity) then
Do_Action (CU, Unit (Library_Unit (CU)));
end if;
end;
if CU = Cunit (Main_Unit) then
-- Must come last
pragma Assert (No (Next_Elmt (Cur)));
Do_Action (CU, N);
end if;
-- It's a spec, so just do it
when others =>
Do_Action (CU, N);
end case;
end;
Next_Elmt (Cur);
end loop;
if Enable_Output then
Outdent;
Write_Line ("end Walk_Library_Items.");
end if;
end Walk_Library_Items;
end Sem;

16
gcc/ada/sem.ads
View File

@ -640,4 +640,20 @@ package Sem is
-- is False, then the status of the check can be determined simply by
-- examining Scope_Checks (C), so this routine is not called in that case.
generic
with procedure Action (Item : Node_Id);
procedure Walk_Library_Items;
-- Primarily for use by SofCheck Inspector. Must be called after semantic
-- analysis (and expansion) are complete. Walks each relevant library item,
-- calling Action for each, in an order such that one will not run across
-- forward references. Each Item passed to Action is the declaration or
-- body of a library unit, including generics and renamings. The first item
-- is the N_Package_Declaration node for package Standard. Bodies are not
-- included, except for the main unit itself, which always comes last.
--
-- Item is never a subunit.
--
-- Item is never an instantiation. Instead, the instance declaration is
-- passed, and (if the instantiation is the main unit), the instance body.
end Sem;

9
gcc/ada/sem_type.adb
View File

@ -312,8 +312,7 @@ package body Sem_Type is
end loop;
All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
All_Interp.Append (No_Interp);
end Add_Entry;
----------------------------
@ -634,8 +633,7 @@ package body Sem_Type is
then
All_Interp.Table (All_Interp.Last) :=
(H, Etype (H), Empty);
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
All_Interp.Append (No_Interp);
goto Next_Homograph;
elsif Scope (H) /= Standard_Standard then
@ -2625,8 +2623,7 @@ package body Sem_Type is
Map_Ptr : Int;
begin
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
All_Interp.Append (No_Interp);
Map_Ptr := Headers (Hash (N));