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

[multiple changes] 

2017-10-09  Justin Squirek  <squirek@adacore.com>

	* sem_ch3.adb: Rename Uses_Unseen_Priv into
	Contains_Lib_Incomplete_Type.

2017-10-09  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_aggr.adb, sem_spark.adb, adabkend.adb, exp_ch5.adb, frontend.adb,
	sem_ch12.adb, fmap.adb, exp_ch6.adb, exp_spark.adb, lib-load.adb,
	exp_ch9.adb, osint.adb, exp_disp.adb, sem_ch8.adb, sem_ch8.ads,
	prepcomp.adb, gnat1drv.adb, atree.adb, sinput-l.adb, targparm.adb,
	sem_ch10.adb, par-ch8.adb: Minor reformatting.

From-SVN: r253566
This commit is contained in:
Pierre-Marie de Rodat 2017-10-09 20:28:22 +00:00
parent f192ca5eea
commit 7f5e671bce
24 changed files with 299 additions and 240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/ada/ChangeLog
View File

@ -1,3 +1,16 @@
2017-10-09 Justin Squirek <squirek@adacore.com>
* sem_ch3.adb: Rename Uses_Unseen_Priv into
Contains_Lib_Incomplete_Type.
2017-10-09 Hristian Kirtchev <kirtchev@adacore.com>
* sem_aggr.adb, sem_spark.adb, adabkend.adb, exp_ch5.adb, frontend.adb,
sem_ch12.adb, fmap.adb, exp_ch6.adb, exp_spark.adb, lib-load.adb,
exp_ch9.adb, osint.adb, exp_disp.adb, sem_ch8.adb, sem_ch8.ads,
prepcomp.adb, gnat1drv.adb, atree.adb, sinput-l.adb, targparm.adb,
sem_ch10.adb, par-ch8.adb: Minor reformatting.
2017-10-09 Hristian Kirtchev <kirtchev@adacore.com>
* sem_elab.adb (Is_Suitable_Access): This scenario is now only relevant

4
gcc/ada/adabkend.adb
View File

@ -59,8 +59,8 @@ package body Adabkend is
-- The front end leaves the Current_Error_Node at a location that is
-- meaningless and confusing when emitting bug boxes from the back end.
-- By resetting it here we default to "No source file position
-- information available" message on back end crashes.
-- Reset the global variable in order to emit "No source file position
-- information available" messages on back end crashes.
Current_Error_Node := Empty;

11
gcc/ada/atree.adb
View File

@ -741,6 +741,7 @@ package body Atree is
begin
pragma Debug (New_Node_Debugging_Output (Source));
pragma Debug (New_Node_Debugging_Output (Destination));
Nodes.Table (Destination) := Nodes.Table (Source);
Nodes.Table (Destination).In_List := Save_In_List;
Nodes.Table (Destination).Link := Save_Link;
@ -1330,6 +1331,7 @@ package body Atree is
begin
pragma Debug (New_Node_Debugging_Output (E1));
pragma Debug (New_Node_Debugging_Output (E2));
pragma Assert (True
and then Has_Extension (E1)
and then Has_Extension (E2)
@ -1402,8 +1404,10 @@ package body Atree is
begin
pragma Assert (not (Has_Extension (Node)));
Result := Allocate_Initialize_Node (Node, With_Extension => True);
pragma Debug (Debug_Extend_Node);
return Result;
end Extend_Node;
@ -1677,8 +1681,8 @@ package body Atree is
Current_Error_Node := Ent;
end if;
Nodes.Table (Ent).Nkind := New_Node_Kind;
Nodes.Table (Ent).Sloc := New_Sloc;
Nodes.Table (Ent).Nkind := New_Node_Kind;
Nodes.Table (Ent).Sloc := New_Sloc;
pragma Debug (New_Node_Debugging_Output (Ent));
-- Mark the new entity as Ghost depending on the current Ghost region
@ -1700,6 +1704,7 @@ package body Atree is
begin
pragma Assert (New_Node_Kind not in N_Entity);
Nod := Allocate_Initialize_Node (Empty, With_Extension => False);
Nodes.Table (Nod).Nkind := New_Node_Kind;
Nodes.Table (Nod).Sloc := New_Sloc;
@ -2144,6 +2149,7 @@ package body Atree is
(not Has_Extension (Old_Node)
and not Has_Extension (New_Node)
and not Nodes.Table (New_Node).In_List);
pragma Debug (New_Node_Debugging_Output (Old_Node));
pragma Debug (New_Node_Debugging_Output (New_Node));
@ -2197,6 +2203,7 @@ package body Atree is
(not Has_Extension (Old_Node)
and not Has_Extension (New_Node)
and not Nodes.Table (New_Node).In_List);
pragma Debug (New_Node_Debugging_Output (Old_Node));
pragma Debug (New_Node_Debugging_Output (New_Node));

2
gcc/ada/exp_ch5.adb
View File

@ -1577,7 +1577,7 @@ package body Exp_Ch5 is
-- suppressed in this case). It is unnecessary but harmless in
-- other cases.
-- Special case: no copy if the target has no discriminants.
-- Special case: no copy if the target has no discriminants
if Has_Discriminants (L_Typ)
and then Is_Unchecked_Union (Base_Type (L_Typ))

4
gcc/ada/exp_ch6.adb
View File

@ -3001,8 +3001,8 @@ package body Exp_Ch6 is
if Prev_Orig /= Prev
and then Nkind (Prev) = N_Attribute_Reference
and then
Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access
and then Get_Attribute_Id (Attribute_Name (Prev)) =
Attribute_Access
and then Is_Aliased_View (Prev_Orig)
then
Prev_Orig := Prev;

1
gcc/ada/exp_ch9.adb
View File

@ -6041,6 +6041,7 @@ package body Exp_Ch9 is
-- reference will have been rewritten.
if Expander_Active then
-- The expanded name may have been constant folded in which case
-- the original node is not necessarily an entity name (e.g. an
-- indexed component).

13
gcc/ada/exp_disp.adb
View File

@ -323,7 +323,7 @@ package body Exp_Disp is
and then not Is_Interface (Full_Typ)
and then Has_Interfaces (Full_Typ)
and then (Full_Typ = Root_Typ
or else not Is_Variable_Size_Record (Etype (Full_Typ)));
or else not Is_Variable_Size_Record (Etype (Full_Typ)));
end Building_Static_Secondary_DT;
----------------------------------
@ -4787,7 +4787,8 @@ package body Exp_Disp is
if Is_Discrete_Type (Etype (Discrim)) then
Append_To (Constr_List,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etype (Discrim), Loc),
Prefix =>
New_Occurrence_Of (Etype (Discrim), Loc),
Attribute_Name => Name_First));
else
@ -4850,12 +4851,12 @@ package body Exp_Disp is
Make_Secondary_DT
(Typ => Typ,
Iface => Base_Type
(Related_Type (Node (AI_Tag_Comp))),
Iface =>
Base_Type (Related_Type (Node (AI_Tag_Comp))),
Iface_Comp => Node (AI_Tag_Comp),
Suffix_Index => Suffix_Index,
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
Num_Iface_Prims =>
UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => True,

75
gcc/ada/exp_spark.adb
View File

@ -55,10 +55,10 @@ package body Exp_SPARK is
-- Replace occurrences of System'To_Address by calls to
-- System.Storage_Elements.To_Address
procedure Expand_SPARK_Freeze_Type (E : Entity_Id);
procedure Expand_SPARK_N_Freeze_Type (E : Entity_Id);
-- Build the DIC procedure of a type when needed, if not already done
procedure Expand_SPARK_Indexed_Component (N : Node_Id);
procedure Expand_SPARK_N_Indexed_Component (N : Node_Id);
-- Insert explicit dereference if required
procedure Expand_SPARK_N_Loop_Statement (N : Node_Id);
@ -73,7 +73,7 @@ package body Exp_SPARK is
procedure Expand_SPARK_N_Op_Ne (N : Node_Id);
-- Rewrite operator /= based on operator = when defined explicitly
procedure Expand_SPARK_Selected_Component (N : Node_Id);
procedure Expand_SPARK_N_Selected_Component (N : Node_Id);
-- Insert explicit dereference if required
------------------
@ -134,14 +134,14 @@ package body Exp_SPARK is
when N_Freeze_Entity =>
if Is_Type (Entity (N)) then
Expand_SPARK_Freeze_Type (Entity (N));
Expand_SPARK_N_Freeze_Type (Entity (N));
end if;
when N_Indexed_Component =>
Expand_SPARK_Indexed_Component (N);
Expand_SPARK_N_Indexed_Component (N);
when N_Selected_Component =>
Expand_SPARK_Selected_Component (N);
Expand_SPARK_N_Selected_Component (N);
-- In SPARK mode, no other constructs require expansion
@ -150,11 +150,11 @@ package body Exp_SPARK is
end case;
end Expand_SPARK;
------------------------------
-- Expand_SPARK_Freeze_Type --
------------------------------
--------------------------------
-- Expand_SPARK_N_Freeze_Type --
--------------------------------
procedure Expand_SPARK_Freeze_Type (E : Entity_Id) is
procedure Expand_SPARK_N_Freeze_Type (E : Entity_Id) is
begin
-- When a DIC is inherited by a tagged type, it may need to be
-- specialized to the descendant type, hence build a separate DIC
@ -163,7 +163,7 @@ package body Exp_SPARK is
if Has_DIC (E) and then Is_Tagged_Type (E) then
Build_DIC_Procedure_Body (E, For_Freeze => True);
end if;
end Expand_SPARK_Freeze_Type;
end Expand_SPARK_N_Freeze_Type;
----------------------------------------
-- Expand_SPARK_N_Attribute_Reference --
@ -292,19 +292,20 @@ package body Exp_SPARK is
end if;
end Expand_SPARK_N_Loop_Statement;
------------------------------------
-- Expand_SPARK_Indexed_Component --
------------------------------------
--------------------------------------
-- Expand_SPARK_N_Indexed_Component --
--------------------------------------
procedure Expand_SPARK_N_Indexed_Component (N : Node_Id) is
Pref : constant Node_Id := Prefix (N);
Typ : constant Entity_Id := Etype (Pref);
procedure Expand_SPARK_Indexed_Component (N : Node_Id) is
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
begin
if Is_Access_Type (T) then
Insert_Explicit_Dereference (P);
Analyze_And_Resolve (P, Designated_Type (T));
if Is_Access_Type (Typ) then
Insert_Explicit_Dereference (Pref);
Analyze_And_Resolve (Pref, Designated_Type (Typ));
end if;
end Expand_SPARK_Indexed_Component;
end Expand_SPARK_N_Indexed_Component;
---------------------------------------
-- Expand_SPARK_N_Object_Declaration --
@ -496,31 +497,31 @@ package body Exp_SPARK is
end if;
end Expand_SPARK_Potential_Renaming;
-------------------------------------
-- Expand_SPARK_Selected_Component --
-------------------------------------
---------------------------------------
-- Expand_SPARK_N_Selected_Component --
---------------------------------------
procedure Expand_SPARK_N_Selected_Component (N : Node_Id) is
Pref : constant Node_Id := Prefix (N);
Typ : constant Entity_Id := Underlying_Type (Etype (Pref));
procedure Expand_SPARK_Selected_Component (N : Node_Id) is
P : constant Node_Id := Prefix (N);
Ptyp : constant Entity_Id := Underlying_Type (Etype (P));
begin
if Present (Ptyp)
and then Is_Access_Type (Ptyp)
then
if Present (Typ) and then Is_Access_Type (Typ) then
-- First set prefix type to proper access type, in case it currently
-- has a private (non-access) view of this type.
Set_Etype (P, Ptyp);
Set_Etype (Pref, Typ);
Insert_Explicit_Dereference (P);
Analyze_And_Resolve (P, Designated_Type (Ptyp));
Insert_Explicit_Dereference (Pref);
Analyze_And_Resolve (Pref, Designated_Type (Typ));
if Ekind (Etype (P)) = E_Private_Subtype
and then Is_For_Access_Subtype (Etype (P))
if Ekind (Etype (Pref)) = E_Private_Subtype
and then Is_For_Access_Subtype (Etype (Pref))
then
Set_Etype (P, Base_Type (Etype (P)));
Set_Etype (Pref, Base_Type (Etype (Pref)));
end if;
end if;
end Expand_SPARK_Selected_Component;
end Expand_SPARK_N_Selected_Component;
end Exp_SPARK;

1
gcc/ada/fmap.adb
View File

@ -306,6 +306,7 @@ package body Fmap is
else
Write_Str ("warning: no read access for mapping file """);
end if;
Write_Str (File_Name);
Write_Line ("""");
No_Mapping_File := True;

1
gcc/ada/frontend.adb
View File

@ -169,6 +169,7 @@ begin
-- Case of gnat.adc file present
if Source_gnat_adc > No_Source_File then
-- Parse the gnat.adc file for configuration pragmas
Initialize_Scanner (No_Unit, Source_gnat_adc);

1
gcc/ada/gnat1drv.adb
View File

@ -1065,6 +1065,7 @@ begin
("fatal error, run-time library not installed correctly");
Write_Line ("cannot locate file system.ads");
raise Unrecoverable_Error;
elsif S = No_Access_To_Source_File then
Write_Line
("fatal error, run-time library not installed correctly");

14
gcc/ada/lib-load.adb
View File

@ -328,19 +328,23 @@ package body Lib.Load is
if Main_Source_File > No_Source_File then
Version := Source_Checksum (Main_Source_File);
else
-- To avoid emitting a source location (since there is no file),
-- we write a custom error message instead of using the machinery
-- in errout.adb.
Set_Standard_Error;
if Main_Source_File = No_Access_To_Source_File then
Write_Str ("no read access for file """
& Get_Name_String (Fname) & """");
Write_Str
("no read access for file """ & Get_Name_String (Fname)
& """");
else
Write_Str ("file """
& Get_Name_String (Fname) & """ not found");
Write_Str
("file """ & Get_Name_String (Fname) & """ not found");
end if;
Write_Eol;
Set_Standard_Output;
end if;
@ -835,6 +839,7 @@ package body Lib.Load is
else
Write_Str (" file was not found, load failed");
end if;
Write_Eol;
end if;
@ -867,6 +872,7 @@ package body Lib.Load is
else
Error_Msg_File_1 := Fname;
if Src_Ind = No_Access_To_Source_File then
Error_Msg ("no read access to file{", Load_Msg_Sloc);
else

4
gcc/ada/osint.adb
View File

@ -2568,10 +2568,6 @@ package body Osint is
FD : out File_Descriptor;
T : File_Type := Source)
is
-- Source_File_FD : File_Descriptor;
-- The file descriptor for the current source file. A negative value
-- indicates failure to open the specified source file.
Len : Integer;
-- Length of file, assume no more than 2 gigabytes of source

4
gcc/ada/par-ch8.adb
View File

@ -65,6 +65,7 @@ package body Ch8 is
Append (Use_Node, Item_List);
Is_Last := True;
else
Set_More_Ids (Use_Node);
@ -152,11 +153,12 @@ package body Ch8 is
-- Error recovery: cannot raise Error_Resync
procedure P_Use_Type_Clause (Item_List : List_Id) is
Use_Sloc : constant Source_Ptr := Prev_Token_Ptr;
All_Present : Boolean;
Is_First : Boolean := True;
Is_Last : Boolean := False;
Use_Node : Node_Id;
Use_Sloc : constant Source_Ptr := Prev_Token_Ptr;
begin
if Token = Tok_All then

15
gcc/ada/prepcomp.adb
View File

@ -630,17 +630,16 @@ package body Prepcomp is
String_To_Name_Buffer (Current_Data.Deffile);
declare
N : constant File_Name_Type := Name_Find;
Deffile : constant Source_File_Index :=
Load_Definition_File (N);
Add_Deffile : Boolean := True;
T : constant Nat := Total_Errors_Detected;
N : constant File_Name_Type := Name_Find;
Deffile : constant Source_File_Index := Load_Definition_File (N);
T : constant Nat := Total_Errors_Detected;
Add_Deffile : Boolean := True;
begin
if Deffile <= No_Source_File then
Fail ("definition file """
& Get_Name_String (N)
& """ not found");
Fail
("definition file """ & Get_Name_String (N) & """ not found");
end if;
-- Initialize the preprocessor and set the characteristics of the

5
gcc/ada/sem_aggr.adb
View File

@ -4144,8 +4144,9 @@ package body Sem_Aggr is
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
Error_Msg_N ("iterated component association can only "
& "appear in an array aggregate", N);
Error_Msg_N
("iterated component association can only appear in an "
& "array aggregate", N);
raise Unrecoverable_Error;
else

20
gcc/ada/sem_ch10.adb
View File

@ -163,7 +163,9 @@ package body Sem_Ch10 is
-- the private declarations of a parent unit.
procedure Install_Parents
(Lib_Unit : Node_Id; Is_Private : Boolean; Chain : Boolean := True);
(Lib_Unit : Node_Id;
Is_Private : Boolean;
Chain : Boolean := True);
-- This procedure establishes the context for the compilation of a child
-- unit. If Lib_Unit is a child library spec then the context of the parent
-- is installed, and the parent itself made immediately visible, so that
@ -3390,7 +3392,9 @@ package body Sem_Ch10 is
if Is_Child_Spec (Lib_Unit) then
Install_Parents
(Lib_Unit, Private_Present (Parent (Lib_Unit)), Chain);
(Lib_Unit => Lib_Unit,
Is_Private => Private_Present (Parent (Lib_Unit)),
Chain => Chain);
end if;
Install_Limited_Context_Clauses (N);
@ -4065,7 +4069,10 @@ package body Sem_Ch10 is
---------------------
procedure Install_Parents
(Lib_Unit : Node_Id; Is_Private : Boolean; Chain : Boolean := True) is
(Lib_Unit : Node_Id;
Is_Private : Boolean;
Chain : Boolean := True)
is
P : Node_Id;
E_Name : Entity_Id;
P_Name : Entity_Id;
@ -4121,8 +4128,11 @@ package body Sem_Ch10 is
-- This is the recursive call that ensures all parents are loaded
if Is_Child_Spec (P) then
Install_Parents (P,
Is_Private or else Private_Present (Parent (Lib_Unit)), Chain);
Install_Parents
(Lib_Unit => P,
Is_Private =>
Is_Private or else Private_Present (Parent (Lib_Unit)),
Chain => Chain);
end if;
-- Now we can install the context for this parent

38
gcc/ada/sem_ch12.adb
View File

@ -1930,7 +1930,7 @@ package body Sem_Ch12 is
procedure Check_Generic_Parent is
Inst : constant Node_Id :=
Next (Unit_Declaration_Node (Actual));
Next (Unit_Declaration_Node (Actual));
Par : Entity_Id;
begin
@ -1939,26 +1939,26 @@ package body Sem_Ch12 is
if Nkind (Parent (Actual)) = N_Package_Specification
then
Par := Scope (Generic_Parent (Parent (Actual)));
if Is_Generic_Instance (Par) then
null;
-- If the actual is a child generic unit, check
-- whether the instantiation of the parent is
-- also local and must also be frozen now.
-- We must retrieve the instance node to locate
-- the parent instance if any.
-- also local and must also be frozen now. We
-- must retrieve the instance node to locate the
-- parent instance if any.
elsif Ekind (Par) = E_Generic_Package
and then Is_Child_Unit (Gen_Par)
and then Ekind (Scope (Gen_Par))
= E_Generic_Package
and then Is_Child_Unit (Gen_Par)
and then Ekind (Scope (Gen_Par)) =
E_Generic_Package
then
if Nkind (Inst) = N_Package_Instantiation
and then
Nkind (Name (Inst)) = N_Expanded_Name
and then Nkind (Name (Inst)) =
N_Expanded_Name
then
-- Retrieve entity of psarent instance.
-- Retrieve entity of parent instance
Par := Entity (Prefix (Name (Inst)));
end if;
@ -1986,12 +1986,13 @@ package body Sem_Ch12 is
begin
if Present (Renamed_Entity (Actual)) then
Gen_Par :=
Generic_Parent (Specification (
Unit_Declaration_Node (
Renamed_Entity (Actual))));
Generic_Parent (Specification
(Unit_Declaration_Node
(Renamed_Entity (Actual))));
else
Gen_Par := Generic_Parent
(Specification (Unit_Declaration_Node (Actual)));
Gen_Par :=
Generic_Parent (Specification
(Unit_Declaration_Node (Actual)));
end if;
if not Expander_Active
@ -2036,12 +2037,13 @@ package body Sem_Ch12 is
-- that it is the instance that must be frozen.
if Nkind (Parent (Actual)) =
N_Package_Renaming_Declaration
N_Package_Renaming_Declaration
then
Set_Has_Delayed_Freeze
(Renamed_Entity (Actual));
Append_Elmt
(Renamed_Entity (Actual), Actuals_To_Freeze);
(Renamed_Entity (Actual),
Actuals_To_Freeze);
else
Set_Has_Delayed_Freeze (Actual);
Append_Elmt (Actual, Actuals_To_Freeze);

85
gcc/ada/sem_ch3.adb
View File

@ -2211,6 +2211,12 @@ package body Sem_Ch3 is
-- contract expression. Full analysis of the expression is done when
-- the contract is processed.
function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean;
-- Check if a nested package has entities within it that rely on library
-- level private types where the full view has not been completed for
-- the purposes of checking if it is acceptable to freeze an expression
-- function at the point of declaration.
procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id);
-- Determine whether Body_Decl denotes the body of a late controlled
-- primitive (either Initialize, Adjust or Finalize). If this is the
@ -2234,12 +2240,6 @@ package body Sem_Ch3 is
-- declarations, or before a declaration that freezes previous entities,
-- such as in a subprogram body.
function Uses_Unseen_Priv (Pkg : Entity_Id) return Boolean;
-- Check if a nested package has entities within it that rely on library
-- level private types where the full view has not been seen for the
-- purposes of checking if it is acceptable to freeze an expression
-- function at the point of declaration.
-----------------
-- Adjust_Decl --
-----------------
@ -2400,6 +2400,40 @@ package body Sem_Ch3 is
end loop;
end Check_Entry_Contracts;
----------------------------------
-- Contains_Lib_Incomplete_Type --
----------------------------------
function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean is
Curr : Entity_Id;
begin
-- Avoid looking through scopes that do not meet the precondition of
-- Pkg not being within a library unit spec.
if not Is_Compilation_Unit (Pkg)
and then not Is_Generic_Instance (Pkg)
and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
then
-- Loop through all entities in the current scope to identify
-- an entity that depends on a private type.
Curr := First_Entity (Pkg);
loop
if Nkind (Curr) in N_Entity
and then Depends_On_Private (Curr)
then
return True;
end if;
exit when Last_Entity (Current_Scope) = Curr;
Curr := Next_Entity (Curr);
end loop;
end if;
return False;
end Contains_Lib_Incomplete_Type;
--------------------------------------
-- Handle_Late_Controlled_Primitive --
--------------------------------------
@ -2543,40 +2577,6 @@ package body Sem_Ch3 is
end loop;
end Resolve_Aspects;
----------------------
-- Uses_Unseen_Priv --
----------------------
function Uses_Unseen_Priv (Pkg : Entity_Id) return Boolean is
Curr : Entity_Id;
begin
-- Avoid looking through scopes that do not meet the precondition of
-- Pkg not being within a library unit spec.
if not Is_Compilation_Unit (Pkg)
and then not Is_Generic_Instance (Pkg)
and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
then
-- Loop through all entities in the current scope to identify
-- an entity that depends on a private type.
Curr := First_Entity (Pkg);
loop
if Nkind (Curr) in N_Entity
and then Depends_On_Private (Curr)
then
return True;
end if;
exit when Last_Entity (Current_Scope) = Curr;
Curr := Next_Entity (Curr);
end loop;
end if;
return False;
end Uses_Unseen_Priv;
-- Local variables
Context : Node_Id := Empty;
@ -2750,7 +2750,7 @@ package body Sem_Ch3 is
-- not cause unwanted freezing at that point.
-- It is also necessary to check for a case where both an expression
-- function is used and the current scope depends on an unseen
-- function is used and the current scope depends on an incomplete
-- private type from a library unit, otherwise premature freezing of
-- the private type will occur.
@ -2758,7 +2758,8 @@ package body Sem_Ch3 is
and then ((Nkind (Next_Decl) /= N_Subprogram_Body
or else not Was_Expression_Function (Next_Decl))
or else (not Is_Ignored_Ghost_Entity (Current_Scope)
and then not Uses_Unseen_Priv (Current_Scope)))
and then not Contains_Lib_Incomplete_Type
(Current_Scope)))
then
-- When a controlled type is frozen, the expander generates stream
-- and controlled-type support routines. If the freeze is caused

198
gcc/ada/sem_ch8.adb
View File

@ -479,6 +479,7 @@ package body Sem_Ch8 is
-- Find the most previous use clause (that is, the first one to appear in
-- the source) by traversing the previous clause chain that exists in both
-- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes.
-- ??? a better subprogram name is in order
function Find_Renamed_Entity
(N : Node_Id;
@ -526,19 +527,24 @@ package body Sem_Ch8 is
Clause2 : Entity_Id) return Entity_Id;
-- Determine which use clause parameter is the most descendant in terms of
-- scope.
-- ??? a better subprogram name is in order
procedure Premature_Usage (N : Node_Id);
-- Diagnose usage of an entity before it is visible
procedure Use_One_Package
(N : Node_Id; Pack_Name : Entity_Id := Empty; Force : Boolean := False);
(N : Node_Id;
Pack_Name : Entity_Id := Empty;
Force : Boolean := False);
-- Make visible entities declared in package P potentially use-visible
-- in the current context. Also used in the analysis of subunits, when
-- re-installing use clauses of parent units. N is the use_clause that
-- names P (and possibly other packages).
procedure Use_One_Type
(Id : Node_Id; Installed : Boolean := False; Force : Boolean := False);
(Id : Node_Id;
Installed : Boolean := False;
Force : Boolean := False);
-- Id is the subtype mark from a use_type_clause. This procedure makes
-- the primitive operators of the type potentially use-visible. The
-- boolean flag Installed indicates that the clause is being reinstalled
@ -3639,8 +3645,8 @@ package body Sem_Ch8 is
-- implicit generic actual.
if From_Default (N)
and then Is_Generic_Actual_Subprogram (New_S)
and then Present (Alias (New_S))
and then Is_Generic_Actual_Subprogram (New_S)
and then Present (Alias (New_S))
then
Mark_Use_Clauses (Alias (New_S));
@ -3666,7 +3672,6 @@ package body Sem_Ch8 is
-- within the package itself, ignore it.
procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True) is
procedure Analyze_Package_Name (Clause : Node_Id);
-- Perform analysis on a package name from a use_package_clause
@ -3700,8 +3705,8 @@ package body Sem_Ch8 is
if Entity (Pref) = Standard_Standard then
Error_Msg_N
("predefined package Standard cannot appear in a "
& "context clause", Pref);
("predefined package Standard cannot appear in a context "
& "clause", Pref);
end if;
end if;
end Analyze_Package_Name;
@ -3763,6 +3768,7 @@ package body Sem_Ch8 is
if not More_Ids (N) and then not Prev_Ids (N) then
Analyze_Package_Name (N);
elsif More_Ids (N) and then not Prev_Ids (N) then
Analyze_Package_Name_List (N);
end if;
@ -3772,12 +3778,13 @@ package body Sem_Ch8 is
return;
end if;
Pack := Entity (Name (N));
if Chain then
Chain_Use_Clause (N);
end if;
Pack := Entity (Name (N));
-- There are many cases where scopes are manipulated during analysis, so
-- check that Pack's current use clause has not already been chained
-- before setting its previous use clause.
@ -3796,8 +3803,7 @@ package body Sem_Ch8 is
if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then
if Ekind (Pack) = E_Generic_Package then
Error_Msg_N -- CODEFIX
("a generic package is not allowed in a use clause",
Name (N));
("a generic package is not allowed in a use clause", Name (N));
elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package)
then
@ -3807,8 +3813,7 @@ package body Sem_Ch8 is
elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then
Error_Msg_N -- CODEFIX
("a subprogram is not allowed in a use clause",
Name (N));
("a subprogram is not allowed in a use clause", Name (N));
else
Error_Msg_N ("& is not allowed in a use clause", Name (N));
@ -4186,8 +4191,8 @@ package body Sem_Ch8 is
----------------------
procedure Chain_Use_Clause (N : Node_Id) is
Pack : Entity_Id;
Level : Int := Scope_Stack.Last;
Pack : Entity_Id;
begin
-- Common case
@ -4209,6 +4214,7 @@ package body Sem_Ch8 is
-- parent unit when compiling a child.
Pack := Defining_Entity (Parent (N), Empty_On_Errors => True);
if not In_Open_Scopes (Pack) then
null;
@ -4771,9 +4777,7 @@ package body Sem_Ch8 is
function Entity_Of_Unit (U : Node_Id) return Entity_Id is
begin
if Nkind (U) = N_Package_Instantiation
and then Analyzed (U)
then
if Nkind (U) = N_Package_Instantiation and then Analyzed (U) then
return Defining_Entity (Instance_Spec (U));
else
return Defining_Entity (U);
@ -5885,9 +5889,7 @@ package body Sem_Ch8 is
-- path, so ignore the fact that they are overloaded and mark them
-- anyway.
if Nkind (N) not in N_Subexpr
or else not Is_Overloaded (N)
then
if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then
Mark_Use_Clauses (N);
end if;
@ -6541,6 +6543,7 @@ package body Sem_Ch8 is
function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is
Curr : Node_Id;
begin
-- Loop through the Prev_Use_Clause chain
@ -8206,7 +8209,6 @@ package body Sem_Ch8 is
----------------------
procedure Mark_Use_Clauses (Id : Node_Or_Entity_Id) is
procedure Mark_Parameters (Call : Entity_Id);
-- Perform use_type_clause marking for all parameters in a subprogram
-- or operator call.
@ -8249,8 +8251,8 @@ package body Sem_Ch8 is
Curr : Node_Id;
begin
-- Ignore cases where the scope of the type is not a package
-- (e.g. Standard_Standard).
-- Ignore cases where the scope of the type is not a package (e.g.
-- Standard_Standard).
if Ekind (Pak) /= E_Package then
return;
@ -8258,10 +8260,10 @@ package body Sem_Ch8 is
Curr := Current_Use_Clause (Pak);
while Present (Curr)
and then not Is_Effective_Use_Clause (Curr)
and then not Is_Effective_Use_Clause (Curr)
loop
-- We need to mark the previous use clauses as effective, but each
-- use clause may in turn render other use_package_clauses
-- We need to mark the previous use clauses as effective, but
-- each use clause may in turn render other use_package_clauses
-- effective. Additionally, it is possible to have a parent
-- package renamed as a child of itself so we must check the
-- prefix entity is not the same as the package we are marking.
@ -8312,6 +8314,7 @@ package body Sem_Ch8 is
-- for ignoring previous errors.
Mark_Use_Package (Scope (Base_Type (Etype (E))));
if Nkind (E) in N_Op
and then Present (Entity (E))
and then Present (Scope (Entity (E)))
@ -8346,7 +8349,7 @@ package body Sem_Ch8 is
-- Use clauses in and of themselves do not count as a "use" of a
-- package.
if Nkind_In (Parent (Id), N_Use_Type_Clause, N_Use_Package_Clause) then
if Nkind_In (Parent (Id), N_Use_Package_Clause, N_Use_Type_Clause) then
return;
end if;
@ -8368,8 +8371,8 @@ package body Sem_Ch8 is
-- Mark primitives
elsif (Ekind (Id) in Overloadable_Kind
or else Ekind_In
(Ekind (Id), E_Generic_Function, E_Generic_Procedure))
or else Ekind_In (Id, E_Generic_Function,
E_Generic_Procedure))
and then (Is_Potentially_Use_Visible (Id)
or else Is_Intrinsic_Subprogram (Id))
then
@ -8388,7 +8391,7 @@ package body Sem_Ch8 is
-- expression.
if Nkind (Id) in N_Binary_Op
and then not (Nkind (Left_Opnd (Id)) in N_Op)
and then not (Nkind (Left_Opnd (Id)) in N_Op)
then
Mark_Use_Type (Left_Opnd (Id));
end if;
@ -8896,8 +8899,9 @@ package body Sem_Ch8 is
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
and then Handle_Use
then
Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause,
Force_Installation => True);
Install_Use_Clauses
(Scope_Stack.Table (SS_Last).First_Use_Clause,
Force_Installation => True);
end if;
end Restore_Scope_Stack;
@ -9020,7 +9024,6 @@ package body Sem_Ch8 is
-----------------------------
procedure Update_Use_Clause_Chain is
procedure Update_Chain_In_Scope (Level : Int);
-- Iterate through one level in the scope stack verifying each use-type
-- clause within said level is used then reset the Current_Use_Clause
@ -9058,7 +9061,6 @@ package body Sem_Ch8 is
and then not Is_Effective_Use_Clause (Curr)
and then not In_Instance
then
-- We are dealing with a potentially unused use_package_clause
if Nkind (Curr) = N_Use_Package_Clause then
@ -9068,21 +9070,24 @@ package body Sem_Ch8 is
if not (Present (Associated_Node (N))
and then Present
(Current_Use_Clause (Associated_Node (N)))
(Current_Use_Clause
(Associated_Node (N)))
and then Is_Effective_Use_Clause
(Current_Use_Clause (Associated_Node (N))))
(Current_Use_Clause
(Associated_Node (N))))
then
Error_Msg_Node_1 := Entity (N);
Error_Msg_NE ("use clause for package &? has no effect",
Curr, Entity (N));
Error_Msg_NE
("use clause for package &? has no effect",
Curr, Entity (N));
end if;
-- We are dealing with an unused use_type_clause
else
Error_Msg_Node_1 := Etype (N);
Error_Msg_NE ("use clause for }? has no effect",
Curr, Etype (N));
Error_Msg_NE
("use clause for }? has no effect", Curr, Etype (N));
end if;
end if;
@ -9123,7 +9128,6 @@ package body Sem_Ch8 is
Pack_Name : Entity_Id := Empty;
Force : Boolean := False)
is
procedure Note_Redundant_Use (Clause : Node_Id);
-- Mark the name in a use clause as redundant if the corresponding
-- entity is already use-visible. Emit a warning if the use clause comes
@ -9134,8 +9138,8 @@ package body Sem_Ch8 is
------------------------
procedure Note_Redundant_Use (Clause : Node_Id) is
Pack_Name : constant Entity_Id := Entity (Clause);
Decl : constant Node_Id := Parent (Clause);
Pack_Name : constant Entity_Id := Entity (Clause);
Cur_Use : Node_Id := Current_Use_Clause (Pack_Name);
Prev_Use : Node_Id := Empty;
@ -9191,10 +9195,11 @@ package body Sem_Ch8 is
elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
declare
Cur_Unit : constant Unit_Number_Type :=
Get_Source_Unit (Cur_Use);
Get_Source_Unit (Cur_Use);
New_Unit : constant Unit_Number_Type :=
Get_Source_Unit (Clause);
Scop : Entity_Id;
Get_Source_Unit (Clause);
Scop : Entity_Id;
begin
if Cur_Unit = New_Unit then
@ -9216,8 +9221,8 @@ package body Sem_Ch8 is
Redundant := Clause;
Prev_Use := Cur_Use;
-- Most common case: redundant clause in body,
-- original clause in spec. Current scope is spec entity.
-- Most common case: redundant clause in body, original
-- clause in spec. Current scope is spec entity.
elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then
Redundant := Cur_Use;
@ -9287,8 +9292,8 @@ package body Sem_Ch8 is
-- visible part of the child, and no warning should be emitted.
if Nkind (Parent (Decl)) = N_Package_Specification
and then
List_Containing (Decl) = Private_Declarations (Parent (Decl))
and then List_Containing (Decl) =
Private_Declarations (Parent (Decl))
then
declare
Par : constant Entity_Id := Defining_Entity (Parent (Decl));
@ -9299,16 +9304,16 @@ package body Sem_Ch8 is
if Is_Compilation_Unit (Par)
and then Par /= Cunit_Entity (Current_Sem_Unit)
and then Parent (Cur_Use) = Spec
and then
List_Containing (Cur_Use) = Visible_Declarations (Spec)
and then List_Containing (Cur_Use) =
Visible_Declarations (Spec)
then
return;
end if;
end;
end if;
-- Finally, if the current use clause is in the context then
-- the clause is redundant when it is nested within the unit.
-- Finally, if the current use clause is in the context then the
-- clause is redundant when it is nested within the unit.
elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit
and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit
@ -9320,6 +9325,7 @@ package body Sem_Ch8 is
end if;
if Present (Redundant) and then Parent (Redundant) /= Prev_Use then
-- Make sure we are looking at most-descendant use_package_clause
-- by traversing the chain with Find_Most_Prev and then verifying
-- there is no scope manipulation via Most_Descendant_Use_Clause.
@ -9328,7 +9334,7 @@ package body Sem_Ch8 is
and then
(Nkind (Parent (Prev_Use)) /= N_Compilation_Unit
or else Most_Descendant_Use_Clause
(Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use)
(Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use)
then
Prev_Use := Find_Most_Prev (Prev_Use);
end if;
@ -9342,12 +9348,12 @@ package body Sem_Ch8 is
-- Local variables
Id : Entity_Id;
Prev : Entity_Id;
Current_Instance : Entity_Id := Empty;
Real_P : Entity_Id;
Private_With_OK : Boolean := False;
Id : Entity_Id;
P : Entity_Id;
Prev : Entity_Id;
Private_With_OK : Boolean := False;
Real_P : Entity_Id;
-- Start of processing for Use_One_Package
@ -9388,9 +9394,11 @@ package body Sem_Ch8 is
if In_Use (P) then
Note_Redundant_Use (Pack_Name);
if not Force then
Set_Current_Use_Clause (P, N);
end if;
return;
-- Warn about detected redundant clauses
@ -9401,6 +9409,7 @@ package body Sem_Ch8 is
("& is already use-visible within itself?r?",
Pack_Name, P);
end if;
return;
end if;
@ -9432,10 +9441,9 @@ package body Sem_Ch8 is
end if;
end if;
-- If unit is a package renaming, indicate that the renamed
-- package is also in use (the flags on both entities must
-- remain consistent, and a subsequent use of either of them
-- should be recognized as redundant).
-- If unit is a package renaming, indicate that the renamed package is
-- also in use (the flags on both entities must remain consistent, and a
-- subsequent use of either of them should be recognized as redundant).
if Present (Renamed_Object (P)) then
Set_In_Use (Renamed_Object (P));
@ -9600,13 +9608,10 @@ package body Sem_Ch8 is
------------------
procedure Use_One_Type
(Id : Node_Id; Installed : Boolean := False; Force : Boolean := False)
(Id : Node_Id;
Installed : Boolean := False;
Force : Boolean := False)
is
Elmt : Elmt_Id;
Is_Known_Used : Boolean;
Op_List : Elist_Id;
T : Entity_Id;
function Spec_Reloaded_For_Body return Boolean;
-- Determine whether the compilation unit is a package body and the use
-- type clause is in the spec of the same package. Even though the spec
@ -9635,9 +9640,9 @@ package body Sem_Ch8 is
return
Nkind (Spec) = N_Package_Specification
and then
In_Same_Source_Unit (Corresponding_Body (Parent (Spec)),
Cunit_Entity (Current_Sem_Unit));
and then In_Same_Source_Unit
(Corresponding_Body (Parent (Spec)),
Cunit_Entity (Current_Sem_Unit));
end;
end if;
@ -9649,9 +9654,6 @@ package body Sem_Ch8 is
-------------------------------
procedure Use_Class_Wide_Operations (Typ : Entity_Id) is
Scop : Entity_Id;
Ent : Entity_Id;
function Is_Class_Wide_Operation_Of
(Op : Entity_Id;
T : Entity_Id) return Boolean;
@ -9663,8 +9665,8 @@ package body Sem_Ch8 is
---------------------------------
function Is_Class_Wide_Operation_Of
(Op : Entity_Id;
T : Entity_Id) return Boolean
(Op : Entity_Id;
T : Entity_Id) return Boolean
is
Formal : Entity_Id;
@ -9674,6 +9676,7 @@ package body Sem_Ch8 is
if Etype (Formal) = Class_Wide_Type (T) then
return True;
end if;
Next_Formal (Formal);
end loop;
@ -9684,6 +9687,11 @@ package body Sem_Ch8 is
return False;
end Is_Class_Wide_Operation_Of;
-- Local variables
Ent : Entity_Id;
Scop : Entity_Id;
-- Start of processing for Use_Class_Wide_Operations
begin
@ -9708,6 +9716,13 @@ package body Sem_Ch8 is
end if;
end Use_Class_Wide_Operations;
-- Local variables
Elmt : Elmt_Id;
Is_Known_Used : Boolean;
Op_List : Elist_Id;
T : Entity_Id;
-- Start of processing for Use_One_Type
begin
@ -9724,13 +9739,13 @@ package body Sem_Ch8 is
-- in use or the entity is declared in the current package, thus
-- use-visible.
Is_Known_Used := (In_Use (T)
and then ((Present (Current_Use_Clause (T))
and then All_Present
(Current_Use_Clause (T)))
or else not All_Present (Parent (Id))))
or else In_Use (Scope (T))
or else Scope (T) = Current_Scope;
Is_Known_Used :=
(In_Use (T)
and then ((Present (Current_Use_Clause (T))
and then All_Present (Current_Use_Clause (T)))
or else not All_Present (Parent (Id))))
or else In_Use (Scope (T))
or else Scope (T) = Current_Scope;
Set_Redundant_Use (Id,
Is_Known_Used or else Is_Potentially_Use_Visible (T));
@ -9784,8 +9799,8 @@ package body Sem_Ch8 is
Set_Current_Use_Clause (T, Parent (Id));
Set_In_Use (T);
-- If T is tagged, primitive operators on class-wide operands
-- are also available.
-- If T is tagged, primitive operators on class-wide operands are
-- also available.
if Is_Tagged_Type (T) then
Set_In_Use (Class_Wide_Type (T));
@ -9862,8 +9877,8 @@ package body Sem_Ch8 is
if Present (Current_Use_Clause (T)) then
Use_Clause_Known : declare
Clause1 : constant Node_Id := Find_Most_Prev
(Current_Use_Clause (T));
Clause1 : constant Node_Id :=
Find_Most_Prev (Current_Use_Clause (T));
Clause2 : constant Node_Id := Parent (Id);
Ent1 : Entity_Id;
Ent2 : Entity_Id;
@ -9938,7 +9953,8 @@ package body Sem_Ch8 is
else
declare
S1, S2 : Entity_Id;
S1 : Entity_Id;
S2 : Entity_Id;
begin
S1 := Scope (Ent1);
@ -9986,8 +10002,8 @@ package body Sem_Ch8 is
end if;
end Use_Clause_Known;
-- Here if Current_Use_Clause is not set for T, another case
-- where we do not have the location information available.
-- Here if Current_Use_Clause is not set for T, another case where
-- we do not have the location information available.
else
Error_Msg_NE -- CODEFIX
@ -9998,8 +10014,8 @@ package body Sem_Ch8 is
-- The package where T is declared is already used
elsif In_Use (Scope (T)) then
Error_Msg_Sloc := Sloc (Find_Most_Prev
(Current_Use_Clause (Scope (T))));
Error_Msg_Sloc :=
Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T))));
Error_Msg_NE -- CODEFIX
("& is already use-visible through package use clause #??",
Id, T);

18
gcc/ada/sem_ch8.ads
View File

@ -53,17 +53,15 @@ package Sem_Ch8 is
procedure Analyze_Package_Renaming (N : Node_Id);
procedure Analyze_Subprogram_Renaming (N : Node_Id);
procedure Analyze_Use_Package (N : Node_Id;
Chain : Boolean := True);
-- Analyze a use package clause and control (through the Chain
-- parameter) whether to add N to the use clause chain for the name
-- denoted within use clause N in case we are reanalyzing a use clause
-- because of stack manipulation.
procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True);
-- Analyze a use package clause and control (through the Chain parameter)
-- whether to add N to the use clause chain for the name denoted within
-- use clause N in case we are reanalyzing a use clause because of stack
-- manipulation.
procedure Analyze_Use_Type (N : Node_Id;
Chain : Boolean := True);
-- Similar to Analyze_Use_Package except the Chain parameter applies
-- to the type within N's subtype mark Current_Use_Clause.
procedure Analyze_Use_Type (N : Node_Id; Chain : Boolean := True);
-- Similar to Analyze_Use_Package except the Chain parameter applies to the
-- type within N's subtype mark Current_Use_Clause.
procedure End_Scope;
-- Called at end of scope. On exit from blocks and bodies (subprogram,

4
gcc/ada/sem_spark.adb
View File

@ -5286,6 +5286,7 @@ package body Sem_SPARK is
is
begin
case Nkind (N) is
-- Base identifier. Set permission to W or No depending on Mode.
when N_Identifier
@ -5293,9 +5294,8 @@ package body Sem_SPARK is
=>
declare
P : constant Node_Id := Entity (N);
C : constant Perm_Tree_Access :=
Get (Current_Perm_Env, Unique_Entity (P));
Get (Current_Perm_Env, Unique_Entity (P));
begin
-- The base tree can be RW (first move from this base path) or

4
gcc/ada/sinput-l.adb
View File

@ -355,10 +355,10 @@ package body Sinput.L is
T : Osint.File_Type) return Source_File_Index
is
FD : File_Descriptor;
Hi : Source_Ptr;
Lo : Source_Ptr;
Src : Source_Buffer_Ptr;
X : Source_File_Index;
Lo : Source_Ptr;
Hi : Source_Ptr;
Preprocessing_Needed : Boolean := False;

4
gcc/ada/targparm.adb
View File

@ -158,8 +158,8 @@ package body Targparm is
Set_NUP : Set_NUP_Type := null)
is
FD : File_Descriptor;
Text : Source_Buffer_Ptr;
Hi : Source_Ptr;
Text : Source_Buffer_Ptr;
begin
if Parameters_Obtained then
@ -173,11 +173,13 @@ package body Targparm is
if Null_Source_Buffer_Ptr (Text) then
Write_Line ("fatal error, run-time library not installed correctly");
if FD = Null_FD then
Write_Line ("cannot locate file system.ads");
else
Write_Line ("no read access for file system.ads");
end if;
raise Unrecoverable_Error;
end if;