Commit 16ca248a by Ed Schonberg Committed by Arnaud Charlet

sem_ch8.adb (Has_Components): If the argument is an incomplete type that is a limited view...

2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* sem_ch8.adb (Has_Components): If the argument is an incomplete type
	that is a limited view, check the non-limited view if available.
	(Undefined): Refine error message for missing with of Text_IO
	(Find_Expanded_Name): Use Is_Known_Unit for more accurate error message
	to distinguish real missing with cases.
	Fix format of all missing with messages
	(Analyze_Subprogram_Renaming): Emit proper error message on illegal
	renaming as body when renamed entity is abstract.

From-SVN: r123597
parent 13bbad84
...@@ -33,6 +33,7 @@ with Exp_Tss; use Exp_Tss; ...@@ -33,6 +33,7 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Fname; use Fname; with Fname; use Fname;
with Freeze; use Freeze; with Freeze; use Freeze;
with Impunit; use Impunit;
with Lib; use Lib; with Lib; use Lib;
with Lib.Load; use Lib.Load; with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref; with Lib.Xref; use Lib.Xref;
...@@ -229,23 +230,22 @@ package body Sem_Ch8 is ...@@ -229,23 +230,22 @@ package body Sem_Ch8 is
-- Compiling subunits -- -- Compiling subunits --
------------------------ ------------------------
-- Subunits must be compiled in the environment of the corresponding -- Subunits must be compiled in the environment of the corresponding stub,
-- stub, that is to say with the same visibility into the parent (and its -- that is to say with the same visibility into the parent (and its
-- context) that is available at the point of the stub declaration, but -- context) that is available at the point of the stub declaration, but
-- with the additional visibility provided by the context clause of the -- with the additional visibility provided by the context clause of the
-- subunit itself. As a result, compilation of a subunit forces compilation -- subunit itself. As a result, compilation of a subunit forces compilation
-- of the parent (see description in lib-). At the point of the stub -- of the parent (see description in lib-). At the point of the stub
-- declaration, Analyze is called recursively to compile the proper body -- declaration, Analyze is called recursively to compile the proper body of
-- of the subunit, but without reinitializing the names table, nor the -- the subunit, but without reinitializing the names table, nor the scope
-- scope stack (i.e. standard is not pushed on the stack). In this fashion -- stack (i.e. standard is not pushed on the stack). In this fashion the
-- the context of the subunit is added to the context of the parent, and -- context of the subunit is added to the context of the parent, and the
-- the subunit is compiled in the correct environment. Note that in the -- subunit is compiled in the correct environment. Note that in the course
-- course of processing the context of a subunit, Standard will appear -- of processing the context of a subunit, Standard will appear twice on
-- twice on the scope stack: once for the parent of the subunit, and -- the scope stack: once for the parent of the subunit, and once for the
-- once for the unit in the context clause being compiled. However, the -- unit in the context clause being compiled. However, the two sets of
-- two sets of entities are not linked by homonym chains, so that the -- entities are not linked by homonym chains, so that the compilation of
-- compilation of any context unit happens in a fresh visibility -- any context unit happens in a fresh visibility environment.
-- environment.
------------------------------- -------------------------------
-- Processing of USE Clauses -- -- Processing of USE Clauses --
...@@ -292,8 +292,8 @@ package body Sem_Ch8 is ...@@ -292,8 +292,8 @@ package body Sem_Ch8 is
-- contains the full declaration. To simplify the swap, the defining -- contains the full declaration. To simplify the swap, the defining
-- occurrence that currently holds the private declaration points to the -- occurrence that currently holds the private declaration points to the
-- full declaration. During semantic processing the defining occurrence -- full declaration. During semantic processing the defining occurrence
-- also points to a list of private dependents, that is to say access -- also points to a list of private dependents, that is to say access types
-- types or composite types whose designated types or component types are -- or composite types whose designated types or component types are
-- subtypes or derived types of the private type in question. After the -- subtypes or derived types of the private type in question. After the
-- full declaration has been seen, the private dependents are updated to -- full declaration has been seen, the private dependents are updated to
-- indicate that they have full definitions. -- indicate that they have full definitions.
...@@ -457,12 +457,11 @@ package body Sem_Ch8 is ...@@ -457,12 +457,11 @@ package body Sem_Ch8 is
function Has_Implicit_Operator (N : Node_Id) return Boolean; function Has_Implicit_Operator (N : Node_Id) return Boolean;
-- N is an expanded name whose selector is an operator name (eg P."+"). -- N is an expanded name whose selector is an operator name (eg P."+").
-- A declarative part contains an implicit declaration of an operator -- declarative part contains an implicit declaration of an operator if it
-- if it has a declaration of a type to which one of the predefined -- has a declaration of a type to which one of the predefined operators
-- operators apply. The existence of this routine is an artifact of -- apply. The existence of this routine is an implementation artifact. A
-- our implementation: a more straightforward but more space-consuming -- more straightforward but more space-consuming choice would be to make
-- choice would be to make all inherited operators explicit in the -- all inherited operators explicit in the symbol table.
-- symbol table.
procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id); procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id);
-- A subprogram defined by a renaming declaration inherits the parameter -- A subprogram defined by a renaming declaration inherits the parameter
...@@ -471,17 +470,17 @@ package body Sem_Ch8 is ...@@ -471,17 +470,17 @@ package body Sem_Ch8 is
-- subprogram, which are then used to recheck the default values. -- subprogram, which are then used to recheck the default values.
function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
-- Prefix is appropriate for record if it is of a record type, or -- Prefix is appropriate for record if it is of a record type, or an access
-- an access to such. -- to such.
function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean; function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean;
-- True if it is of a task type, a protected type, or else an access -- True if it is of a task type, a protected type, or else an access to one
-- to one of these types. -- of these types.
procedure Note_Redundant_Use (Clause : Node_Id); procedure Note_Redundant_Use (Clause : Node_Id);
-- Mark the name in a use clause as redundant if the corresponding -- Mark the name in a use clause as redundant if the corresponding entity
-- entity is already use-visible. Emit a warning if the use clause -- is already use-visible. Emit a warning if the use clause comes from
-- comes from source and the proper warnings are enabled. -- source and the proper warnings are enabled.
procedure Premature_Usage (N : Node_Id); procedure Premature_Usage (N : Node_Id);
-- Diagnose usage of an entity before it is visible -- Diagnose usage of an entity before it is visible
...@@ -507,9 +506,9 @@ package body Sem_Ch8 is ...@@ -507,9 +506,9 @@ package body Sem_Ch8 is
-- Analyze_Exception_Renaming -- -- Analyze_Exception_Renaming --
-------------------------------- --------------------------------
-- The language only allows a single identifier, but the tree holds -- The language only allows a single identifier, but the tree holds an
-- an identifier list. The parser has already issued an error message -- identifier list. The parser has already issued an error message if
-- if there is more than one element in the list. -- there is more than one element in the list.
procedure Analyze_Exception_Renaming (N : Node_Id) is procedure Analyze_Exception_Renaming (N : Node_Id) is
Id : constant Node_Id := Defining_Identifier (N); Id : constant Node_Id := Defining_Identifier (N);
...@@ -543,10 +542,10 @@ package body Sem_Ch8 is ...@@ -543,10 +542,10 @@ package body Sem_Ch8 is
procedure Analyze_Expanded_Name (N : Node_Id) is procedure Analyze_Expanded_Name (N : Node_Id) is
begin begin
-- If the entity pointer is already set, this is an internal node, or -- If the entity pointer is already set, this is an internal node, or a
-- a node that is analyzed more than once, after a tree modification. -- node that is analyzed more than once, after a tree modification. In
-- In such a case there is no resolution to perform, just set the type. -- such a case there is no resolution to perform, just set the type. For
-- For completeness, analyze prefix as well. -- completeness, analyze prefix as well.
if Present (Entity (N)) then if Present (Entity (N)) then
if Is_Type (Entity (N)) then if Is_Type (Entity (N)) then
...@@ -577,8 +576,8 @@ package body Sem_Ch8 is ...@@ -577,8 +576,8 @@ package body Sem_Ch8 is
procedure Analyze_Generic_Package_Renaming (N : Node_Id) is procedure Analyze_Generic_Package_Renaming (N : Node_Id) is
begin begin
-- Apply the Text_IO Kludge here, since we may be renaming -- Apply the Text_IO Kludge here, since we may be renaming one of the
-- one of the subpackages of Text_IO, then join common routine. -- subpackages of Text_IO, then join common routine.
Text_IO_Kludge (Name (N)); Text_IO_Kludge (Name (N));
...@@ -704,11 +703,11 @@ package body Sem_Ch8 is ...@@ -704,11 +703,11 @@ package body Sem_Ch8 is
Set_Is_Pure (Id, Is_Pure (Current_Scope)); Set_Is_Pure (Id, Is_Pure (Current_Scope));
Enter_Name (Id); Enter_Name (Id);
-- The renaming of a component that depends on a discriminant -- The renaming of a component that depends on a discriminant requires
-- requires an actual subtype, because in subsequent use of the object -- an actual subtype, because in subsequent use of the object Gigi will
-- Gigi will be unable to locate the actual bounds. This explicit step -- be unable to locate the actual bounds. This explicit step is required
-- is required when the renaming is generated in removing side effects -- when the renaming is generated in removing side effects of an
-- of an already-analyzed expression. -- already-analyzed expression.
if Nkind (Nam) = N_Selected_Component if Nkind (Nam) = N_Selected_Component
and then Analyzed (Nam) and then Analyzed (Nam)
...@@ -749,8 +748,8 @@ package body Sem_Ch8 is ...@@ -749,8 +748,8 @@ package body Sem_Ch8 is
end if; end if;
end if; end if;
-- An object renaming requires an exact match of the type; -- An object renaming requires an exact match of the type. Class-wide
-- class-wide matching is not allowed. -- matching is not allowed.
if Is_Class_Wide_Type (T) if Is_Class_Wide_Type (T)
and then Base_Type (Etype (Nam)) /= Base_Type (T) and then Base_Type (Etype (Nam)) /= Base_Type (T)
...@@ -822,8 +821,8 @@ package body Sem_Ch8 is ...@@ -822,8 +821,8 @@ package body Sem_Ch8 is
Error_Msg_N ("null-exclusion required in formal " & Error_Msg_N ("null-exclusion required in formal " &
"object declaration", Error_Node); "object declaration", Error_Node);
-- Ada 2005 (AI-423): Otherwise, the subtype of the object -- Ada 2005 (AI-423): Otherwise, the subtype of the object name
-- name shall exclude null. -- shall exclude null.
elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration
and then not Has_Null_Exclusion (Subtyp_Decl) and then not Has_Null_Exclusion (Subtyp_Decl)
...@@ -932,6 +931,7 @@ package body Sem_Ch8 is ...@@ -932,6 +931,7 @@ package body Sem_Ch8 is
Enter_Name (New_P); Enter_Name (New_P);
Analyze (Name (N)); Analyze (Name (N));
if Is_Entity_Name (Name (N)) then if Is_Entity_Name (Name (N)) then
Old_P := Entity (Name (N)); Old_P := Entity (Name (N));
else else
...@@ -1007,8 +1007,10 @@ package body Sem_Ch8 is ...@@ -1007,8 +1007,10 @@ package body Sem_Ch8 is
and then Chars (New_P) = Chars (Generic_Parent (Spec)) and then Chars (New_P) = Chars (Generic_Parent (Spec))
then then
declare declare
E : Entity_Id := First_Entity (Old_P); E : Entity_Id;
begin begin
E := First_Entity (Old_P);
while Present (E) while Present (E)
and then E /= New_P and then E /= New_P
loop loop
...@@ -1136,8 +1138,7 @@ package body Sem_Ch8 is ...@@ -1136,8 +1138,7 @@ package body Sem_Ch8 is
return; return;
end if; end if;
-- Otherwise, find renamed entity, and build body of New_S as a call -- Otherwise find renamed entity and build body of New_S as a call to it
-- to it.
Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S); Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S);
...@@ -1199,6 +1200,7 @@ package body Sem_Ch8 is ...@@ -1199,6 +1200,7 @@ package body Sem_Ch8 is
Generate_Reference (New_S, Defining_Entity (N), 'b'); Generate_Reference (New_S, Defining_Entity (N), 'b');
Style.Check_Identifier (Defining_Entity (N), New_S); Style.Check_Identifier (Defining_Entity (N), New_S);
end if; end if;
else else
Error_Msg_N ("no entry family matches specification", N); Error_Msg_N ("no entry family matches specification", N);
end if; end if;
...@@ -1231,21 +1233,23 @@ package body Sem_Ch8 is ...@@ -1231,21 +1233,23 @@ package body Sem_Ch8 is
Sub : Entity_Id); Sub : Entity_Id);
-- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
-- following AI rules: -- following AI rules:
-- o If Ren is a renaming of a formal subprogram and one of its --
-- parameters has a null exclusion, then the corresponding formal -- If Ren is a renaming of a formal subprogram and one of its
-- in Sub must also have one. Otherwise the subtype of the Sub's -- parameters has a null exclusion, then the corresponding formal
-- formal parameter must exclude null. -- in Sub must also have one. Otherwise the subtype of the Sub's
-- o If Ren is a renaming of a formal function and its retrun -- formal parameter must exclude null.
-- profile has a null exclusion, then Sub's return profile must --
-- have one. Otherwise the subtype of Sub's return profile must -- If Ren is a renaming of a formal function and its retrun
-- exclude null. -- profile has a null exclusion, then Sub's return profile must
-- have one. Otherwise the subtype of Sub's return profile must
-- exclude null.
function Original_Subprogram (Subp : Entity_Id) return Entity_Id; function Original_Subprogram (Subp : Entity_Id) return Entity_Id;
-- Find renamed entity when the declaration is a renaming_as_body -- Find renamed entity when the declaration is a renaming_as_body and
-- and the renamed entity may itself be a renaming_as_body. Used to -- the renamed entity may itself be a renaming_as_body. Used to enforce
-- enforce rule that a renaming_as_body is illegal if the declaration -- rule that a renaming_as_body is illegal if the declaration occurs
-- occurs before the subprogram it completes is frozen, and renaming -- before the subprogram it completes is frozen, and renaming indirectly
-- indirectly renames the subprogram itself.(Defect Report 8652/0027). -- renames the subprogram itself.(Defect Report 8652/0027).
-------------------------- --------------------------
-- Check_Null_Exclusion -- -- Check_Null_Exclusion --
...@@ -1255,12 +1259,14 @@ package body Sem_Ch8 is ...@@ -1255,12 +1259,14 @@ package body Sem_Ch8 is
(Ren : Entity_Id; (Ren : Entity_Id;
Sub : Entity_Id) Sub : Entity_Id)
is is
Ren_Formal : Entity_Id := First_Formal (Ren); Ren_Formal : Entity_Id;
Sub_Formal : Entity_Id := First_Formal (Sub); Sub_Formal : Entity_Id;
begin begin
-- Parameter check -- Parameter check
Ren_Formal := First_Formal (Ren);
Sub_Formal := First_Formal (Sub);
while Present (Ren_Formal) while Present (Ren_Formal)
and then Present (Sub_Formal) and then Present (Sub_Formal)
loop loop
...@@ -1345,15 +1351,15 @@ package body Sem_Ch8 is ...@@ -1345,15 +1351,15 @@ package body Sem_Ch8 is
if Nkind (Nam) = N_Attribute_Reference then if Nkind (Nam) = N_Attribute_Reference then
-- In the case of an abstract formal subprogram association, -- In the case of an abstract formal subprogram association, rewrite
-- rewrite an actual given by a stream attribute as the name -- an actual given by a stream attribute as the name of the
-- of the corresponding stream primitive of the type. -- corresponding stream primitive of the type.
-- In a generic context the stream operations are not generated, -- In a generic context the stream operations are not generated, and
-- and this must be treated as a normal attribute reference, to -- this must be treated as a normal attribute reference, to be
-- be expanded in subsequent instantiations. -- expanded in subsequent instantiations.
if Is_Actual and then Is_Abstract (Formal_Spec) if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec)
and then Expander_Active and then Expander_Active
then then
declare declare
...@@ -1373,10 +1379,10 @@ package body Sem_Ch8 is ...@@ -1373,10 +1379,10 @@ package body Sem_Ch8 is
end if; end if;
-- Retrieve the primitive subprogram associated with the -- Retrieve the primitive subprogram associated with the
-- attribute. This can only be a stream attribute, since -- attribute. This can only be a stream attribute, since those
-- those are the only ones that are dispatching (and the -- are the only ones that are dispatching (and the actual for
-- actual for an abstract formal subprogram must be a -- an abstract formal subprogram must be dispatching
-- dispatching operation). -- operation).
case Attribute_Name (Nam) is case Attribute_Name (Nam) is
when Name_Input => when Name_Input =>
...@@ -1424,13 +1430,13 @@ package body Sem_Ch8 is ...@@ -1424,13 +1430,13 @@ package body Sem_Ch8 is
-- Check whether this declaration corresponds to the instantiation -- Check whether this declaration corresponds to the instantiation
-- of a formal subprogram. -- of a formal subprogram.
-- If this is an instantiation, the corresponding actual is frozen -- If this is an instantiation, the corresponding actual is frozen and
-- and error messages can be made more precise. If this is a default -- error messages can be made more precise. If this is a default
-- subprogram, the entity is already established in the generic, and -- subprogram, the entity is already established in the generic, and is
-- is not retrieved by visibility. If it is a default with a box, the -- not retrieved by visibility. If it is a default with a box, the
-- candidate interpretations, if any, have been collected when building -- candidate interpretations, if any, have been collected when building
-- the renaming declaration. If overloaded, the proper interpretation -- the renaming declaration. If overloaded, the proper interpretation is
-- is determined in Find_Renamed_Entity. If the entity is an operator, -- determined in Find_Renamed_Entity. If the entity is an operator,
-- Find_Renamed_Entity applies additional visibility checks. -- Find_Renamed_Entity applies additional visibility checks.
if Is_Actual then if Is_Actual then
...@@ -1456,9 +1462,9 @@ package body Sem_Ch8 is ...@@ -1456,9 +1462,9 @@ package body Sem_Ch8 is
-- If there is an immediately visible homonym of the operator -- If there is an immediately visible homonym of the operator
-- and the declaration has a default, this is worth a warning -- and the declaration has a default, this is worth a warning
-- because the user probably did not intend to get the pre- -- because the user probably did not intend to get the pre-
-- defined operator, visible in the generic declaration. -- defined operator, visible in the generic declaration. To
-- To find if there is an intended candidate, analyze the -- find if there is an intended candidate, analyze the renaming
-- renaming again in the current context. -- again in the current context.
elsif Scope (Old_S) = Standard_Standard elsif Scope (Old_S) = Standard_Standard
and then Present (Default_Name (Inst_Node)) and then Present (Default_Name (Inst_Node))
...@@ -1545,7 +1551,7 @@ package body Sem_Ch8 is ...@@ -1545,7 +1551,7 @@ package body Sem_Ch8 is
begin begin
Remove (Old_Decl); Remove (Old_Decl);
Insert_After (N, New_Decl); Insert_After (N, New_Decl);
Set_Is_Abstract (Rename_Spec, False); Set_Is_Abstract_Subprogram (Rename_Spec, False);
Set_Analyzed (New_Decl); Set_Analyzed (New_Decl);
end; end;
end if; end if;
...@@ -1638,7 +1644,6 @@ package body Sem_Ch8 is ...@@ -1638,7 +1644,6 @@ package body Sem_Ch8 is
then then
Error_Msg_N ("expect valid subprogram name in renaming", N); Error_Msg_N ("expect valid subprogram name in renaming", N);
return; return;
end if; end if;
-- Most common case: subprogram renames subprogram. No body is generated -- Most common case: subprogram renames subprogram. No body is generated
...@@ -1785,12 +1790,13 @@ package body Sem_Ch8 is ...@@ -1785,12 +1790,13 @@ package body Sem_Ch8 is
-- indicate that the renaming is an abstract dispatching operation -- indicate that the renaming is an abstract dispatching operation
-- with a controlling type. -- with a controlling type.
if Is_Actual and then Is_Abstract (Formal_Spec) then if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) then
-- Mark the renaming as abstract here, so Find_Dispatching_Type -- Mark the renaming as abstract here, so Find_Dispatching_Type
-- see it as corresponding to a generic association for a -- see it as corresponding to a generic association for a
-- formal abstract subprogram -- formal abstract subprogram
Set_Is_Abstract (New_S); Set_Is_Abstract_Subprogram (New_S);
declare declare
New_S_Ctrl_Type : constant Entity_Id := New_S_Ctrl_Type : constant Entity_Id :=
...@@ -1808,10 +1814,9 @@ package body Sem_Ch8 is ...@@ -1808,10 +1814,9 @@ package body Sem_Ch8 is
Set_Is_Dispatching_Operation (New_S); Set_Is_Dispatching_Operation (New_S);
Check_Controlling_Formals (New_S_Ctrl_Type, New_S); Check_Controlling_Formals (New_S_Ctrl_Type, New_S);
-- In the case where the actual in the formal subprogram -- If the actual in the formal subprogram is itself a
-- is itself a formal abstract subprogram association, -- formal abstract subprogram association, there's no
-- there's no dispatch table component or position to -- dispatch table component or position to inherit.
-- inherit.
if Present (DTC_Entity (Old_S)) then if Present (DTC_Entity (Old_S)) then
Set_DTC_Entity (New_S, DTC_Entity (Old_S)); Set_DTC_Entity (New_S, DTC_Entity (Old_S));
...@@ -1831,7 +1836,18 @@ package body Sem_Ch8 is ...@@ -1831,7 +1836,18 @@ package body Sem_Ch8 is
end if; end if;
Set_Convention (New_S, Convention (Old_S)); Set_Convention (New_S, Convention (Old_S));
Set_Is_Abstract (New_S, Is_Abstract (Old_S));
if Is_Abstract_Subprogram (Old_S) then
if Present (Rename_Spec) then
Error_Msg_N
("a renaming-as-body cannot rename an abstract subprogram",
N);
Set_Has_Completion (Rename_Spec);
else
Set_Is_Abstract_Subprogram (New_S);
end if;
end if;
Check_Library_Unit_Renaming (N, Old_S); Check_Library_Unit_Renaming (N, Old_S);
-- Pathological case: procedure renames entry in the scope of its -- Pathological case: procedure renames entry in the scope of its
...@@ -1852,8 +1868,8 @@ package body Sem_Ch8 is ...@@ -1852,8 +1868,8 @@ package body Sem_Ch8 is
-- where the formal subprogram is also abstract. -- where the formal subprogram is also abstract.
if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function) if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function)
and then Is_Abstract (Old_S) and then Is_Abstract_Subprogram (Old_S)
and then not Is_Abstract (Formal_Spec) and then not Is_Abstract_Subprogram (Formal_Spec)
then then
Error_Msg_N Error_Msg_N
("abstract subprogram not allowed as generic actual", Nam); ("abstract subprogram not allowed as generic actual", Nam);
...@@ -1874,7 +1890,6 @@ package body Sem_Ch8 is ...@@ -1874,7 +1890,6 @@ package body Sem_Ch8 is
declare declare
T : constant Entity_Id := T : constant Entity_Id :=
Base_Type (Etype (First_Formal (New_S))); Base_Type (Etype (First_Formal (New_S)));
begin begin
Error_Msg_Node_2 := Prefix (Nam); Error_Msg_Node_2 := Prefix (Nam);
Error_Msg_NE Error_Msg_NE
...@@ -2008,7 +2023,6 @@ package body Sem_Ch8 is ...@@ -2008,7 +2023,6 @@ package body Sem_Ch8 is
-- Loop through package names to identify referenced packages -- Loop through package names to identify referenced packages
Pack_Name := First (Names (N)); Pack_Name := First (Names (N));
while Present (Pack_Name) loop while Present (Pack_Name) loop
Analyze (Pack_Name); Analyze (Pack_Name);
...@@ -2016,9 +2030,10 @@ package body Sem_Ch8 is ...@@ -2016,9 +2030,10 @@ package body Sem_Ch8 is
and then Nkind (Pack_Name) = N_Expanded_Name and then Nkind (Pack_Name) = N_Expanded_Name
then then
declare declare
Pref : Node_Id := Prefix (Pack_Name); Pref : Node_Id;
begin begin
Pref := Prefix (Pack_Name);
while Nkind (Pref) = N_Expanded_Name loop while Nkind (Pref) = N_Expanded_Name loop
Pref := Prefix (Pref); Pref := Prefix (Pref);
end loop; end loop;
...@@ -2038,9 +2053,7 @@ package body Sem_Ch8 is ...@@ -2038,9 +2053,7 @@ package body Sem_Ch8 is
-- use visible. -- use visible.
Pack_Name := First (Names (N)); Pack_Name := First (Names (N));
while Present (Pack_Name) loop while Present (Pack_Name) loop
if Is_Entity_Name (Pack_Name) then if Is_Entity_Name (Pack_Name) then
Pack := Entity (Pack_Name); Pack := Entity (Pack_Name);
...@@ -2068,7 +2081,6 @@ package body Sem_Ch8 is ...@@ -2068,7 +2081,6 @@ package body Sem_Ch8 is
Next (Pack_Name); Next (Pack_Name);
end loop; end loop;
end Analyze_Use_Package; end Analyze_Use_Package;
---------------------- ----------------------
...@@ -2088,7 +2100,6 @@ package body Sem_Ch8 is ...@@ -2088,7 +2100,6 @@ package body Sem_Ch8 is
end if; end if;
Id := First (Subtype_Marks (N)); Id := First (Subtype_Marks (N));
while Present (Id) loop while Present (Id) loop
Find_Type (Id); Find_Type (Id);
...@@ -2173,7 +2184,6 @@ package body Sem_Ch8 is ...@@ -2173,7 +2184,6 @@ package body Sem_Ch8 is
else else
Param_Spec := First (Parameter_Specifications (Spec)); Param_Spec := First (Parameter_Specifications (Spec));
while Present (Param_Spec) loop while Present (Param_Spec) loop
Form_Num := Form_Num + 1; Form_Num := Form_Num + 1;
...@@ -2248,7 +2258,6 @@ package body Sem_Ch8 is ...@@ -2248,7 +2258,6 @@ package body Sem_Ch8 is
-- Note that there is no Expr_List in this case anyway -- Note that there is no Expr_List in this case anyway
if Aname = Name_AST_Entry then if Aname = Name_AST_Entry then
declare declare
Ent : Entity_Id; Ent : Entity_Id;
Decl : Node_Id; Decl : Node_Id;
...@@ -2288,7 +2297,6 @@ package body Sem_Ch8 is ...@@ -2288,7 +2297,6 @@ package body Sem_Ch8 is
-- Case of renaming a function -- Case of renaming a function
if Nkind (Spec) = N_Function_Specification then if Nkind (Spec) = N_Function_Specification then
if Is_Procedure_Attribute_Name (Aname) then if Is_Procedure_Attribute_Name (Aname) then
Error_Msg_N ("attribute can only be renamed as procedure", Nam); Error_Msg_N ("attribute can only be renamed as procedure", Nam);
return; return;
...@@ -2448,8 +2456,7 @@ package body Sem_Ch8 is ...@@ -2448,8 +2456,7 @@ package body Sem_Ch8 is
loop loop
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
-- Protect the frontend against previously reported -- Protect the frontend against previous critical errors
-- critical errors
and then Nkind (Name (Item)) /= N_Selected_Component and then Nkind (Name (Item)) /= N_Selected_Component
and then Entity (Name (Item)) = Pack and then Entity (Name (Item)) = Pack
...@@ -2549,7 +2556,6 @@ package body Sem_Ch8 is ...@@ -2549,7 +2556,6 @@ package body Sem_Ch8 is
begin begin
Id := First_Entity (Current_Scope); Id := First_Entity (Current_Scope);
while Present (Id) loop while Present (Id) loop
-- An entity in the current scope is not necessarily the first one -- An entity in the current scope is not necessarily the first one
-- on its homonym chain. Find its predecessor if any, -- on its homonym chain. Find its predecessor if any,
...@@ -2575,9 +2581,9 @@ package body Sem_Ch8 is ...@@ -2575,9 +2581,9 @@ package body Sem_Ch8 is
Prev := Empty; Prev := Empty;
end if; end if;
Outer := Homonym (Id);
Set_Is_Immediately_Visible (Id, False); Set_Is_Immediately_Visible (Id, False);
Outer := Homonym (Id);
while Present (Outer) and then Scope (Outer) = Current_Scope loop while Present (Outer) and then Scope (Outer) = Current_Scope loop
Outer := Homonym (Outer); Outer := Homonym (Outer);
end loop; end loop;
...@@ -2692,7 +2698,6 @@ package body Sem_Ch8 is ...@@ -2692,7 +2698,6 @@ package body Sem_Ch8 is
F : Entity_Id) return Boolean F : Entity_Id) return Boolean
is is
T : constant Entity_Id := Etype (F); T : constant Entity_Id := Etype (F);
begin begin
return In_Use (T) return In_Use (T)
and then Scope (T) = Scope (Op); and then Scope (T) = Scope (Op);
...@@ -2702,20 +2707,18 @@ package body Sem_Ch8 is ...@@ -2702,20 +2707,18 @@ package body Sem_Ch8 is
begin begin
Pack_Name := First (Names (N)); Pack_Name := First (Names (N));
while Present (Pack_Name) loop while Present (Pack_Name) loop
Pack := Entity (Pack_Name); Pack := Entity (Pack_Name);
if Ekind (Pack) = E_Package then if Ekind (Pack) = E_Package then
if In_Open_Scopes (Pack) then if In_Open_Scopes (Pack) then
null; null;
elsif not Redundant_Use (Pack_Name) then elsif not Redundant_Use (Pack_Name) then
Set_In_Use (Pack, False); Set_In_Use (Pack, False);
Set_Current_Use_Clause (Pack, Empty); Set_Current_Use_Clause (Pack, Empty);
Id := First_Entity (Pack);
Id := First_Entity (Pack);
while Present (Id) loop while Present (Id) loop
-- Preserve use-visibility of operators that are primitive -- Preserve use-visibility of operators that are primitive
...@@ -2756,7 +2759,6 @@ package body Sem_Ch8 is ...@@ -2756,7 +2759,6 @@ package body Sem_Ch8 is
and then Present_System_Aux and then Present_System_Aux
then then
Id := First_Entity (System_Aux_Id); Id := First_Entity (System_Aux_Id);
while Present (Id) loop while Present (Id) loop
Set_Is_Potentially_Use_Visible (Id, False); Set_Is_Potentially_Use_Visible (Id, False);
...@@ -2775,7 +2777,6 @@ package body Sem_Ch8 is ...@@ -2775,7 +2777,6 @@ package body Sem_Ch8 is
else else
Set_Redundant_Use (Pack_Name, False); Set_Redundant_Use (Pack_Name, False);
end if; end if;
end if; end if;
Next (Pack_Name); Next (Pack_Name);
...@@ -2783,7 +2784,6 @@ package body Sem_Ch8 is ...@@ -2783,7 +2784,6 @@ package body Sem_Ch8 is
if Present (Hidden_By_Use_Clause (N)) then if Present (Hidden_By_Use_Clause (N)) then
Elmt := First_Elmt (Hidden_By_Use_Clause (N)); Elmt := First_Elmt (Hidden_By_Use_Clause (N));
while Present (Elmt) loop while Present (Elmt) loop
Set_Is_Immediately_Visible (Node (Elmt)); Set_Is_Immediately_Visible (Node (Elmt));
Next_Elmt (Elmt); Next_Elmt (Elmt);
...@@ -2805,7 +2805,6 @@ package body Sem_Ch8 is ...@@ -2805,7 +2805,6 @@ package body Sem_Ch8 is
begin begin
Id := First (Subtype_Marks (N)); Id := First (Subtype_Marks (N));
while Present (Id) loop while Present (Id) loop
-- A call to rtsfind may occur while analyzing a use_type clause, -- A call to rtsfind may occur while analyzing a use_type clause,
...@@ -2825,9 +2824,9 @@ package body Sem_Ch8 is ...@@ -2825,9 +2824,9 @@ package body Sem_Ch8 is
then then
null; null;
-- Note that the use_Type clause may mention a subtype of the -- Note that the use_Type clause may mention a subtype of the type
-- type whose primitive operations have been made visible. Here -- whose primitive operations have been made visible. Here as
-- as elsewhere, it is the base type that matters for visibility. -- elsewhere, it is the base type that matters for visibility.
elsif In_Open_Scopes (Scope (Base_Type (T))) then elsif In_Open_Scopes (Scope (Base_Type (T))) then
null; null;
...@@ -2836,10 +2835,9 @@ package body Sem_Ch8 is ...@@ -2836,10 +2835,9 @@ package body Sem_Ch8 is
Set_In_Use (T, False); Set_In_Use (T, False);
Set_In_Use (Base_Type (T), False); Set_In_Use (Base_Type (T), False);
Op_List := Collect_Primitive_Operations (T); Op_List := Collect_Primitive_Operations (T);
Elmt := First_Elmt (Op_List);
Elmt := First_Elmt (Op_List);
while Present (Elmt) loop while Present (Elmt) loop
if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then
Set_Is_Potentially_Use_Visible (Node (Elmt), False); Set_Is_Potentially_Use_Visible (Node (Elmt), False);
end if; end if;
...@@ -2924,7 +2922,6 @@ package body Sem_Ch8 is ...@@ -2924,7 +2922,6 @@ package body Sem_Ch8 is
return False; return False;
else else
Inst := Current_Scope; Inst := Current_Scope;
while Present (Inst) while Present (Inst)
and then Ekind (Inst) /= E_Package and then Ekind (Inst) /= E_Package
and then not Is_Generic_Instance (Inst) and then not Is_Generic_Instance (Inst)
...@@ -2937,7 +2934,6 @@ package body Sem_Ch8 is ...@@ -2937,7 +2934,6 @@ package body Sem_Ch8 is
end if; end if;
Act := First_Entity (Inst); Act := First_Entity (Inst);
while Present (Act) loop while Present (Act) loop
if Ekind (Act) = E_Package then if Ekind (Act) = E_Package then
...@@ -3051,16 +3047,16 @@ package body Sem_Ch8 is ...@@ -3051,16 +3047,16 @@ package body Sem_Ch8 is
if Nvis_Is_Private_Subprg then if Nvis_Is_Private_Subprg then
pragma Assert (Nkind (E2) = N_Defining_Identifier pragma Assert (Nkind (E2) = N_Defining_Identifier
and then Ekind (E2) = E_Function and then Ekind (E2) = E_Function
and then Scope (E2) = Standard_Standard and then Scope (E2) = Standard_Standard
and then Has_Private_With (E2)); and then Has_Private_With (E2));
-- Find the sloc corresponding to the private with'ed unit -- Find the sloc corresponding to the private with'ed unit
Comp_Unit := Cunit (Current_Sem_Unit); Comp_Unit := Cunit (Current_Sem_Unit);
Item := First (Context_Items (Comp_Unit));
Error_Msg_Sloc := No_Location; Error_Msg_Sloc := No_Location;
Item := First (Context_Items (Comp_Unit));
while Present (Item) loop while Present (Item) loop
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
and then Private_Present (Item) and then Private_Present (Item)
...@@ -3088,7 +3084,6 @@ package body Sem_Ch8 is ...@@ -3088,7 +3084,6 @@ package body Sem_Ch8 is
Ent := Homonyms; Ent := Homonyms;
while Present (Ent) loop while Present (Ent) loop
if Is_Potentially_Use_Visible (Ent) then if Is_Potentially_Use_Visible (Ent) then
if not Hidden then if not Hidden then
Error_Msg_N ("multiple use clauses cause hiding!", N); Error_Msg_N ("multiple use clauses cause hiding!", N);
Hidden := True; Hidden := True;
...@@ -3134,8 +3129,9 @@ package body Sem_Ch8 is ...@@ -3134,8 +3129,9 @@ package body Sem_Ch8 is
and then and then
Nkind (Parent (Parent (N))) = N_Use_Package_Clause Nkind (Parent (Parent (N))) = N_Use_Package_Clause
then then
Error_Msg_NE Error_Msg_Qual_Level := 99;
("\possible missing with_clause for&", N, Ent); Error_Msg_NE ("\\missing `WITH &;`", N, Ent);
Error_Msg_Qual_Level := 0;
end if; end if;
end if; end if;
...@@ -3152,7 +3148,6 @@ package body Sem_Ch8 is ...@@ -3152,7 +3148,6 @@ package body Sem_Ch8 is
<<Continue>> <<Continue>>
Ent := Homonym (Ent); Ent := Homonym (Ent);
end loop; end loop;
end if; end if;
end Nvis_Messages; end Nvis_Messages;
...@@ -3275,7 +3270,20 @@ package body Sem_Ch8 is ...@@ -3275,7 +3270,20 @@ package body Sem_Ch8 is
-- this is a very common error for beginners to make). -- this is a very common error for beginners to make).
if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then
Error_Msg_N ("\possible missing with of 'Text_'I'O!", N); Error_Msg_N
("\\possible missing `WITH Ada.Text_'I'O; " &
"USE Ada.Text_'I'O`!", N);
-- Another special check if N is the prefix of a selected
-- component which is a known unit, add message complaining
-- about missingw with for this unit.
elsif Nkind (Parent (N)) = N_Selected_Component
and then N = Prefix (Parent (N))
and then Is_Known_Unit (Parent (N))
then
Error_Msg_Node_2 := Selector_Name (Parent (N));
Error_Msg_N ("\\missing `WITH &.&;`", Prefix (Parent (N)));
end if; end if;
-- Now check for possible misspellings -- Now check for possible misspellings
...@@ -3319,10 +3327,10 @@ package body Sem_Ch8 is ...@@ -3319,10 +3327,10 @@ package body Sem_Ch8 is
end; end;
end if; end if;
-- Make entry in undefined references table unless the full -- Make entry in undefined references table unless the full errors
-- errors switch is set, in which case by refraining from -- switch is set, in which case by refraining from generating the
-- generating the table entry, we guarantee that we get an -- table entry, we guarantee that we get an error message for every
-- error message for every undefined reference. -- undefined reference.
if not All_Errors_Mode then if not All_Errors_Mode then
Urefs.Increment_Last; Urefs.Increment_Last;
...@@ -3440,7 +3448,6 @@ package body Sem_Ch8 is ...@@ -3440,7 +3448,6 @@ package body Sem_Ch8 is
begin begin
E2 := Homonym (E); E2 := Homonym (E);
while Present (E2) loop while Present (E2) loop
if Is_Immediately_Visible (E2) then if Is_Immediately_Visible (E2) then
...@@ -3509,10 +3516,10 @@ package body Sem_Ch8 is ...@@ -3509,10 +3516,10 @@ package body Sem_Ch8 is
else else
if In_Instance then if In_Instance then
Inst := Current_Scope;
-- Find current instance -- Find current instance
Inst := Current_Scope;
while Present (Inst) while Present (Inst)
and then Inst /= Standard_Standard and then Inst /= Standard_Standard
loop loop
...@@ -3524,7 +3531,6 @@ package body Sem_Ch8 is ...@@ -3524,7 +3531,6 @@ package body Sem_Ch8 is
end loop; end loop;
E2 := E; E2 := E;
while Present (E2) loop while Present (E2) loop
if From_Actual_Package (E2) if From_Actual_Package (E2)
or else or else
...@@ -3687,10 +3693,10 @@ package body Sem_Ch8 is ...@@ -3687,10 +3693,10 @@ package body Sem_Ch8 is
then then
Premature_Usage (N); Premature_Usage (N);
-- If the entity is overloadable, collect all interpretations -- If the entity is overloadable, collect all interpretations of the
-- of the name for subsequent overload resolution. We optimize -- name for subsequent overload resolution. We optimize a bit here to
-- a bit here to do this only if we have an overloadable entity -- do this only if we have an overloadable entity that is not on its
-- that is not on its own on the homonym chain. -- own on the homonym chain.
elsif Is_Overloadable (E) elsif Is_Overloadable (E)
and then (Present (Homonym (E)) or else Current_Entity (N) /= E) and then (Present (Homonym (E)) or else Current_Entity (N) /= E)
...@@ -3710,11 +3716,11 @@ package body Sem_Ch8 is ...@@ -3710,11 +3716,11 @@ package body Sem_Ch8 is
-- to the discriminant in the initialization procedure. -- to the discriminant in the initialization procedure.
else else
-- Entity is unambiguous, indicate that it is referenced here -- Entity is unambiguous, indicate that it is referenced here One
-- One slightly odd case is that we do not want to set the -- slightly odd case is that we do not want to set the Referenced
-- Referenced flag if the entity is a label, and the identifier -- flag if the entity is a label, and the identifier is the label
-- is the label in the source, since this is not a reference -- in the source, since this is not a reference from the point of
-- from the point of view of the user -- view of the user
if Nkind (Parent (N)) = N_Label then if Nkind (Parent (N)) = N_Label then
declare declare
...@@ -3731,11 +3737,10 @@ package body Sem_Ch8 is ...@@ -3731,11 +3737,10 @@ package body Sem_Ch8 is
Generate_Reference (E, N); Generate_Reference (E, N);
end if; end if;
-- Set Entity, with style check if need be. If this is a -- Set Entity, with style check if need be. For a discriminant
-- discriminant reference, it must be replaced by the -- reference, replace by the corresponding discriminal, i.e. the
-- corresponding discriminal, that is to say the parameter -- parameter of the initialization procedure that corresponds to
-- of the initialization procedure that corresponds to the -- the discriminant. If this replacement is being performed, there
-- discriminant. If this replacement is being performed, there
-- is no style check to perform. -- is no style check to perform.
-- This replacement must not be done if we are currently -- This replacement must not be done if we are currently
...@@ -3754,9 +3759,10 @@ package body Sem_Ch8 is ...@@ -3754,9 +3759,10 @@ package body Sem_Ch8 is
elsif Is_Concurrent_Type (Scope (E)) then elsif Is_Concurrent_Type (Scope (E)) then
declare declare
P : Node_Id := Parent (N); P : Node_Id;
begin begin
P := Parent (N);
while Present (P) while Present (P)
and then Nkind (P) /= N_Parameter_Specification and then Nkind (P) /= N_Parameter_Specification
and then Nkind (P) /= N_Component_Declaration and then Nkind (P) /= N_Component_Declaration
...@@ -3946,12 +3952,15 @@ package body Sem_Ch8 is ...@@ -3946,12 +3952,15 @@ package body Sem_Ch8 is
if Present (Candidate) then if Present (Candidate) then
-- If we know that the unit is a child unit we can give a more
-- accurate error message.
if Is_Child_Unit (Candidate) then if Is_Child_Unit (Candidate) then
-- If the candidate is a private child unit and we are -- If the candidate is a private child unit and we are in
-- in the visible part of a public unit, specialize the -- the visible part of a public unit, specialize the error
-- error message. There might be a private with_clause for -- message. There might be a private with_clause for it,
-- it, but it is not currently active. -- but it is not currently active.
if Is_Private_Descendant (Candidate) if Is_Private_Descendant (Candidate)
and then Ekind (Current_Scope) = E_Package and then Ekind (Current_Scope) = E_Package
...@@ -3959,20 +3968,27 @@ package body Sem_Ch8 is ...@@ -3959,20 +3968,27 @@ package body Sem_Ch8 is
and then not Is_Private_Descendant (Current_Scope) and then not Is_Private_Descendant (Current_Scope)
then then
Error_Msg_N ("private child unit& is not visible here", Error_Msg_N ("private child unit& is not visible here",
Selector); Selector);
-- Normal case where we have a missing with for a child unit
else else
Error_Msg_N Error_Msg_Qual_Level := 99;
("missing with_clause for child unit &", Selector); Error_Msg_NE ("missing `WITH &;`", Selector, Candidate);
Error_Msg_Qual_Level := 0;
end if; end if;
-- Here we don't know that this is a child unit
else else
Error_Msg_NE ("& is not a visible entity of&", N, Selector); Error_Msg_NE ("& is not a visible entity of&", N, Selector);
end if; end if;
else else
-- Within the instantiation of a child unit, the prefix may -- Within the instantiation of a child unit, the prefix may
-- denote the parent instance, but the selector has the -- denote the parent instance, but the selector has the name
-- name of the original child. Find whether we are within -- of the original child. Find whether we are within the
-- the corresponding instance, and get the proper entity, which -- corresponding instance, and get the proper entity, which
-- can only be an enclosing scope. -- can only be an enclosing scope.
if O_Name /= P_Name if O_Name /= P_Name
...@@ -4009,15 +4025,16 @@ package body Sem_Ch8 is ...@@ -4009,15 +4025,16 @@ package body Sem_Ch8 is
end; end;
end if; end if;
if Chars (P_Name) = Name_Ada -- If this is a selection from Ada, System or Interfaces, then
and then Scope (P_Name) = Standard_Standard -- we assume a missing with for the corresponding package.
then
if Is_Known_Unit (N) then
Error_Msg_Node_2 := Selector; Error_Msg_Node_2 := Selector;
Error_Msg_NE ("missing with for `&.&`", N, P_Name); Error_Msg_N ("missing `WITH &.&;`", Prefix (N));
-- If this is a selection from a dummy package, then -- If this is a selection from a dummy package, then suppress
-- suppress the error message, of course the entity -- the error message, of course the entity is missing if the
-- is missing if the package is missing! -- package is missing!
elsif Sloc (Error_Msg_Node_2) = No_Location then elsif Sloc (Error_Msg_Node_2) = No_Location then
null; null;
...@@ -4025,7 +4042,6 @@ package body Sem_Ch8 is ...@@ -4025,7 +4042,6 @@ package body Sem_Ch8 is
-- Here we have the case of an undefined component -- Here we have the case of an undefined component
else else
Error_Msg_NE ("& not declared in&", N, Selector); Error_Msg_NE ("& not declared in&", N, Selector);
-- Check for misspelling of some entity in prefix -- Check for misspelling of some entity in prefix
...@@ -4060,9 +4076,8 @@ package body Sem_Ch8 is ...@@ -4060,9 +4076,8 @@ package body Sem_Ch8 is
and then Is_Compilation_Unit and then Is_Compilation_Unit
(Generic_Parent (Parent (Entity (Prefix (N))))) (Generic_Parent (Parent (Entity (Prefix (N)))))
then then
Error_Msg_NE Error_Msg_Node_2 := Selector;
("\possible missing with clause on child unit&", Error_Msg_N ("\missing `WITH &.&;`", Prefix (N));
N, Selector);
end if; end if;
end if; end if;
end if; end if;
...@@ -4076,10 +4091,10 @@ package body Sem_Ch8 is ...@@ -4076,10 +4091,10 @@ package body Sem_Ch8 is
and then Is_Remote_Access_To_Subprogram_Type (Id) and then Is_Remote_Access_To_Subprogram_Type (Id)
and then Present (Equivalent_Type (Id)) and then Present (Equivalent_Type (Id))
then then
-- If we are not actually generating distribution code (i.e. -- If we are not actually generating distribution code (i.e. the
-- the current PCS is the dummy non-distributed version), then -- current PCS is the dummy non-distributed version), then the
-- the Equivalent_Type will be missing, and Id should be treated -- Equivalent_Type will be missing, and Id should be treated as
-- as a regular access-to-subprogram type. -- a regular access-to-subprogram type.
Id := Equivalent_Type (Id); Id := Equivalent_Type (Id);
Set_Chars (Selector, Chars (Id)); Set_Chars (Selector, Chars (Id));
...@@ -4111,8 +4126,8 @@ package body Sem_Ch8 is ...@@ -4111,8 +4126,8 @@ package body Sem_Ch8 is
and then and then
Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) Nkind (Parent (Parent (N))) /= N_Attribute_Reference))
then then
-- It is an entry call after all, either to the current task -- It is an entry call after all, either to the current task (which
-- (which will deadlock) or to an enclosing task. -- will deadlock) or to an enclosing task.
Analyze_Selected_Component (N); Analyze_Selected_Component (N);
return; return;
...@@ -4121,8 +4136,8 @@ package body Sem_Ch8 is ...@@ -4121,8 +4136,8 @@ package body Sem_Ch8 is
Change_Selected_Component_To_Expanded_Name (N); Change_Selected_Component_To_Expanded_Name (N);
-- Do style check and generate reference, but skip both steps if this -- Do style check and generate reference, but skip both steps if this
-- entity has homonyms, since we may not have the right homonym set -- entity has homonyms, since we may not have the right homonym set yet.
-- yet. The proper homonym will be set during the resolve phase. -- The proper homonym will be set during the resolve phase.
if Has_Homonym (Id) then if Has_Homonym (Id) then
Set_Entity (N, Id); Set_Entity (N, Id);
...@@ -4137,8 +4152,8 @@ package body Sem_Ch8 is ...@@ -4137,8 +4152,8 @@ package body Sem_Ch8 is
Set_Etype (N, Get_Full_View (Etype (Id))); Set_Etype (N, Get_Full_View (Etype (Id)));
end if; end if;
-- If the Ekind of the entity is Void, it means that all homonyms -- If the Ekind of the entity is Void, it means that all homonyms are
-- are hidden from all visibility (RM 8.3(5,14-20)). -- hidden from all visibility (RM 8.3(5,14-20)).
if Ekind (Id) = E_Void then if Ekind (Id) = E_Void then
Premature_Usage (N); Premature_Usage (N);
...@@ -4163,8 +4178,8 @@ package body Sem_Ch8 is ...@@ -4163,8 +4178,8 @@ package body Sem_Ch8 is
H := Homonym (H); H := Homonym (H);
end loop; end loop;
-- If an extension of System is present, collect possible -- If an extension of System is present, collect possible explicit
-- explicit overloadings declared in the extension. -- overloadings declared in the extension.
if Chars (P_Name) = Name_System if Chars (P_Name) = Name_System
and then Scope (P_Name) = Standard_Standard and then Scope (P_Name) = Standard_Standard
...@@ -4187,11 +4202,11 @@ package body Sem_Ch8 is ...@@ -4187,11 +4202,11 @@ package body Sem_Ch8 is
if Nkind (Selector_Name (N)) = N_Operator_Symbol if Nkind (Selector_Name (N)) = N_Operator_Symbol
and then Scope (Id) /= Standard_Standard and then Scope (Id) /= Standard_Standard
then then
-- In addition to user-defined operators in the given scope, -- In addition to user-defined operators in the given scope, there
-- there may be an implicit instance of the predefined -- may be an implicit instance of the predefined operator. The
-- operator. The operator (defined in Standard) is found -- operator (defined in Standard) is found in Has_Implicit_Operator,
-- in Has_Implicit_Operator, and added to the interpretations. -- and added to the interpretations. Procedure Add_One_Interp will
-- Procedure Add_One_Interp will determine which hides which. -- determine which hides which.
if Has_Implicit_Operator (N) then if Has_Implicit_Operator (N) then
null; null;
...@@ -4224,24 +4239,23 @@ package body Sem_Ch8 is ...@@ -4224,24 +4239,23 @@ package body Sem_Ch8 is
-- to this enclosing instance, we know that the default was properly -- to this enclosing instance, we know that the default was properly
-- resolved when analyzing the generic, so we prefer the local -- resolved when analyzing the generic, so we prefer the local
-- candidates to those that are external. This is not always the case -- candidates to those that are external. This is not always the case
-- but is a reasonable heuristic on the use of nested generics. -- but is a reasonable heuristic on the use of nested generics. The
-- The proper solution requires a full renaming model. -- proper solution requires a full renaming model.
function Is_Visible_Operation (Op : Entity_Id) return Boolean; function Is_Visible_Operation (Op : Entity_Id) return Boolean;
-- If the renamed entity is an implicit operator, check whether it is -- If the renamed entity is an implicit operator, check whether it is
-- visible because its operand type is properly visible. This -- visible because its operand type is properly visible. This check
-- check applies to explicit renamed entities that appear in the -- applies to explicit renamed entities that appear in the source in a
-- source in a renaming declaration or a formal subprogram instance, -- renaming declaration or a formal subprogram instance, but not to
-- but not to default generic actuals with a name. -- default generic actuals with a name.
function Report_Overload return Entity_Id; function Report_Overload return Entity_Id;
-- List possible interpretations, and specialize message in the -- List possible interpretations, and specialize message in the
-- case of a generic actual. -- case of a generic actual.
function Within (Inner, Outer : Entity_Id) return Boolean; function Within (Inner, Outer : Entity_Id) return Boolean;
-- Determine whether a candidate subprogram is defined within -- Determine whether a candidate subprogram is defined within the
-- the enclosing instance. If yes, it has precedence over outer -- enclosing instance. If yes, it has precedence over outer candidates.
-- candidates.
------------------------ ------------------------
-- Enclosing_Instance -- -- Enclosing_Instance --
...@@ -4258,9 +4272,7 @@ package body Sem_Ch8 is ...@@ -4258,9 +4272,7 @@ package body Sem_Ch8 is
end if; end if;
S := Scope (Current_Scope); S := Scope (Current_Scope);
while S /= Standard_Standard loop while S /= Standard_Standard loop
if Is_Generic_Instance (S) then if Is_Generic_Instance (S) then
return S; return S;
end if; end if;
...@@ -4335,9 +4347,10 @@ package body Sem_Ch8 is ...@@ -4335,9 +4347,10 @@ package body Sem_Ch8 is
------------ ------------
function Within (Inner, Outer : Entity_Id) return Boolean is function Within (Inner, Outer : Entity_Id) return Boolean is
Sc : Entity_Id := Scope (Inner); Sc : Entity_Id;
begin begin
Sc := Scope (Inner);
while Sc /= Standard_Standard loop while Sc /= Standard_Standard loop
if Sc = Outer then if Sc = Outer then
return True; return True;
...@@ -4392,9 +4405,7 @@ package body Sem_Ch8 is ...@@ -4392,9 +4405,7 @@ package body Sem_Ch8 is
else else
Get_First_Interp (Nam, Ind, It); Get_First_Interp (Nam, Ind, It);
while Present (It.Nam) loop while Present (It.Nam) loop
if Entity_Matches_Spec (It.Nam, New_S) if Entity_Matches_Spec (It.Nam, New_S)
and then Is_Visible_Operation (It.Nam) and then Is_Visible_Operation (It.Nam)
then then
...@@ -4407,17 +4418,13 @@ package body Sem_Ch8 is ...@@ -4407,17 +4418,13 @@ package body Sem_Ch8 is
It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S)); It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S));
if It1 = No_Interp then if It1 = No_Interp then
Inst := Enclosing_Instance; Inst := Enclosing_Instance;
if Present (Inst) then if Present (Inst) then
if Within (It.Nam, Inst) then if Within (It.Nam, Inst) then
return (It.Nam); return (It.Nam);
elsif Within (Old_S, Inst) then elsif Within (Old_S, Inst) then
return (Old_S); return (Old_S);
else else
return Report_Overload; return Report_Overload;
end if; end if;
...@@ -4476,10 +4483,10 @@ package body Sem_Ch8 is ...@@ -4476,10 +4483,10 @@ package body Sem_Ch8 is
if Nkind (P) = N_Error then if Nkind (P) = N_Error then
return; return;
-- If the selector already has an entity, the node has been -- If the selector already has an entity, the node has been constructed
-- constructed in the course of expansion, and is known to be -- in the course of expansion, and is known to be valid. Do not verify
-- valid. Do not verify that it is defined for the type (it may -- that it is defined for the type (it may be a private component used
-- be a private component used in the expansion of record equality). -- in the expansion of record equality).
elsif Present (Entity (Selector_Name (N))) then elsif Present (Entity (Selector_Name (N))) then
...@@ -4566,7 +4573,6 @@ package body Sem_Ch8 is ...@@ -4566,7 +4573,6 @@ package body Sem_Ch8 is
declare declare
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
Decl : constant Node_Id := Declaration_Node (Typ); Decl : constant Node_Id := Declaration_Node (Typ);
begin begin
if Nkind (Decl) = N_Subtype_Declaration if Nkind (Decl) = N_Subtype_Declaration
and then not Analyzed (Decl) and then not Analyzed (Decl)
...@@ -4660,9 +4666,7 @@ package body Sem_Ch8 is ...@@ -4660,9 +4666,7 @@ package body Sem_Ch8 is
begin begin
Get_First_Interp (P, Ind, It); Get_First_Interp (P, Ind, It);
while Present (It.Nam) loop while Present (It.Nam) loop
if In_Open_Scopes (It.Nam) then if In_Open_Scopes (It.Nam) then
if Found then if Found then
Error_Msg_N ( Error_Msg_N (
...@@ -4690,16 +4694,15 @@ package body Sem_Ch8 is ...@@ -4690,16 +4694,15 @@ package body Sem_Ch8 is
else else
-- If no interpretation as an expanded name is possible, it -- If no interpretation as an expanded name is possible, it
-- must be a selected component of a record returned by a -- must be a selected component of a record returned by a
-- function call. Reformat prefix as a function call, the -- function call. Reformat prefix as a function call, the rest
-- rest is done by type resolution. If the prefix is a -- is done by type resolution. If the prefix is procedure or
-- procedure or entry, as is P.X; this is an error. -- entry, as is P.X; this is an error.
if Ekind (P_Name) /= E_Function if Ekind (P_Name) /= E_Function
and then (not Is_Overloaded (P) and then (not Is_Overloaded (P)
or else or else
Nkind (Parent (N)) = N_Procedure_Call_Statement) Nkind (Parent (N)) = N_Procedure_Call_Statement)
then then
-- Prefix may mention a package that is hidden by a local -- Prefix may mention a package that is hidden by a local
-- declaration: let the user know. Scan the full homonym -- declaration: let the user know. Scan the full homonym
-- chain, the candidate package may be anywhere on it. -- chain, the candidate package may be anywhere on it.
...@@ -4824,9 +4827,9 @@ package body Sem_Ch8 is ...@@ -4824,9 +4827,9 @@ package body Sem_Ch8 is
T := Base_Type (Entity (Prefix (N))); T := Base_Type (Entity (Prefix (N)));
-- Case type is not known to be tagged. Its appearance in -- Case type is not known to be tagged. Its appearance in the
-- the prefix of the 'Class attribute indicates that the full -- prefix of the 'Class attribute indicates that the full view
-- view will be tagged. -- will be tagged.
if not Is_Tagged_Type (T) then if not Is_Tagged_Type (T) then
if Ekind (T) = E_Incomplete_Type then if Ekind (T) = E_Incomplete_Type then
...@@ -4844,14 +4847,13 @@ package body Sem_Ch8 is ...@@ -4844,14 +4847,13 @@ package body Sem_Ch8 is
and then not Is_Generic_Type (T) and then not Is_Generic_Type (T)
and then In_Private_Part (Scope (T)) and then In_Private_Part (Scope (T))
then then
-- The Class attribute can be applied to an untagged -- The Class attribute can be applied to an untagged private
-- private type fulfilled by a tagged type prior to -- type fulfilled by a tagged type prior to the full type
-- the full type declaration (but only within the -- declaration (but only within the parent package's private
-- parent package's private part). Create the class-wide -- part). Create the class-wide type now and check that the
-- type now and check that the full type is tagged -- full type is tagged later during its analysis. Note that
-- later during its analysis. Note that we do not -- we do not mark the private type as tagged, unlike the
-- mark the private type as tagged, unlike the case -- case of incomplete types, because the type must still
-- of incomplete types, because the type must still
-- appear untagged to outside units. -- appear untagged to outside units.
if No (Class_Wide_Type (T)) then if No (Class_Wide_Type (T)) then
...@@ -4862,8 +4864,8 @@ package body Sem_Ch8 is ...@@ -4862,8 +4864,8 @@ package body Sem_Ch8 is
Set_Etype (N, Class_Wide_Type (T)); Set_Etype (N, Class_Wide_Type (T));
else else
-- Should we introduce a type Any_Tagged and use -- Should we introduce a type Any_Tagged and use Wrong_Type
-- Wrong_Type here, it would be a bit more consistent??? -- here, it would be a bit more consistent???
Error_Msg_NE Error_Msg_NE
("tagged type required, found}", ("tagged type required, found}",
...@@ -5198,7 +5200,6 @@ package body Sem_Ch8 is ...@@ -5198,7 +5200,6 @@ package body Sem_Ch8 is
-- Start of processing for Has_Implicit_Operator -- Start of processing for Has_Implicit_Operator
begin begin
if Ekind (P) = E_Package if Ekind (P) = E_Package
and then not In_Open_Scopes (P) and then not In_Open_Scopes (P)
then then
...@@ -5214,9 +5215,7 @@ package body Sem_Ch8 is ...@@ -5214,9 +5215,7 @@ package body Sem_Ch8 is
-- array of Boolean type. -- array of Boolean type.
when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor => when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor =>
while Id /= Priv_Id loop while Id /= Priv_Id loop
if Valid_Boolean_Arg (Id) if Valid_Boolean_Arg (Id)
and then Id = Base_Type (Id) and then Id = Base_Type (Id)
then then
...@@ -5230,9 +5229,7 @@ package body Sem_Ch8 is ...@@ -5230,9 +5229,7 @@ package body Sem_Ch8 is
-- Equality: look for any non-limited type (result is Boolean) -- Equality: look for any non-limited type (result is Boolean)
when Name_Op_Eq | Name_Op_Ne => when Name_Op_Eq | Name_Op_Ne =>
while Id /= Priv_Id loop while Id /= Priv_Id loop
if Is_Type (Id) if Is_Type (Id)
and then not Is_Limited_Type (Id) and then not Is_Limited_Type (Id)
and then Id = Base_Type (Id) and then Id = Base_Type (Id)
...@@ -5247,7 +5244,6 @@ package body Sem_Ch8 is ...@@ -5247,7 +5244,6 @@ package body Sem_Ch8 is
-- Comparison operators: scalar type, or array of scalar -- Comparison operators: scalar type, or array of scalar
when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge => when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge =>
while Id /= Priv_Id loop while Id /= Priv_Id loop
if (Is_Scalar_Type (Id) if (Is_Scalar_Type (Id)
or else (Is_Array_Type (Id) or else (Is_Array_Type (Id)
...@@ -5271,7 +5267,6 @@ package body Sem_Ch8 is ...@@ -5271,7 +5267,6 @@ package body Sem_Ch8 is
Name_Op_Multiply | Name_Op_Multiply |
Name_Op_Divide | Name_Op_Divide |
Name_Op_Expon => Name_Op_Expon =>
while Id /= Priv_Id loop while Id /= Priv_Id loop
if Is_Numeric_Type (Id) if Is_Numeric_Type (Id)
and then Id = Base_Type (Id) and then Id = Base_Type (Id)
...@@ -5286,7 +5281,6 @@ package body Sem_Ch8 is ...@@ -5286,7 +5281,6 @@ package body Sem_Ch8 is
-- Concatenation: any one-dimensional array type -- Concatenation: any one-dimensional array type
when Name_Op_Concat => when Name_Op_Concat =>
while Id /= Priv_Id loop while Id /= Priv_Id loop
if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1 if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1
and then Id = Base_Type (Id) and then Id = Base_Type (Id)
...@@ -5302,7 +5296,6 @@ package body Sem_Ch8 is ...@@ -5302,7 +5296,6 @@ package body Sem_Ch8 is
-- subtype of Name_Id that would restrict to operators ??? -- subtype of Name_Id that would restrict to operators ???
when others => null; when others => null;
end case; end case;
-- If we fall through, then we do not have an implicit operator -- If we fall through, then we do not have an implicit operator
...@@ -5354,7 +5347,6 @@ package body Sem_Ch8 is ...@@ -5354,7 +5347,6 @@ package body Sem_Ch8 is
begin begin
if Ekind (Old_S) = E_Operator then if Ekind (Old_S) = E_Operator then
New_F := First_Formal (New_S); New_F := First_Formal (New_S);
while Present (New_F) loop while Present (New_F) loop
...@@ -5414,23 +5406,22 @@ package body Sem_Ch8 is ...@@ -5414,23 +5406,22 @@ package body Sem_Ch8 is
(Clause : Node_Id; (Clause : Node_Id;
Force_Installation : Boolean := False) Force_Installation : Boolean := False)
is is
U : Node_Id := Clause; U : Node_Id;
P : Node_Id; P : Node_Id;
Id : Entity_Id; Id : Entity_Id;
begin begin
U := Clause;
while Present (U) loop while Present (U) loop
-- Case of USE package -- Case of USE package
if Nkind (U) = N_Use_Package_Clause then if Nkind (U) = N_Use_Package_Clause then
P := First (Names (U)); P := First (Names (U));
while Present (P) loop while Present (P) loop
Id := Entity (P); Id := Entity (P);
if Ekind (Id) = E_Package then if Ekind (Id) = E_Package then
if In_Use (Id) then if In_Use (Id) then
Note_Redundant_Use (P); Note_Redundant_Use (P);
...@@ -5448,11 +5439,10 @@ package body Sem_Ch8 is ...@@ -5448,11 +5439,10 @@ package body Sem_Ch8 is
Next (P); Next (P);
end loop; end loop;
-- case of USE TYPE -- Case of USE TYPE
else else
P := First (Subtype_Marks (U)); P := First (Subtype_Marks (U));
while Present (P) loop while Present (P) loop
if not Is_Entity_Name (P) if not Is_Entity_Name (P)
or else No (Entity (P)) or else No (Entity (P))
...@@ -5496,11 +5486,19 @@ package body Sem_Ch8 is ...@@ -5496,11 +5486,19 @@ package body Sem_Ch8 is
-- Determine if given type has components (i.e. is either a record -- Determine if given type has components (i.e. is either a record
-- type or a type that has discriminants). -- type or a type that has discriminants).
--------------------
-- Has_Components --
--------------------
function Has_Components (T1 : Entity_Id) return Boolean is function Has_Components (T1 : Entity_Id) return Boolean is
begin begin
return Is_Record_Type (T1) return Is_Record_Type (T1)
or else (Is_Private_Type (T1) and then Has_Discriminants (T1)) or else (Is_Private_Type (T1) and then Has_Discriminants (T1))
or else (Is_Task_Type (T1) and then Has_Discriminants (T1)); or else (Is_Task_Type (T1) and then Has_Discriminants (T1))
or else (Is_Incomplete_Type (T1)
and then From_With_Type (T1)
and then Present (Non_Limited_View (T1))
and then Is_Record_Type (Non_Limited_View (T1)));
end Has_Components; end Has_Components;
-- Start of processing for Is_Appropriate_For_Record -- Start of processing for Is_Appropriate_For_Record
...@@ -5509,9 +5507,8 @@ package body Sem_Ch8 is ...@@ -5509,9 +5507,8 @@ package body Sem_Ch8 is
return return
Present (T) Present (T)
and then (Has_Components (T) and then (Has_Components (T)
or else (Is_Access_Type (T) or else (Is_Access_Type (T)
and then and then Has_Components (Designated_Type (T))));
Has_Components (Designated_Type (T))));
end Is_Appropriate_For_Record; end Is_Appropriate_For_Record;
--------------- ---------------
...@@ -5845,10 +5842,10 @@ package body Sem_Ch8 is ...@@ -5845,10 +5842,10 @@ package body Sem_Ch8 is
begin begin
-- Within an instance, the analysis of the actual for a formal object -- Within an instance, the analysis of the actual for a formal object
-- does not see the name of the object itself. This is significant -- does not see the name of the object itself. This is significant only
-- only if the object is an aggregate, where its analysis does not do -- if the object is an aggregate, where its analysis does not do any
-- any name resolution on component associations. (see 4717-008). In -- name resolution on component associations. (see 4717-008). In such a
-- such a case, look for the visible homonym on the chain. -- case, look for the visible homonym on the chain.
if In_Instance if In_Instance
and then Present (Homonym (E)) and then Present (Homonym (E))
...@@ -5907,7 +5904,7 @@ package body Sem_Ch8 is ...@@ -5907,7 +5904,7 @@ package body Sem_Ch8 is
The_Unit : Node_Id; The_Unit : Node_Id;
function Find_System (C_Unit : Node_Id) return Entity_Id; function Find_System (C_Unit : Node_Id) return Entity_Id;
-- Scan context clause of compilation unit to find a with_clause -- Scan context clause of compilation unit to find with_clause
-- for System. -- for System.
----------------- -----------------
...@@ -5919,7 +5916,6 @@ package body Sem_Ch8 is ...@@ -5919,7 +5916,6 @@ package body Sem_Ch8 is
begin begin
With_Clause := First (Context_Items (C_Unit)); With_Clause := First (Context_Items (C_Unit));
while Present (With_Clause) loop while Present (With_Clause) loop
if (Nkind (With_Clause) = N_With_Clause if (Nkind (With_Clause) = N_With_Clause
and then Chars (Name (With_Clause)) = Name_System) and then Chars (Name (With_Clause)) = Name_System)
...@@ -6007,21 +6003,20 @@ package body Sem_Ch8 is ...@@ -6007,21 +6003,20 @@ package body Sem_Ch8 is
System_Aux_Id := System_Aux_Id :=
Defining_Entity (Specification (Unit (Cunit (Unum)))); Defining_Entity (Specification (Unit (Cunit (Unum))));
Withn := Make_With_Clause (Loc, Withn :=
Name => Make_With_Clause (Loc,
Make_Expanded_Name (Loc, Name =>
Chars => Chars (System_Aux_Id), Make_Expanded_Name (Loc,
Prefix => Chars => Chars (System_Aux_Id),
New_Reference_To (Scope (System_Aux_Id), Loc), Prefix => New_Reference_To (Scope (System_Aux_Id), Loc),
Selector_Name => Selector_Name => New_Reference_To (System_Aux_Id, Loc)));
New_Reference_To (System_Aux_Id, Loc)));
Set_Entity (Name (Withn), System_Aux_Id); Set_Entity (Name (Withn), System_Aux_Id);
Set_Library_Unit (Withn, Cunit (Unum)); Set_Library_Unit (Withn, Cunit (Unum));
Set_Corresponding_Spec (Withn, System_Aux_Id); Set_Corresponding_Spec (Withn, System_Aux_Id);
Set_First_Name (Withn, True); Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True); Set_Implicit_With (Withn, True);
Insert_After (With_Sys, Withn); Insert_After (With_Sys, Withn);
Mark_Rewrite_Insertion (Withn); Mark_Rewrite_Insertion (Withn);
...@@ -6077,7 +6072,6 @@ package body Sem_Ch8 is ...@@ -6077,7 +6072,6 @@ package body Sem_Ch8 is
end if; end if;
E := First_Entity (S); E := First_Entity (S);
while Present (E) loop while Present (E) loop
if Is_Child_Unit (E) then if Is_Child_Unit (E) then
Set_Is_Immediately_Visible (E, Set_Is_Immediately_Visible (E,
...@@ -6097,9 +6091,7 @@ package body Sem_Ch8 is ...@@ -6097,9 +6091,7 @@ package body Sem_Ch8 is
-- must be restored in any case. Their declarations may appear -- must be restored in any case. Their declarations may appear
-- after the private part of the parent. -- after the private part of the parent.
if not Full_Vis if not Full_Vis then
and then Present (E)
then
while Present (E) loop while Present (E) loop
if Is_Child_Unit (E) then if Is_Child_Unit (E) then
Set_Is_Immediately_Visible (E, Set_Is_Immediately_Visible (E,
...@@ -6171,9 +6163,9 @@ package body Sem_Ch8 is ...@@ -6171,9 +6163,9 @@ package body Sem_Ch8 is
End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause); End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
end if; end if;
-- If the call is from within a compilation unit, as when -- If the call is from within a compilation unit, as when called from
-- called from Rtsfind, make current entries in scope stack -- Rtsfind, make current entries in scope stack invisible while we
-- invisible while we analyze the new unit. -- analyze the new unit.
for J in reverse 0 .. SS_Last loop for J in reverse 0 .. SS_Last loop
exit when Scope_Stack.Table (J).Entity = Standard_Standard exit when Scope_Stack.Table (J).Entity = Standard_Standard
...@@ -6181,8 +6173,8 @@ package body Sem_Ch8 is ...@@ -6181,8 +6173,8 @@ package body Sem_Ch8 is
S := Scope_Stack.Table (J).Entity; S := Scope_Stack.Table (J).Entity;
Set_Is_Immediately_Visible (S, False); Set_Is_Immediately_Visible (S, False);
E := First_Entity (S);
E := First_Entity (S);
while Present (E) loop while Present (E) loop
Set_Is_Immediately_Visible (E, False); Set_Is_Immediately_Visible (E, False);
Next_Entity (E); Next_Entity (E);
...@@ -6205,12 +6197,11 @@ package body Sem_Ch8 is ...@@ -6205,12 +6197,11 @@ package body Sem_Ch8 is
begin begin
if Present (L) then if Present (L) then
Decl := First (L); Decl := First (L);
while Present (Decl) loop while Present (Decl) loop
if Nkind (Decl) = N_Use_Package_Clause then if Nkind (Decl) = N_Use_Package_Clause then
Chain_Use_Clause (Decl); Chain_Use_Clause (Decl);
Pack_Name := First (Names (Decl));
Pack_Name := First (Names (Decl));
while Present (Pack_Name) loop while Present (Pack_Name) loop
Pack := Entity (Pack_Name); Pack := Entity (Pack_Name);
...@@ -6225,8 +6216,8 @@ package body Sem_Ch8 is ...@@ -6225,8 +6216,8 @@ package body Sem_Ch8 is
elsif Nkind (Decl) = N_Use_Type_Clause then elsif Nkind (Decl) = N_Use_Type_Clause then
Chain_Use_Clause (Decl); Chain_Use_Clause (Decl);
Id := First (Subtype_Marks (Decl));
Id := First (Subtype_Marks (Decl));
while Present (Id) loop while Present (Id) loop
if Entity (Id) /= Any_Type then if Entity (Id) /= Any_Type then
Use_One_Type (Id); Use_One_Type (Id);
...@@ -6270,7 +6261,6 @@ package body Sem_Ch8 is ...@@ -6270,7 +6261,6 @@ package body Sem_Ch8 is
if In_Instance then if In_Instance then
Current_Instance := Current_Scope; Current_Instance := Current_Scope;
while not Is_Generic_Instance (Current_Instance) loop while not Is_Generic_Instance (Current_Instance) loop
Current_Instance := Scope (Current_Instance); Current_Instance := Scope (Current_Instance);
end loop; end loop;
...@@ -6314,7 +6304,6 @@ package body Sem_Ch8 is ...@@ -6314,7 +6304,6 @@ package body Sem_Ch8 is
or else Private_With_OK) -- Ada 2005 (AI-262) or else Private_With_OK) -- Ada 2005 (AI-262)
loop loop
Prev := Current_Entity (Id); Prev := Current_Entity (Id);
while Present (Prev) loop while Present (Prev) loop
if Is_Immediately_Visible (Prev) if Is_Immediately_Visible (Prev)
and then (not Is_Overloadable (Prev) and then (not Is_Overloadable (Prev)
...@@ -6327,13 +6316,12 @@ package body Sem_Ch8 is ...@@ -6327,13 +6316,12 @@ package body Sem_Ch8 is
goto Next_Usable_Entity; goto Next_Usable_Entity;
-- A use clause within an instance hides outer global -- A use clause within an instance hides outer global entities,
-- entities, which are not used to resolve local entities -- which are not used to resolve local entities in the
-- in the instance. Note that the predefined entities in -- instance. Note that the predefined entities in Standard
-- Standard could not have been hidden in the generic by -- could not have been hidden in the generic by a use clause,
-- a use clause, and therefore remain visible. Other -- and therefore remain visible. Other compilation units whose
-- compilation units whose entities appear in Standard must -- entities appear in Standard must be hidden in an instance.
-- be hidden in an instance.
-- To determine whether an entity is external to the instance -- To determine whether an entity is external to the instance
-- we compare the scope depth of its scope with that of the -- we compare the scope depth of its scope with that of the
...@@ -6359,13 +6347,12 @@ package body Sem_Ch8 is ...@@ -6359,13 +6347,12 @@ package body Sem_Ch8 is
Append_Elmt (Prev, Hidden_By_Use_Clause (N)); Append_Elmt (Prev, Hidden_By_Use_Clause (N));
end if; end if;
-- A user-defined operator is not use-visible if the -- A user-defined operator is not use-visible if the predefined
-- predefined operator for the type is immediately visible, -- operator for the type is immediately visible, which is the case
-- which is the case if the type of the operand is in an open -- if the type of the operand is in an open scope. This does not
-- scope. This does not apply to user-defined operators that -- apply to user-defined operators that have operands of different
-- have operands of different types, because the predefined -- types, because the predefined mixed mode operations (multiply
-- mixed mode operations (multiplication and division) apply to -- and divide) apply to universal types and do not hide anything.
-- universal types and do not hide anything.
elsif Ekind (Prev) = E_Operator elsif Ekind (Prev) = E_Operator
and then Operator_Matches_Spec (Prev, Id) and then Operator_Matches_Spec (Prev, Id)
...@@ -6401,11 +6388,10 @@ package body Sem_Ch8 is ...@@ -6401,11 +6388,10 @@ package body Sem_Ch8 is
Next_Entity (Id); Next_Entity (Id);
end loop; end loop;
-- Child units are also made use-visible by a use clause, but they -- Child units are also made use-visible by a use clause, but they may
-- may appear after all visible declarations in the parent entity list. -- appear after all visible declarations in the parent entity list.
while Present (Id) loop while Present (Id) loop
if Is_Child_Unit (Id) if Is_Child_Unit (Id)
and then Is_Visible_Child_Unit (Id) and then Is_Visible_Child_Unit (Id)
then then
...@@ -6460,10 +6446,9 @@ package body Sem_Ch8 is ...@@ -6460,10 +6446,9 @@ package body Sem_Ch8 is
elsif not Redundant_Use (Id) then elsif not Redundant_Use (Id) then
Set_In_Use (T); Set_In_Use (T);
Op_List := Collect_Primitive_Operations (T); Op_List := Collect_Primitive_Operations (T);
Elmt := First_Elmt (Op_List);
Elmt := First_Elmt (Op_List);
while Present (Elmt) loop while Present (Elmt) loop
if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol
or else Chars (Node (Elmt)) in Any_Operator_Name) or else Chars (Node (Elmt)) in Any_Operator_Name)
and then not Is_Hidden (Node (Elmt)) and then not Is_Hidden (Node (Elmt))
...@@ -6525,7 +6510,6 @@ package body Sem_Ch8 is ...@@ -6525,7 +6510,6 @@ package body Sem_Ch8 is
procedure Write_Scopes is procedure Write_Scopes is
S : Entity_Id; S : Entity_Id;
begin begin
for J in reverse 1 .. Scope_Stack.Last loop for J in reverse 1 .. Scope_Stack.Last loop
S := Scope_Stack.Table (J).Entity; S := Scope_Stack.Table (J).Entity;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment