-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN;
with Snames; use Snames;
-with Style; use Style;
+with Style;
with Table;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- The renaming operation is intrinsic because the compiler must in
-- fact generate a wrapper for it (6.3.1 (10 1/2)).
- function Applicable_Use (Pack_Name : Node_Id) return Boolean;
- -- Common code to Use_One_Package and Set_Use, to determine whether use
- -- clause must be processed. Pack_Name is an entity name that references
- -- the package in question.
-
procedure Attribute_Renaming (N : Node_Id);
-- Analyze renaming of attribute as subprogram. The renaming declaration N
-- is rewritten as a subprogram body that returns the attribute reference
-- but is a reasonable heuristic on the use of nested generics. The
-- proper solution requires a full renaming model.
- function Has_Implicit_Character_Literal (N : Node_Id) return Boolean;
- -- Find a type derived from Character or Wide_Character in the prefix of N.
- -- Used to resolved qualified names whose selector is a character literal.
-
- function Has_Private_With (E : Entity_Id) return Boolean;
- -- Ada 2005 (AI-262): Determines if the current compilation unit has a
- -- private with on E.
+ function Entity_Of_Unit (U : Node_Id) return Entity_Id;
+ -- Return the appropriate entity for determining which unit has a deeper
+ -- scope: the defining entity for U, unless U is a package instance, in
+ -- which case we retrieve the entity of the instance spec.
procedure Find_Expanded_Name (N : Node_Id);
-- The input is a selected component known to be an expanded name. Verify
-- legality of selector given the scope denoted by prefix, and change node
-- N into a expanded name with a properly set Entity field.
+ function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id;
+ -- 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;
Nam : Node_Id;
-- indicates that the renaming is the one generated for an actual subpro-
-- gram in an instance, for which special visibility checks apply.
+ function Has_Implicit_Character_Literal (N : Node_Id) return Boolean;
+ -- Find a type derived from Character or Wide_Character in the prefix of N.
+ -- Used to resolved qualified names whose selector is a character literal.
+
+ function Has_Private_With (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-262): Determines if the current compilation unit has a
+ -- private with on E.
+
function Has_Implicit_Operator (N : Node_Id) return Boolean;
-- N is an expanded name whose selector is an operator name (e.g. P."+").
-- declarative part contains an implicit declaration of an operator if it
-- specification are discarded and replaced with those of the renamed
-- subprogram, which are then used to recheck the default values.
- function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
- -- Prefix is appropriate for record if it is of a record type, or an access
- -- to such.
-
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 to one
-- of these types.
- 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 from
- -- source and the proper warnings are enabled.
+ function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
+ -- Prefix is appropriate for record if it is of a record type, or an access
+ -- to such.
+
+ function Most_Descendant_Use_Clause
+ (Clause1 : Entity_Id;
+ 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 (P : Entity_Id; N : Node_Id);
+ procedure Use_One_Package
+ (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);
- -- Id is the subtype mark from a use type clause. This procedure makes
+ procedure Use_One_Type
+ (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
-- after previous analysis, and primitive operations are already chained
-- has already established its actual subtype. This is only relevant
-- if the renamed object is an explicit dereference.
+ function Get_Object_Name (Nod : Node_Id) return Node_Id;
+ -- Obtain the name of the object from node Nod which is being renamed by
+ -- the object renaming declaration N.
+
------------------------------
-- Check_Constrained_Object --
------------------------------
begin
if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference)
- and then Is_Composite_Type (Etype (Nam))
- and then not Is_Constrained (Etype (Nam))
- and then not Has_Unknown_Discriminants (Etype (Nam))
+ and then Is_Composite_Type (Typ)
+ and then not Is_Constrained (Typ)
+ and then not Has_Unknown_Discriminants (Typ)
and then Expander_Active
then
-- If Actual_Subtype is already set, nothing to do
null;
-- If a record is limited its size is invariant. This is the case
- -- in particular with record types with an access discirminant
+ -- in particular with record types with an access discriminant
-- that are used in iterators. This is an optimization, but it
-- also prevents typing anomalies when the prefix is further
- -- expanded. Limited types with discriminants are included.
+ -- expanded.
+ -- Note that we cannot just use the Is_Limited_Record flag because
+ -- it does not apply to records with limited components, for which
+ -- this syntactic flag is not set, but whose size is also fixed.
- elsif Is_Limited_Record (Typ)
- or else
- (Ekind (Typ) = E_Limited_Private_Type
- and then Has_Discriminants (Typ)
- and then Is_Access_Type (Etype (First_Discriminant (Typ))))
- then
+ elsif Is_Limited_Type (Typ) then
null;
else
end if;
end Check_Constrained_Object;
+ ---------------------
+ -- Get_Object_Name --
+ ---------------------
+
+ function Get_Object_Name (Nod : Node_Id) return Node_Id is
+ Obj_Nam : Node_Id;
+
+ begin
+ Obj_Nam := Nod;
+ while Present (Obj_Nam) loop
+ if Nkind_In (Obj_Nam, N_Attribute_Reference,
+ N_Explicit_Dereference,
+ N_Indexed_Component,
+ N_Slice)
+ then
+ Obj_Nam := Prefix (Obj_Nam);
+
+ elsif Nkind (Obj_Nam) = N_Selected_Component then
+ Obj_Nam := Selector_Name (Obj_Nam);
+ else
+ exit;
+ end if;
+ end loop;
+
+ return Obj_Nam;
+ end Get_Object_Name;
+
-- Start of processing for Analyze_Object_Renaming
begin
Wrong_Type (Nam, T);
end if;
- T2 := Etype (Nam);
+ -- We must search for an actual subtype here so that the bounds of
+ -- objects of unconstrained types don't get dropped on the floor - such
+ -- as with renamings of formal parameters.
+
+ T2 := Get_Actual_Subtype_If_Available (Nam);
-- Ada 2005 (AI-326): Handle wrong use of incomplete type
elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then
declare
- Nam_Decl : Node_Id;
- Nam_Ent : Entity_Id;
+ Nam_Ent : constant Entity_Id := Entity (Get_Object_Name (Nam));
+ Nam_Decl : constant Node_Id := Declaration_Node (Nam_Ent);
begin
- if Nkind (Nam) = N_Attribute_Reference then
- Nam_Ent := Entity (Prefix (Nam));
- else
- Nam_Ent := Entity (Nam);
- end if;
-
- Nam_Decl := Parent (Nam_Ent);
-
if Has_Null_Exclusion (N)
and then not Has_Null_Exclusion (Nam_Decl)
then
end if;
-- The entity of the renaming declaration needs to reflect whether the
- -- renamed object is volatile. Is_Volatile is set if the renamed object
- -- is volatile in the RM legality sense.
-
- Set_Is_Volatile (Id, Is_Volatile_Object (Nam));
+ -- renamed object is atomic, independent, volatile or VFA. These flags
+ -- are set on the renamed object in the RM legality sense.
- -- Also copy settings of Atomic/Independent/Volatile_Full_Access
-
- if Is_Entity_Name (Nam) then
- Set_Is_Atomic (Id, Is_Atomic (Entity (Nam)));
- Set_Is_Independent (Id, Is_Independent (Entity (Nam)));
- Set_Is_Volatile_Full_Access (Id,
- Is_Volatile_Full_Access (Entity (Nam)));
- end if;
+ Set_Is_Atomic (Id, Is_Atomic_Object (Nam));
+ Set_Is_Independent (Id, Is_Independent_Object (Nam));
+ Set_Is_Volatile (Id, Is_Volatile_Object (Nam));
+ Set_Is_Volatile_Full_Access (Id, Is_Volatile_Full_Access_Object (Nam));
-- Treat as volatile if we just set the Volatile flag
-- AI05-0225: If the renamed entity is a procedure or entry of a
-- protected object, the target object must be a variable.
- if Ekind (Scope (Old_S)) in Protected_Kind
+ if Is_Protected_Type (Scope (Old_S))
and then Ekind (New_S) = E_Procedure
and then not Is_Variable (Prefix (Nam))
then
-- have one. Otherwise the subtype of Sub's return profile must
-- exclude null.
+ procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id);
+ -- Ensure that a SPARK renaming denoted by its entity Subp_Id does not
+ -- declare a primitive operation of a tagged type (SPARK RM 6.1.1(3)).
+
procedure Freeze_Actual_Profile;
-- In Ada 2012, enforce the freezing rule concerning formal incomplete
-- types: a callable entity freezes its profile, unless it has an
end if;
end Check_Null_Exclusion;
+ -------------------------------------
+ -- Check_SPARK_Primitive_Operation --
+ -------------------------------------
+
+ procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id) is
+ Prag : constant Node_Id := SPARK_Pragma (Subp_Id);
+ Typ : Entity_Id;
+
+ begin
+ -- Nothing to do when the subprogram is not subject to SPARK_Mode On
+ -- because this check applies to SPARK code only.
+
+ if not (Present (Prag)
+ and then Get_SPARK_Mode_From_Annotation (Prag) = On)
+ then
+ return;
+
+ -- Nothing to do when the subprogram is not a primitive operation
+
+ elsif not Is_Primitive (Subp_Id) then
+ return;
+ end if;
+
+ Typ := Find_Dispatching_Type (Subp_Id);
+
+ -- Nothing to do when the subprogram is a primitive operation of an
+ -- untagged type.
+
+ if No (Typ) then
+ return;
+ end if;
+
+ -- At this point a renaming declaration introduces a new primitive
+ -- operation for a tagged type.
+
+ Error_Msg_Node_2 := Typ;
+ Error_Msg_NE
+ ("subprogram renaming & cannot declare primitive for type & "
+ & "(SPARK RM 6.1.1(3))", N, Subp_Id);
+ end Check_SPARK_Primitive_Operation;
+
---------------------------
-- Freeze_Actual_Profile --
---------------------------
-- Set SPARK mode from current context
- Set_SPARK_Pragma (New_S, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma (New_S, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (New_S);
Rename_Spec := Find_Corresponding_Spec (N);
Generate_Definition (New_S);
New_Overloaded_Entity (New_S);
- if Is_Entity_Name (Nam)
- and then Is_Intrinsic_Subprogram (Entity (Nam))
+ if not (Is_Entity_Name (Nam)
+ and then Is_Intrinsic_Subprogram (Entity (Nam)))
then
- null;
- else
Check_Delayed_Subprogram (New_S);
end if;
+
+ -- Verify that a SPARK renaming does not declare a primitive
+ -- operation of a tagged type.
+
+ Check_SPARK_Primitive_Operation (New_S);
end if;
-- There is no need for elaboration checks on the new entity, which may
elsif Requires_Overriding (Old_S)
or else
- (Is_Abstract_Subprogram (Old_S)
- and then Present (Find_Dispatching_Type (Old_S))
- and then
- not Is_Abstract_Type (Find_Dispatching_Type (Old_S)))
+ (Is_Abstract_Subprogram (Old_S)
+ and then Present (Find_Dispatching_Type (Old_S))
+ and then not Is_Abstract_Type (Find_Dispatching_Type (Old_S)))
then
Error_Msg_N
("renamed entity cannot be subprogram that requires overriding "
if CW_Actual then
null;
- elsif not Is_Actual or else No (Enclosing_Instance) then
+
+ -- No need for a redundant error message if this is a nested
+ -- instance, unless the current instantiation (of a child unit)
+ -- is a compilation unit, which is not analyzed when the parent
+ -- generic is analyzed.
+
+ elsif not Is_Actual
+ or else No (Enclosing_Instance)
+ or else Is_Compilation_Unit (Current_Scope)
+ then
Check_Mode_Conformant (New_S, Old_S);
end if;
if Old_S_Ctrl_Type /= New_S_Ctrl_Type
or else No (New_S_Ctrl_Type)
then
- Error_Msg_NE
- ("actual must be dispatching subprogram for type&",
- Nam, New_S_Ctrl_Type);
+ if No (New_S_Ctrl_Type) then
+ Error_Msg_N
+ ("actual must be dispatching subprogram", Nam);
+ else
+ Error_Msg_NE
+ ("actual must be dispatching subprogram for type&",
+ Nam, New_S_Ctrl_Type);
+ end if;
else
Set_Is_Dispatching_Operation (New_S);
Analyze (N);
end if;
end if;
+
+ -- Check if we are looking at an Ada 2012 defaulted formal subprogram
+ -- and mark any use_package_clauses that affect the visibility of the
+ -- implicit generic actual.
+
+ -- Also, we may be looking at an internal renaming of a user-defined
+ -- subprogram created for a generic formal subprogram association,
+ -- which will also have to be marked here. This can occur when the
+ -- corresponding formal subprogram contains references to other generic
+ -- formals.
+
+ if Is_Generic_Actual_Subprogram (New_S)
+ and then (Is_Intrinsic_Subprogram (New_S)
+ or else From_Default (N)
+ or else Nkind (N) = N_Subprogram_Renaming_Declaration)
+ then
+ Mark_Use_Clauses (New_S);
+
+ -- Handle overloaded subprograms
+
+ if Present (Alias (New_S)) then
+ Mark_Use_Clauses (Alias (New_S));
+ end if;
+ end if;
end Analyze_Subprogram_Renaming;
-------------------------
-- use. If the package is an open scope, i.e. if the use clause occurs
-- within the package itself, ignore it.
- procedure Analyze_Use_Package (N : Node_Id) is
- Ghost_Id : Entity_Id := Empty;
- Living_Id : Entity_Id := Empty;
- Pack : Entity_Id;
- Pack_Name : Node_Id;
+ 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
+
+ procedure Analyze_Package_Name_List (Head_Clause : Node_Id);
+ -- Similar to Analyze_Package_Name but iterates over all the names
+ -- in a use clause.
+
+ --------------------------
+ -- Analyze_Package_Name --
+ --------------------------
+
+ procedure Analyze_Package_Name (Clause : Node_Id) is
+ Pack : constant Node_Id := Name (Clause);
+ Pref : Node_Id;
+
+ begin
+ pragma Assert (Nkind (Clause) = N_Use_Package_Clause);
+ Analyze (Pack);
+
+ -- Verify that the package standard is not directly named in a
+ -- use_package_clause.
+
+ if Nkind (Parent (Clause)) = N_Compilation_Unit
+ and then Nkind (Pack) = N_Expanded_Name
+ then
+ Pref := Prefix (Pack);
+
+ while Nkind (Pref) = N_Expanded_Name loop
+ Pref := Prefix (Pref);
+ end loop;
+
+ if Entity (Pref) = Standard_Standard then
+ Error_Msg_N
+ ("predefined package Standard cannot appear in a context "
+ & "clause", Pref);
+ end if;
+ end if;
+ end Analyze_Package_Name;
+
+ -------------------------------
+ -- Analyze_Package_Name_List --
+ -------------------------------
+
+ procedure Analyze_Package_Name_List (Head_Clause : Node_Id) is
+ Curr : Node_Id;
+
+ begin
+ -- Due to the way source use clauses are split during parsing we are
+ -- forced to simply iterate through all entities in scope until the
+ -- clause representing the last name in the list is found.
+
+ Curr := Head_Clause;
+ while Present (Curr) loop
+ Analyze_Package_Name (Curr);
+
+ -- Stop iterating over the names in the use clause when we are at
+ -- the last one.
+
+ exit when not More_Ids (Curr) and then Prev_Ids (Curr);
+ Next (Curr);
+ end loop;
+ end Analyze_Package_Name_List;
+
+ -- Local variables
+
+ Pack : Entity_Id;
+
+ -- Start of processing for Analyze_Use_Package
begin
Check_SPARK_05_Restriction ("use clause is not allowed", N);
Error_Msg_N ("use clause not allowed in predefined spec", N);
end if;
- -- Chain clause to list of use clauses in current scope
-
- if Nkind (Parent (N)) /= N_Compilation_Unit then
- Chain_Use_Clause (N);
- end if;
-
- -- Loop through package names to identify referenced packages
-
- Pack_Name := First (Names (N));
- while Present (Pack_Name) loop
- Analyze (Pack_Name);
-
- if Nkind (Parent (N)) = N_Compilation_Unit
- and then Nkind (Pack_Name) = N_Expanded_Name
- then
- declare
- Pref : Node_Id;
-
- begin
- Pref := Prefix (Pack_Name);
- while Nkind (Pref) = N_Expanded_Name loop
- Pref := Prefix (Pref);
- end loop;
-
- if Entity (Pref) = Standard_Standard then
- Error_Msg_N
- ("predefined package Standard cannot appear in a context "
- & "clause", Pref);
- end if;
- end;
- end if;
-
- Next (Pack_Name);
- end loop;
-
- -- Loop through package names to mark all entities as potentially use
- -- visible.
+ -- Loop through all package names from the original use clause in
+ -- order to analyze referenced packages. A use_package_clause with only
+ -- one name does not have More_Ids or Prev_Ids set, while a clause with
+ -- More_Ids only starts the chain produced by the parser.
- Pack_Name := First (Names (N));
- while Present (Pack_Name) loop
- if Is_Entity_Name (Pack_Name) then
- Pack := Entity (Pack_Name);
+ if not More_Ids (N) and then not Prev_Ids (N) then
+ Analyze_Package_Name (N);
- 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",
- Pack_Name);
+ elsif More_Ids (N) and then not Prev_Ids (N) then
+ Analyze_Package_Name_List (N);
+ end if;
- elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package)
- then
- Error_Msg_N -- CODEFIX
- ("a generic subprogram is not allowed in a use clause",
- Pack_Name);
+ if not Is_Entity_Name (Name (N)) then
+ Error_Msg_N ("& is not a package", Name (N));
- elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then
- Error_Msg_N -- CODEFIX
- ("a subprogram is not allowed in a use clause",
- Pack_Name);
+ return;
+ end if;
- else
- Error_Msg_N ("& is not allowed in a use clause", Pack_Name);
- end if;
+ if Chain then
+ Chain_Use_Clause (N);
+ end if;
- else
- if Nkind (Parent (N)) = N_Compilation_Unit then
- Check_In_Previous_With_Clause (N, Pack_Name);
- end if;
+ Pack := Entity (Name (N));
- if Applicable_Use (Pack_Name) then
- Use_One_Package (Pack, N);
- end if;
+ -- 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.
- -- Capture the first Ghost package and the first living package
+ if Ekind (Pack) = E_Package
+ and then Present (Current_Use_Clause (Pack))
+ and then Current_Use_Clause (Pack) /= N
+ and then No (Prev_Use_Clause (N))
+ and then Prev_Use_Clause (Current_Use_Clause (Pack)) /= N
+ then
+ Set_Prev_Use_Clause (N, Current_Use_Clause (Pack));
+ end if;
- if Is_Entity_Name (Pack_Name) then
- Pack := Entity (Pack_Name);
+ -- Mark all entities as potentially use visible.
- if Is_Ghost_Entity (Pack) then
- if No (Ghost_Id) then
- Ghost_Id := Pack;
- end if;
+ 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));
- elsif No (Living_Id) then
- Living_Id := Pack;
- end if;
- end if;
- end if;
+ elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package)
+ then
+ Error_Msg_N -- CODEFIX
+ ("a generic subprogram is not allowed in a use clause",
+ Name (N));
- -- Report error because name denotes something other than a package
+ 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));
else
- Error_Msg_N ("& is not a package", Pack_Name);
+ Error_Msg_N ("& is not allowed in a use clause", Name (N));
end if;
- Next (Pack_Name);
- end loop;
-
- -- Detect a mixture of Ghost packages and living packages within the
- -- same use package clause. Ideally one would split a use package clause
- -- with multiple names into multiple use package clauses with a single
- -- name, however clients of the front end would have to adapt to this
- -- change.
-
- if Present (Ghost_Id) and then Present (Living_Id) then
- Error_Msg_N
- ("use clause cannot mention ghost and non-ghost ghost units", N);
-
- Error_Msg_Sloc := Sloc (Ghost_Id);
- Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
+ else
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Check_In_Previous_With_Clause (N, Name (N));
+ end if;
- Error_Msg_Sloc := Sloc (Living_Id);
- Error_Msg_NE ("\& # declared as non-ghost", N, Living_Id);
+ Use_One_Package (N, Name (N));
end if;
Mark_Ghost_Clause (N);
-- Analyze_Use_Type --
----------------------
- procedure Analyze_Use_Type (N : Node_Id) is
- E : Entity_Id;
- Ghost_Id : Entity_Id := Empty;
- Id : Node_Id;
- Living_Id : Entity_Id := Empty;
+ procedure Analyze_Use_Type (N : Node_Id; Chain : Boolean := True) is
+ E : Entity_Id;
+ Id : Node_Id;
begin
Set_Hidden_By_Use_Clause (N, No_Elist);
- -- Chain clause to list of use clauses in current scope
+ -- Chain clause to list of use clauses in current scope when flagged
- if Nkind (Parent (N)) /= N_Compilation_Unit then
+ if Chain then
Chain_Use_Clause (N);
end if;
+ -- Obtain the base type of the type denoted within the use_type_clause's
+ -- subtype mark.
+
+ Id := Subtype_Mark (N);
+ Find_Type (Id);
+ E := Base_Type (Entity (Id));
+
+ -- There are many cases where a use_type_clause may be reanalyzed due to
+ -- manipulation of the scope stack so we much guard against those cases
+ -- here, otherwise, we must add the new use_type_clause to the previous
+ -- use_type_clause chain in order to mark redundant use_type_clauses as
+ -- used. When the redundant use-type clauses appear in a parent unit and
+ -- a child unit we must prevent a circularity in the chain that would
+ -- otherwise result from the separate steps of analysis and installation
+ -- of the parent context.
+
+ if Present (Current_Use_Clause (E))
+ and then Current_Use_Clause (E) /= N
+ and then Prev_Use_Clause (Current_Use_Clause (E)) /= N
+ and then No (Prev_Use_Clause (N))
+ then
+ Set_Prev_Use_Clause (N, Current_Use_Clause (E));
+ end if;
+
-- If the Used_Operations list is already initialized, the clause has
-- been analyzed previously, and it is being reinstalled, for example
-- when the clause appears in a package spec and we are compiling the
if Present (Used_Operations (N)) then
declare
- Mark : Node_Id;
Elmt : Elmt_Id;
begin
- Mark := First (Subtype_Marks (N));
- while Present (Mark) loop
- Use_One_Type (Mark, Installed => True);
- Next (Mark);
- end loop;
+ Use_One_Type (Subtype_Mark (N), Installed => True);
Elmt := First_Elmt (Used_Operations (N));
while Present (Elmt) loop
-- made use-visible by the clause.
Set_Used_Operations (N, New_Elmt_List);
- Id := First (Subtype_Marks (N));
- while Present (Id) loop
- Find_Type (Id);
- E := Entity (Id);
-
- if E /= Any_Type then
- Use_One_Type (Id);
+ E := Entity (Id);
- if Nkind (Parent (N)) = N_Compilation_Unit then
- if Nkind (Id) = N_Identifier then
- Error_Msg_N ("type is not directly visible", Id);
-
- elsif Is_Child_Unit (Scope (E))
- and then Scope (E) /= System_Aux_Id
- then
- Check_In_Previous_With_Clause (N, Prefix (Id));
- end if;
- end if;
+ if E /= Any_Type then
+ Use_One_Type (Id);
- else
- -- If the use_type_clause appears in a compilation unit context,
- -- check whether it comes from a unit that may appear in a
- -- limited_with_clause, for a better error message.
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ if Nkind (Id) = N_Identifier then
+ Error_Msg_N ("type is not directly visible", Id);
- if Nkind (Parent (N)) = N_Compilation_Unit
- and then Nkind (Id) /= N_Identifier
+ elsif Is_Child_Unit (Scope (E))
+ and then Scope (E) /= System_Aux_Id
then
- declare
- Item : Node_Id;
- Pref : Node_Id;
-
- function Mentioned (Nam : Node_Id) return Boolean;
- -- Check whether the prefix of expanded name for the type
- -- appears in the prefix of some limited_with_clause.
-
- ---------------
- -- Mentioned --
- ---------------
-
- function Mentioned (Nam : Node_Id) return Boolean is
- begin
- return Nkind (Name (Item)) = N_Selected_Component
- and then Chars (Prefix (Name (Item))) = Chars (Nam);
- end Mentioned;
-
- begin
- Pref := Prefix (Id);
- Item := First (Context_Items (Parent (N)));
- while Present (Item) and then Item /= N loop
- if Nkind (Item) = N_With_Clause
- and then Limited_Present (Item)
- and then Mentioned (Pref)
- then
- Change_Error_Text
- (Get_Msg_Id, "premature usage of incomplete type");
- end if;
-
- Next (Item);
- end loop;
- end;
+ Check_In_Previous_With_Clause (N, Prefix (Id));
end if;
end if;
- -- Capture the first Ghost type and the first living type
-
- if Is_Ghost_Entity (E) then
- if No (Ghost_Id) then
- Ghost_Id := E;
- end if;
+ else
+ -- If the use_type_clause appears in a compilation unit context,
+ -- check whether it comes from a unit that may appear in a
+ -- limited_with_clause, for a better error message.
- elsif No (Living_Id) then
- Living_Id := E;
- end if;
+ if Nkind (Parent (N)) = N_Compilation_Unit
+ and then Nkind (Id) /= N_Identifier
+ then
+ declare
+ Item : Node_Id;
+ Pref : Node_Id;
- Next (Id);
- end loop;
+ function Mentioned (Nam : Node_Id) return Boolean;
+ -- Check whether the prefix of expanded name for the type
+ -- appears in the prefix of some limited_with_clause.
- -- Detect a mixture of Ghost types and living types within the same use
- -- type clause. Ideally one would split a use type clause with multiple
- -- marks into multiple use type clauses with a single mark, however
- -- clients of the front end will have to adapt to this change.
+ ---------------
+ -- Mentioned --
+ ---------------
- if Present (Ghost_Id) and then Present (Living_Id) then
- Error_Msg_N
- ("use clause cannot mention ghost and non-ghost ghost types", N);
+ function Mentioned (Nam : Node_Id) return Boolean is
+ begin
+ return Nkind (Name (Item)) = N_Selected_Component
+ and then Chars (Prefix (Name (Item))) = Chars (Nam);
+ end Mentioned;
- Error_Msg_Sloc := Sloc (Ghost_Id);
- Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
+ begin
+ Pref := Prefix (Id);
+ Item := First (Context_Items (Parent (N)));
+ while Present (Item) and then Item /= N loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Mentioned (Pref)
+ then
+ Change_Error_Text
+ (Get_Msg_Id, "premature usage of incomplete type");
+ end if;
- Error_Msg_Sloc := Sloc (Living_Id);
- Error_Msg_NE ("\& # declared as non-ghost", N, Living_Id);
+ Next (Item);
+ end loop;
+ end;
+ end if;
end if;
Mark_Ghost_Clause (N);
end Analyze_Use_Type;
- --------------------
- -- Applicable_Use --
- --------------------
-
- function Applicable_Use (Pack_Name : Node_Id) return Boolean is
- Pack : constant Entity_Id := Entity (Pack_Name);
-
- begin
- if In_Open_Scopes (Pack) then
- if Warn_On_Redundant_Constructs and then Pack = Current_Scope then
- Error_Msg_NE -- CODEFIX
- ("& is already use-visible within itself?r?", Pack_Name, Pack);
- end if;
-
- return False;
-
- elsif In_Use (Pack) then
- Note_Redundant_Use (Pack_Name);
- return False;
-
- elsif Present (Renamed_Object (Pack))
- and then In_Use (Renamed_Object (Pack))
- then
- Note_Redundant_Use (Pack_Name);
- return False;
-
- else
- return True;
- end if;
- end Applicable_Use;
-
------------------------
-- Attribute_Renaming --
------------------------
Statements => New_List (Attr_Node)));
end if;
+ -- Signal the ABE mechanism that the generated subprogram body has not
+ -- ABE ramifications.
+
+ Set_Was_Attribute_Reference (Body_Node);
+
-- In case of tagged types we add the body of the generated function to
-- the freezing actions of the type (because in the general case such
-- type is still not frozen). We exclude from this processing generic
-- after the instantiation itself, and thus look like a bogus case
-- of access before elaboration.
- Set_Suppress_Elaboration_Warnings (New_S);
-
+ if Legacy_Elaboration_Checks then
+ Set_Suppress_Elaboration_Warnings (New_S);
+ end if;
end Attribute_Renaming;
----------------------
----------------------
procedure Chain_Use_Clause (N : Node_Id) is
- Pack : Entity_Id;
Level : Int := Scope_Stack.Last;
+ Pack : Entity_Id;
begin
+ -- Common case
+
if not Is_Compilation_Unit (Current_Scope)
or else not Is_Child_Unit (Current_Scope)
then
- null; -- Common case
+ null;
+
+ -- Common case for compilation unit
elsif Defining_Entity (Parent (N)) = Current_Scope then
- null; -- Common case for compilation unit
+ null;
else
-- If declaration appears in some other scope, it must be in some
-- parent unit when compiling a child.
Pack := Defining_Entity (Parent (N));
+
if not In_Open_Scopes (Pack) then
- null; -- default as well
+ null;
-- If the use clause appears in an ancestor and we are in the
-- private part of the immediate parent, the use clauses are
Analyze (B_Node);
end if;
- if Is_Intrinsic_Subprogram (Old_S) and then not In_Instance then
+ if Is_Intrinsic_Subprogram (Old_S)
+ and then not In_Instance
+ and then not Relaxed_RM_Semantics
+ then
Error_Msg_N
("subprogram used in renaming_as_body cannot be intrinsic",
Name (N));
---------------------
procedure End_Use_Clauses (Clause : Node_Id) is
- U : Node_Id;
+ U : Node_Id;
begin
- -- Remove Use_Type clauses first, because they affect the
- -- visibility of operators in subsequent used packages.
+ -- Remove use_type_clauses first, because they affect the visibility of
+ -- operators in subsequent used packages.
U := Clause;
while Present (U) loop
---------------------
procedure End_Use_Package (N : Node_Id) is
- Pack_Name : Node_Id;
Pack : Entity_Id;
+ Pack_Name : Node_Id;
Id : Entity_Id;
Elmt : Elmt_Id;
-- Start of processing for End_Use_Package
begin
- Pack_Name := First (Names (N));
- while Present (Pack_Name) loop
+ Pack_Name := Name (N);
- -- Test that Pack_Name actually denotes a package before processing
+ -- Test that Pack_Name actually denotes a package before processing
- if Is_Entity_Name (Pack_Name)
- and then Ekind (Entity (Pack_Name)) = E_Package
- then
- Pack := Entity (Pack_Name);
+ if Is_Entity_Name (Pack_Name)
+ and then Ekind (Entity (Pack_Name)) = E_Package
+ then
+ Pack := Entity (Pack_Name);
- if In_Open_Scopes (Pack) then
- null;
+ if In_Open_Scopes (Pack) then
+ null;
- elsif not Redundant_Use (Pack_Name) then
- Set_In_Use (Pack, False);
- Set_Current_Use_Clause (Pack, Empty);
+ elsif not Redundant_Use (Pack_Name) then
+ Set_In_Use (Pack, False);
+ Set_Current_Use_Clause (Pack, Empty);
- Id := First_Entity (Pack);
- while Present (Id) loop
+ Id := First_Entity (Pack);
+ while Present (Id) loop
- -- Preserve use-visibility of operators that are primitive
- -- operators of a type that is use-visible through an active
- -- use_type clause.
+ -- Preserve use-visibility of operators that are primitive
+ -- operators of a type that is use-visible through an active
+ -- use_type_clause.
- if Nkind (Id) = N_Defining_Operator_Symbol
- and then
- (Is_Primitive_Operator_In_Use (Id, First_Formal (Id))
- or else
- (Present (Next_Formal (First_Formal (Id)))
- and then
- Is_Primitive_Operator_In_Use
- (Id, Next_Formal (First_Formal (Id)))))
- then
- null;
- else
- Set_Is_Potentially_Use_Visible (Id, False);
- end if;
+ if Nkind (Id) = N_Defining_Operator_Symbol
+ and then
+ (Is_Primitive_Operator_In_Use (Id, First_Formal (Id))
+ or else
+ (Present (Next_Formal (First_Formal (Id)))
+ and then
+ Is_Primitive_Operator_In_Use
+ (Id, Next_Formal (First_Formal (Id)))))
+ then
+ null;
+ else
+ Set_Is_Potentially_Use_Visible (Id, False);
+ end if;
+
+ if Is_Private_Type (Id)
+ and then Present (Full_View (Id))
+ then
+ Set_Is_Potentially_Use_Visible (Full_View (Id), False);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ if Present (Renamed_Object (Pack)) then
+ Set_In_Use (Renamed_Object (Pack), False);
+ Set_Current_Use_Clause (Renamed_Object (Pack), Empty);
+ end if;
+
+ if Chars (Pack) = Name_System
+ and then Scope (Pack) = Standard_Standard
+ and then Present_System_Aux
+ then
+ Id := First_Entity (System_Aux_Id);
+ while Present (Id) loop
+ Set_Is_Potentially_Use_Visible (Id, False);
if Is_Private_Type (Id)
and then Present (Full_View (Id))
Next_Entity (Id);
end loop;
- if Present (Renamed_Object (Pack)) then
- Set_In_Use (Renamed_Object (Pack), False);
- Set_Current_Use_Clause (Renamed_Object (Pack), Empty);
- end if;
-
- if Chars (Pack) = Name_System
- and then Scope (Pack) = Standard_Standard
- and then Present_System_Aux
- then
- Id := First_Entity (System_Aux_Id);
- while Present (Id) loop
- Set_Is_Potentially_Use_Visible (Id, False);
-
- if Is_Private_Type (Id)
- and then Present (Full_View (Id))
- then
- Set_Is_Potentially_Use_Visible (Full_View (Id), False);
- end if;
-
- Next_Entity (Id);
- end loop;
-
- Set_In_Use (System_Aux_Id, False);
- end if;
-
- else
- Set_Redundant_Use (Pack_Name, False);
+ Set_In_Use (System_Aux_Id, False);
end if;
+ else
+ Set_Redundant_Use (Pack_Name, False);
end if;
-
- Next (Pack_Name);
- end loop;
+ end if;
if Present (Hidden_By_Use_Clause (N)) then
Elmt := First_Elmt (Hidden_By_Use_Clause (N));
------------------
procedure End_Use_Type (N : Node_Id) is
- Elmt : Elmt_Id;
- Id : Entity_Id;
- T : Entity_Id;
+ Elmt : Elmt_Id;
+ Id : Entity_Id;
+ T : Entity_Id;
-- Start of processing for End_Use_Type
begin
- Id := First (Subtype_Marks (N));
- while Present (Id) loop
-
- -- A call to Rtsfind may occur while analyzing a use_type clause,
- -- in which case the type marks are not resolved yet, and there is
- -- nothing to remove.
+ Id := Subtype_Mark (N);
- if not Is_Entity_Name (Id) or else No (Entity (Id)) then
- goto Continue;
- end if;
+ -- A call to Rtsfind may occur while analyzing a use_type_clause, in
+ -- which case the type marks are not resolved yet, so guard against that
+ -- here.
+ if Is_Entity_Name (Id) and then Present (Entity (Id)) then
T := Entity (Id);
if T = Any_Type or else From_Limited_With (T) then
null;
- -- Note that the use_type clause may mention a subtype of the type
+ -- Note that the use_type_clause may mention a subtype of the type
-- whose primitive operations have been made visible. Here as
-- elsewhere, it is the base type that matters for visibility.
Set_In_Use (Base_Type (T), False);
Set_Current_Use_Clause (T, Empty);
Set_Current_Use_Clause (Base_Type (T), Empty);
- end if;
- <<Continue>>
- Next (Id);
- end loop;
+ -- See Use_One_Type for the rationale. This is a bit on the naive
+ -- side, but should be good enough in practice.
+
+ if Is_Tagged_Type (T) then
+ Set_In_Use (Class_Wide_Type (T), False);
+ end if;
+ end if;
+ end if;
if Is_Empty_Elmt_List (Used_Operations (N)) then
return;
end if;
end End_Use_Type;
+ --------------------
+ -- Entity_Of_Unit --
+ --------------------
+
+ function Entity_Of_Unit (U : Node_Id) return Entity_Id is
+ begin
+ if Nkind (U) = N_Package_Instantiation and then Analyzed (U) then
+ return Defining_Entity (Instance_Spec (U));
+ else
+ return Defining_Entity (U);
+ end if;
+ end Entity_Of_Unit;
+
----------------------
-- Find_Direct_Name --
----------------------
- procedure Find_Direct_Name (N : Node_Id) is
+ procedure Find_Direct_Name
+ (N : Node_Id;
+ Errors_OK : Boolean := True;
+ Marker_OK : Boolean := True;
+ Reference_OK : Boolean := True)
+ is
E : Entity_Id;
E2 : Entity_Id;
Msg : Boolean;
Item : Node_Id;
begin
+ if not Errors_OK then
+ return;
+ end if;
+
-- Ada 2005 (AI-262): Generate a precise error concerning the
-- Beaujolais effect that was previously detected
-- Named aggregate should also be handled similarly ???
- if Nkind (N) = N_Identifier
+ if Errors_OK
+ and then Nkind (N) = N_Identifier
and then Nkind (Parent (N)) = N_Case_Statement_Alternative
then
declare
Set_Entity (N, Any_Id);
Set_Etype (N, Any_Type);
- -- We use the table Urefs to keep track of entities for which we
- -- have issued errors for undefined references. Multiple errors
- -- for a single name are normally suppressed, however we modify
- -- the error message to alert the programmer to this effect.
+ if Errors_OK then
- for J in Urefs.First .. Urefs.Last loop
- if Chars (N) = Chars (Urefs.Table (J).Node) then
- if Urefs.Table (J).Err /= No_Error_Msg
- and then Sloc (N) /= Urefs.Table (J).Loc
- then
- Error_Msg_Node_1 := Urefs.Table (J).Node;
+ -- We use the table Urefs to keep track of entities for which we
+ -- have issued errors for undefined references. Multiple errors
+ -- for a single name are normally suppressed, however we modify
+ -- the error message to alert the programmer to this effect.
- if Urefs.Table (J).Nvis then
- Change_Error_Text (Urefs.Table (J).Err,
- "& is not visible (more references follow)");
- else
- Change_Error_Text (Urefs.Table (J).Err,
- "& is undefined (more references follow)");
- end if;
+ for J in Urefs.First .. Urefs.Last loop
+ if Chars (N) = Chars (Urefs.Table (J).Node) then
+ if Urefs.Table (J).Err /= No_Error_Msg
+ and then Sloc (N) /= Urefs.Table (J).Loc
+ then
+ Error_Msg_Node_1 := Urefs.Table (J).Node;
- Urefs.Table (J).Err := No_Error_Msg;
- end if;
+ if Urefs.Table (J).Nvis then
+ Change_Error_Text (Urefs.Table (J).Err,
+ "& is not visible (more references follow)");
+ else
+ Change_Error_Text (Urefs.Table (J).Err,
+ "& is undefined (more references follow)");
+ end if;
- -- Although we will set Msg False, and thus suppress the
- -- message, we also set Error_Posted True, to avoid any
- -- cascaded messages resulting from the undefined reference.
+ Urefs.Table (J).Err := No_Error_Msg;
+ end if;
- Msg := False;
- Set_Error_Posted (N, True);
- return;
- end if;
- end loop;
+ -- Although we will set Msg False, and thus suppress the
+ -- message, we also set Error_Posted True, to avoid any
+ -- cascaded messages resulting from the undefined reference.
+
+ Msg := False;
+ Set_Error_Posted (N);
+ return;
+ end if;
+ end loop;
- -- If entry not found, this is first undefined occurrence
+ -- If entry not found, this is first undefined occurrence
- if Nvis then
- Error_Msg_N ("& is not visible!", N);
- Emsg := Get_Msg_Id;
+ if Nvis then
+ Error_Msg_N ("& is not visible!", N);
+ Emsg := Get_Msg_Id;
- else
- Error_Msg_N ("& is undefined!", N);
- Emsg := Get_Msg_Id;
+ else
+ Error_Msg_N ("& is undefined!", N);
+ Emsg := Get_Msg_Id;
- -- A very bizarre special check, if the undefined identifier
- -- is put or put_line, then add a special error message (since
- -- this is a very common error for beginners to make).
+ -- A very bizarre special check, if the undefined identifier
+ -- is Put or Put_Line, then add a special error message (since
+ -- this is a very common error for beginners to make).
- if Nam_In (Chars (N), Name_Put, Name_Put_Line) then
- Error_Msg_N -- CODEFIX
- ("\\possible missing `WITH Ada.Text_'I'O; " &
- "USE Ada.Text_'I'O`!", N);
+ if Nam_In (Chars (N), Name_Put, Name_Put_Line) then
+ Error_Msg_N -- CODEFIX
+ ("\\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 missing with for this unit.
+ -- Another special check if N is the prefix of a selected
+ -- component which is a known unit: add message complaining
+ -- about missing 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 -- CODEFIX
- ("\\missing `WITH &.&;`", Prefix (Parent (N)));
- end if;
+ 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 -- CODEFIX
+ ("\\missing `WITH &.&;`", Prefix (Parent (N)));
+ end if;
- -- Now check for possible misspellings
+ -- Now check for possible misspellings
- declare
- E : Entity_Id;
- Ematch : Entity_Id := Empty;
+ declare
+ E : Entity_Id;
+ Ematch : Entity_Id := Empty;
- Last_Name_Id : constant Name_Id :=
- Name_Id (Nat (First_Name_Id) +
- Name_Entries_Count - 1);
+ Last_Name_Id : constant Name_Id :=
+ Name_Id (Nat (First_Name_Id) +
+ Name_Entries_Count - 1);
- begin
- for Nam in First_Name_Id .. Last_Name_Id loop
- E := Get_Name_Entity_Id (Nam);
+ begin
+ for Nam in First_Name_Id .. Last_Name_Id loop
+ E := Get_Name_Entity_Id (Nam);
- if Present (E)
- and then (Is_Immediately_Visible (E)
- or else
- Is_Potentially_Use_Visible (E))
- then
- if Is_Bad_Spelling_Of (Chars (N), Nam) then
- Ematch := E;
- exit;
+ if Present (E)
+ and then (Is_Immediately_Visible (E)
+ or else
+ Is_Potentially_Use_Visible (E))
+ then
+ if Is_Bad_Spelling_Of (Chars (N), Nam) then
+ Ematch := E;
+ exit;
+ end if;
end if;
- end if;
- end loop;
+ end loop;
- if Present (Ematch) then
- Error_Msg_NE -- CODEFIX
- ("\possible misspelling of&", N, Ematch);
- end if;
- end;
- end if;
+ if Present (Ematch) then
+ Error_Msg_NE -- CODEFIX
+ ("\possible misspelling of&", N, Ematch);
+ end if;
+ end;
+ end if;
- -- Make entry in undefined references table unless the full errors
- -- switch is set, in which case by refraining from generating the
- -- table entry, we guarantee that we get an error message for every
- -- undefined reference.
+ -- Make entry in undefined references table unless the full errors
+ -- switch is set, in which case by refraining from generating the
+ -- table entry we guarantee that we get an error message for every
+ -- undefined reference. The entry is not added if we are ignoring
+ -- errors.
+
+ if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then
+ Urefs.Append (
+ (Node => N,
+ Err => Emsg,
+ Nvis => Nvis,
+ Loc => Sloc (N)));
+ end if;
- if not All_Errors_Mode then
- Urefs.Append (
- (Node => N,
- Err => Emsg,
- Nvis => Nvis,
- Loc => Sloc (N)));
+ Msg := True;
end if;
-
- Msg := True;
end Undefined;
-- Local variables
end;
end if;
+ -- Although the marking of use clauses happens at the end of
+ -- Find_Direct_Name, a certain case where a generic actual satisfies
+ -- a use clause must be checked here due to how the generic machinery
+ -- handles the analysis of said actuals.
+
+ if In_Instance
+ and then Nkind (Parent (N)) = N_Generic_Association
+ then
+ Mark_Use_Clauses (Entity (N));
+ end if;
+
return;
end if;
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ if Nkind (N) = N_Identifier then
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Checks => True,
+ Modes => True,
+ Warnings => True);
+ end if;
+
-- Here if Entity pointer was not set, we need full visibility analysis
-- First we generate debugging output if the debug E flag is set.
goto Done;
elsif Is_Predefined_Unit (Current_Sem_Unit) then
- -- A use-clause in the body of a system file creates conflict
+ -- A use clause in the body of a system file creates conflict
-- with some entity in a user scope, while rtsfind is active.
-- Keep only the entity coming from another predefined unit.
-- If no homonyms were visible, the entity is unambiguous
if not Is_Overloaded (N) then
- if not Is_Actual_Parameter then
+ if Reference_OK and then not Is_Actual_Parameter then
Generate_Reference (E, N);
end if;
end if;
-- in SPARK mode where renamings are traversed for generating
-- local effects of subprograms.
- if Is_Object (E)
+ if Reference_OK
+ and then Is_Object (E)
and then Present (Renamed_Object (E))
and then not GNATprove_Mode
then
-- Generate reference unless this is an actual parameter
-- (see comment below)
- if Is_Actual_Parameter then
+ if Reference_OK and then Is_Actual_Parameter then
Generate_Reference (E, N);
Set_Referenced (E, R);
end if;
-- Normal case, not a label: generate reference
else
- if not Is_Actual_Parameter then
+ if Reference_OK and then not Is_Actual_Parameter then
-- Package or generic package is always a simple reference
- if Ekind_In (E, E_Package, E_Generic_Package) then
+ if Is_Package_Or_Generic_Package (E) then
Generate_Reference (E, N, 'r');
-- Else see if we have a left hand side
end if;
end;
+ -- Mark relevant use-type and use-package clauses as effective if the
+ -- node in question is not overloaded and therefore does not require
+ -- resolution.
+ --
+ -- Note: Generic actual subprograms do not follow the normal resolution
+ -- 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
+ Mark_Use_Clauses (N);
+ end if;
+
-- Come here with entity set
<<Done>>
Check_Restriction_No_Use_Of_Entity (N);
+
+ -- Annotate the tree by creating a variable reference marker in case the
+ -- original variable reference is folded or optimized away. The variable
+ -- reference marker is automatically saved for later examination by the
+ -- ABE Processing phase. Variable references which act as actuals in a
+ -- call require special processing and are left to Resolve_Actuals. The
+ -- reference is a write when it appears on the left hand side of an
+ -- assignment.
+
+ if Marker_OK
+ and then Needs_Variable_Reference_Marker
+ (N => N,
+ Calls_OK => False)
+ then
+ declare
+ Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes;
+
+ begin
+ Build_Variable_Reference_Marker
+ (N => N,
+ Read => not Is_Assignment_LHS,
+ Write => Is_Assignment_LHS);
+ end;
+ end if;
end Find_Direct_Name;
------------------------
-- Local variables
- Selector : constant Node_Id := Selector_Name (N);
- Candidate : Entity_Id := Empty;
+ Selector : constant Node_Id := Selector_Name (N);
+
+ Candidate : Entity_Id := Empty;
P_Name : Entity_Id;
Id : Entity_Id;
Candidate := Get_Full_View (Non_Limited_View (Id));
Is_New_Candidate := True;
+ -- An unusual case arises with a fully qualified name for an
+ -- entity local to a generic child unit package, within an
+ -- instantiation of that package. The name of the unit now
+ -- denotes the renaming created within the instance. This is
+ -- only relevant in an instance body, see below.
+
+ elsif Is_Generic_Instance (Scope (Id))
+ and then In_Open_Scopes (Scope (Id))
+ and then In_Instance_Body
+ and then Ekind (Scope (Id)) = E_Package
+ and then Ekind (Id) = E_Package
+ and then Renamed_Entity (Id) = Scope (Id)
+ and then Is_Immediately_Visible (P_Name)
+ then
+ Is_New_Candidate := True;
+
else
Is_New_Candidate := False;
end if;
-- If this is a selection from Ada, System or Interfaces, then
-- we assume a missing with for the corresponding package.
- if Is_Known_Unit (N) then
+ if Is_Known_Unit (N)
+ and then not (Present (Entity (Prefix (N)))
+ and then Scope (Entity (Prefix (N))) /=
+ Standard_Standard)
+ then
if not Error_Posted (N) then
Error_Msg_Node_2 := Selector;
Error_Msg_N -- CODEFIX
end;
else
+ -- Might be worth specializing the case when the prefix
+ -- is a limited view.
+ -- ... not declared in limited view of...
+
Error_Msg_NE ("& not declared in&", N, Selector);
end if;
Change_Selected_Component_To_Expanded_Name (N);
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Checks => True,
+ Modes => True,
+ Warnings => True);
+
-- Set appropriate type
if Is_Type (Id) then
Generate_Reference (Id, N);
end if;
+ -- Mark relevant use-type and use-package clauses as effective if the
+ -- node in question is not overloaded and therefore does not require
+ -- resolution.
+
+ if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then
+ Mark_Use_Clauses (N);
+ end if;
+
Check_Restriction_No_Use_Of_Entity (N);
+
+ -- Annotate the tree by creating a variable reference marker in case the
+ -- original variable reference is folded or optimized away. The variable
+ -- reference marker is automatically saved for later examination by the
+ -- ABE Processing phase. Variable references which act as actuals in a
+ -- call require special processing and are left to Resolve_Actuals. The
+ -- reference is a write when it appears on the left hand side of an
+ -- assignment.
+
+ if Needs_Variable_Reference_Marker
+ (N => N,
+ Calls_OK => False)
+ then
+ declare
+ Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes;
+
+ begin
+ Build_Variable_Reference_Marker
+ (N => N,
+ Read => not Is_Assignment_LHS,
+ Write => Is_Assignment_LHS);
+ end;
+ end if;
end Find_Expanded_Name;
+ --------------------
+ -- Find_Most_Prev --
+ --------------------
+
+ function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is
+ Curr : Node_Id;
+
+ begin
+ -- Loop through the Prev_Use_Clause chain
+
+ Curr := Use_Clause;
+ while Present (Prev_Use_Clause (Curr)) loop
+ Curr := Prev_Use_Clause (Curr);
+ end loop;
+
+ return Curr;
+ end Find_Most_Prev;
+
-------------------------
-- Find_Renamed_Entity --
-------------------------
Old_S : Entity_Id;
Inst : Entity_Id;
+ function Find_Nearer_Entity
+ (New_S : Entity_Id;
+ Old1_S : Entity_Id;
+ Old2_S : Entity_Id) return Entity_Id;
+ -- Determine whether one of Old_S1 and Old_S2 is nearer to New_S than
+ -- the other, and return it if so. Return Empty otherwise. We use this
+ -- in conjunction with Inherit_Renamed_Profile to simplify later type
+ -- disambiguation for actual subprograms in instances.
+
function Is_Visible_Operation (Op : Entity_Id) return Boolean;
-- If the renamed entity is an implicit operator, check whether it is
-- visible because its operand type is properly visible. This check
-- Determine whether a candidate subprogram is defined within the
-- enclosing instance. If yes, it has precedence over outer candidates.
+ --------------------------
+ -- Find_Nearer_Entity --
+ --------------------------
+
+ function Find_Nearer_Entity
+ (New_S : Entity_Id;
+ Old1_S : Entity_Id;
+ Old2_S : Entity_Id) return Entity_Id
+ is
+ New_F : Entity_Id;
+ Old1_F : Entity_Id;
+ Old2_F : Entity_Id;
+ Anc_T : Entity_Id;
+
+ begin
+ New_F := First_Formal (New_S);
+ Old1_F := First_Formal (Old1_S);
+ Old2_F := First_Formal (Old2_S);
+
+ -- The criterion is whether the type of the formals of one of Old1_S
+ -- and Old2_S is an ancestor subtype of the type of the corresponding
+ -- formals of New_S while the other is not (we already know that they
+ -- are all subtypes of the same base type).
+
+ -- This makes it possible to find the more correct renamed entity in
+ -- the case of a generic instantiation nested in an enclosing one for
+ -- which different formal types get the same actual type, which will
+ -- in turn make it possible for Inherit_Renamed_Profile to preserve
+ -- types on formal parameters and ultimately simplify disambiguation.
+
+ -- Consider the follow package G:
+
+ -- generic
+ -- type Item_T is private;
+ -- with function Compare (L, R: Item_T) return Boolean is <>;
+
+ -- type Bound_T is private;
+ -- with function Compare (L, R : Bound_T) return Boolean is <>;
+ -- package G is
+ -- ...
+ -- end G;
+
+ -- package body G is
+ -- package My_Inner is Inner_G (Bound_T);
+ -- ...
+ -- end G;
+
+ -- with the following package Inner_G:
+
+ -- generic
+ -- type T is private;
+ -- with function Compare (L, R: T) return Boolean is <>;
+ -- package Inner_G is
+ -- function "<" (L, R: T) return Boolean is (Compare (L, R));
+ -- end Inner_G;
+
+ -- If G is instantiated on the same actual type with a single Compare
+ -- function:
+
+ -- type T is ...
+ -- function Compare (L, R : T) return Boolean;
+ -- package My_G is new (T, T);
+
+ -- then the renaming generated for Compare in the inner instantiation
+ -- is ambiguous: it can rename either of the renamings generated for
+ -- the outer instantiation. Now if the first one is picked up, then
+ -- the subtypes of the formal parameters of the renaming will not be
+ -- preserved in Inherit_Renamed_Profile because they are subtypes of
+ -- the Bound_T formal type and not of the Item_T formal type, so we
+ -- need to arrange for the second one to be picked up instead.
+
+ while Present (New_F) loop
+ if Etype (Old1_F) /= Etype (Old2_F) then
+ Anc_T := Ancestor_Subtype (Etype (New_F));
+
+ if Etype (Old1_F) = Anc_T then
+ return Old1_S;
+ elsif Etype (Old2_F) = Anc_T then
+ return Old2_S;
+ end if;
+ end if;
+
+ Next_Formal (New_F);
+ Next_Formal (Old1_F);
+ Next_Formal (Old2_F);
+ end loop;
+
+ pragma Assert (No (Old1_F));
+ pragma Assert (No (Old2_F));
+
+ return Empty;
+ end Find_Nearer_Entity;
+
--------------------------
-- Is_Visible_Operation --
--------------------------
if Present (Inst) then
if Within (It.Nam, Inst) then
if Within (Old_S, Inst) then
-
- -- Choose the innermost subprogram, which would
- -- have hidden the outer one in the generic.
-
- if Scope_Depth (It.Nam) <
- Scope_Depth (Old_S)
- then
- return Old_S;
- else
- return It.Nam;
- end if;
+ declare
+ It_D : constant Uint := Scope_Depth (It.Nam);
+ Old_D : constant Uint := Scope_Depth (Old_S);
+ N_Ent : Entity_Id;
+ begin
+ -- Choose the innermost subprogram, which
+ -- would hide the outer one in the generic.
+
+ if Old_D > It_D then
+ return Old_S;
+ elsif It_D > Old_D then
+ return It.Nam;
+ end if;
+
+ -- Otherwise, if we can determine that one
+ -- of the entities is nearer to the renaming
+ -- than the other, choose it. If not, then
+ -- return the newer one as done historically.
+
+ N_Ent :=
+ Find_Nearer_Entity (New_S, Old_S, It.Nam);
+ if Present (N_Ent) then
+ return N_Ent;
+ else
+ return It.Nam;
+ end if;
+ end;
end if;
elsif Within (Old_S, Inst) then
- return (Old_S);
+ return Old_S;
else
return Report_Overload;
end if;
-- If the selected component appears within a default expression
- -- and it has an actual subtype, the pre-analysis has not yet
+ -- and it has an actual subtype, the preanalysis has not yet
-- completed its analysis, because Insert_Actions is disabled in
-- that context. Within the init proc of the enclosing type we
-- must complete this analysis, if an actual subtype was created.
-- It is not an error if the prefix is the current instance of
-- type name, e.g. the expression of a type aspect, when it is
- -- analyzed for ASIS use.
+ -- analyzed for ASIS use, or within a generic unit. We still
+ -- have to verify that a component of that name exists, and
+ -- decorate the node accordingly.
elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then
- null;
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Entity (P));
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Selector_Name (N)) then
+ Set_Entity (N, Comp);
+ Set_Etype (N, Etype (Comp));
+ Set_Entity (Selector_Name (N), Comp);
+ Set_Etype (Selector_Name (N), Etype (Comp));
+ return;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end;
elsif Ekind (P_Name) = E_Void then
Premature_Usage (P);
-- synchronized type itself, with minimal semantic
-- attributes, to catch other errors in some ACATS tests.
- pragma Assert (Serious_Errors_Detected > 0);
+ pragma Assert (Serious_Errors_Detected /= 0);
Make_Class_Wide_Type (T);
C := Class_Wide_Type (T);
Set_First_Entity (C, First_Entity (T));
(Clause : Node_Id;
Force_Installation : Boolean := False)
is
- U : Node_Id;
- P : Node_Id;
- Id : Entity_Id;
+ U : Node_Id;
begin
U := Clause;
-- Case of USE package
if Nkind (U) = N_Use_Package_Clause then
- P := First (Names (U));
- while Present (P) loop
- Id := Entity (P);
-
- if Ekind (Id) = E_Package then
- if In_Use (Id) then
- Note_Redundant_Use (P);
-
- elsif Present (Renamed_Object (Id))
- and then In_Use (Renamed_Object (Id))
- then
- Note_Redundant_Use (P);
-
- elsif Force_Installation or else Applicable_Use (P) then
- Use_One_Package (Id, U);
-
- end if;
- end if;
-
- Next (P);
- end loop;
+ Use_One_Package (U, Name (U), True);
-- Case of USE TYPE
else
- P := First (Subtype_Marks (U));
- while Present (P) loop
- if not Is_Entity_Name (P)
- or else No (Entity (P))
- then
- null;
-
- elsif Entity (P) /= Any_Type then
- Use_One_Type (P);
- end if;
+ Use_One_Type (Subtype_Mark (U), Force => Force_Installation);
- Next (P);
- end loop;
end if;
Next_Use_Clause (U);
and then Has_Components (Designated_Type (T))));
end Is_Appropriate_For_Record;
- ------------------------
- -- Note_Redundant_Use --
- ------------------------
+ ----------------------
+ -- Mark_Use_Clauses --
+ ----------------------
- procedure Note_Redundant_Use (Clause : Node_Id) is
- Pack_Name : constant Entity_Id := Entity (Clause);
- Cur_Use : constant Node_Id := Current_Use_Clause (Pack_Name);
- Decl : constant Node_Id := Parent (Clause);
+ 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.
- Prev_Use : Node_Id := Empty;
- Redundant : Node_Id := Empty;
- -- The Use_Clause which is actually redundant. In the simplest case it
- -- is Pack itself, but when we compile a body we install its context
- -- before that of its spec, in which case it is the use_clause in the
- -- spec that will appear to be redundant, and we want the warning to be
- -- placed on the body. Similar complications appear when the redundancy
- -- is between a child unit and one of its ancestors.
+ procedure Mark_Use_Package (Pak : Entity_Id);
+ -- Move up the Prev_Use_Clause chain for packages denoted by Pak -
+ -- marking each clause in the chain as effective in the process.
- begin
- Set_Redundant_Use (Clause, True);
+ procedure Mark_Use_Type (E : Entity_Id);
+ -- Similar to Do_Use_Package_Marking except we move up the
+ -- Prev_Use_Clause chain for the type denoted by E.
- if not Comes_From_Source (Clause)
- or else In_Instance
- or else not Warn_On_Redundant_Constructs
- then
- return;
- end if;
+ ---------------------
+ -- Mark_Parameters --
+ ---------------------
- if not Is_Compilation_Unit (Current_Scope) then
+ procedure Mark_Parameters (Call : Entity_Id) is
+ Curr : Node_Id;
- -- If the use_clause is in an inner scope, it is made redundant by
- -- some clause in the current context, with one exception: If we're
- -- compiling a nested package body, and the use_clause comes from the
- -- corresponding spec, the clause is not necessarily fully redundant,
- -- so we should not warn. If a warning was warranted, it would have
- -- been given when the spec was processed.
+ begin
+ -- Move through all of the formals
- if Nkind (Parent (Decl)) = N_Package_Specification then
- declare
- Package_Spec_Entity : constant Entity_Id :=
- Defining_Unit_Name (Parent (Decl));
- begin
- if In_Package_Body (Package_Spec_Entity) then
- return;
- end if;
- end;
- end if;
+ Curr := First_Formal (Call);
+ while Present (Curr) loop
+ Mark_Use_Type (Curr);
- Redundant := Clause;
- Prev_Use := Cur_Use;
+ Curr := Next_Formal (Curr);
+ end loop;
- elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
- declare
- Cur_Unit : constant Unit_Number_Type := Get_Source_Unit (Cur_Use);
- New_Unit : constant Unit_Number_Type := Get_Source_Unit (Clause);
- Scop : Entity_Id;
+ -- Handle the return type
- begin
- if Cur_Unit = New_Unit then
+ Mark_Use_Type (Call);
+ end Mark_Parameters;
- -- Redundant clause in same body
+ ----------------------
+ -- Mark_Use_Package --
+ ----------------------
- Redundant := Clause;
- Prev_Use := Cur_Use;
+ procedure Mark_Use_Package (Pak : Entity_Id) is
+ Curr : Node_Id;
- elsif Cur_Unit = Current_Sem_Unit then
+ begin
+ -- Ignore cases where the scope of the type is not a package (e.g.
+ -- Standard_Standard).
- -- If the new clause is not in the current unit it has been
- -- analyzed first, and it makes the other one redundant.
- -- However, if the new clause appears in a subunit, Cur_Unit
- -- is still the parent, and in that case the redundant one
- -- is the one appearing in the subunit.
+ if Ekind (Pak) /= E_Package then
+ return;
+ end if;
- if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then
- Redundant := Clause;
- Prev_Use := Cur_Use;
+ Curr := Current_Use_Clause (Pak);
+ while Present (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
+ -- 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.
+
+ if Nkind (Name (Curr)) /= N_Identifier
+ and then Present (Prefix (Name (Curr)))
+ and then Entity (Prefix (Name (Curr))) /= Pak
+ then
+ Mark_Use_Package (Entity (Prefix (Name (Curr))));
- -- Most common case: redundant clause in body,
- -- original clause in spec. Current scope is spec entity.
+ -- It is also possible to have a child package without a prefix
+ -- that relies on a previous use_package_clause.
- elsif
- Current_Scope =
- Defining_Entity (
- Unit (Library_Unit (Cunit (Current_Sem_Unit))))
- then
- Redundant := Cur_Use;
- Prev_Use := Clause;
+ elsif Nkind (Name (Curr)) = N_Identifier
+ and then Is_Child_Unit (Entity (Name (Curr)))
+ then
+ Mark_Use_Package (Scope (Entity (Name (Curr))));
+ end if;
- else
- -- The new clause may appear in an unrelated unit, when
- -- the parents of a generic are being installed prior to
- -- instantiation. In this case there must be no warning.
- -- We detect this case by checking whether the current top
- -- of the stack is related to the current compilation.
-
- Scop := Current_Scope;
- while Present (Scop) and then Scop /= Standard_Standard loop
- if Is_Compilation_Unit (Scop)
- and then not Is_Child_Unit (Scop)
- then
- return;
+ -- Mark the use_package_clause as effective and move up the chain
- elsif Scop = Cunit_Entity (Current_Sem_Unit) then
- exit;
- end if;
+ Set_Is_Effective_Use_Clause (Curr);
- Scop := Scope (Scop);
- end loop;
+ Curr := Prev_Use_Clause (Curr);
+ end loop;
+ end Mark_Use_Package;
- Redundant := Cur_Use;
- Prev_Use := Clause;
- end if;
+ -------------------
+ -- Mark_Use_Type --
+ -------------------
- elsif New_Unit = Current_Sem_Unit then
- Redundant := Clause;
- Prev_Use := Cur_Use;
+ procedure Mark_Use_Type (E : Entity_Id) is
+ Curr : Node_Id;
+ Base : Entity_Id;
- else
- -- Neither is the current unit, so they appear in parent or
- -- sibling units. Warning will be emitted elsewhere.
+ begin
+ -- Ignore void types and unresolved string literals and primitives
- return;
- end if;
- end;
+ if Nkind (E) = N_String_Literal
+ or else Nkind (Etype (E)) not in N_Entity
+ or else not Is_Type (Etype (E))
+ then
+ return;
+ end if;
- elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
- and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit))))
- then
- -- Use_clause is in child unit of current unit, and the child unit
- -- appears in the context of the body of the parent, so it has been
- -- installed first, even though it is the redundant one. Depending on
- -- their placement in the context, the visible or the private parts
- -- of the two units, either might appear as redundant, but the
- -- message has to be on the current unit.
-
- if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then
- Redundant := Cur_Use;
- Prev_Use := Clause;
- else
- Redundant := Clause;
- Prev_Use := Cur_Use;
+ -- Primitives with class-wide operands might additionally render
+ -- their base type's use_clauses effective - so do a recursive check
+ -- here.
+
+ Base := Base_Type (Etype (E));
+
+ if Ekind (Base) = E_Class_Wide_Type then
+ Mark_Use_Type (Base);
end if;
- -- If the new use clause appears in the private part of a parent unit
- -- it may appear to be redundant w.r.t. a use clause in a child unit,
- -- but the previous use clause was needed in the visible part of the
- -- child, and no warning should be emitted.
+ -- The package containing the type or operator function being used
+ -- may be in use as well, so mark any use_package_clauses for it as
+ -- effective. There are also additional sanity checks performed here
+ -- for ignoring previous errors.
- if Nkind (Parent (Decl)) = N_Package_Specification
- and then
- List_Containing (Decl) = Private_Declarations (Parent (Decl))
+ Mark_Use_Package (Scope (Base));
+
+ if Nkind (E) in N_Op
+ and then Present (Entity (E))
+ and then Present (Scope (Entity (E)))
then
- declare
- Par : constant Entity_Id := Defining_Entity (Parent (Decl));
- Spec : constant Node_Id :=
- Specification (Unit (Cunit (Current_Sem_Unit)));
+ Mark_Use_Package (Scope (Entity (E)));
+ end if;
- begin
- 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)
- then
- return;
- end if;
- end;
+ Curr := Current_Use_Clause (Base);
+ while Present (Curr)
+ and then not Is_Effective_Use_Clause (Curr)
+ loop
+ -- Current use_type_clause may render other use_package_clauses
+ -- effective.
+
+ if Nkind (Subtype_Mark (Curr)) /= N_Identifier
+ and then Present (Prefix (Subtype_Mark (Curr)))
+ then
+ Mark_Use_Package (Entity (Prefix (Subtype_Mark (Curr))));
+ end if;
+
+ -- Mark the use_type_clause as effective and move up the chain
+
+ Set_Is_Effective_Use_Clause (Curr);
+
+ Curr := Prev_Use_Clause (Curr);
+ end loop;
+ end Mark_Use_Type;
+
+ -- Start of processing for Mark_Use_Clauses
+
+ begin
+ -- Use clauses in and of themselves do not count as a "use" of a
+ -- package.
+
+ if Nkind_In (Parent (Id), N_Use_Package_Clause, N_Use_Type_Clause) then
+ return;
+ end if;
+
+ -- Handle entities
+
+ if Nkind (Id) in N_Entity then
+
+ -- Mark the entity's package
+
+ if Is_Potentially_Use_Visible (Id) then
+ Mark_Use_Package (Scope (Id));
end if;
- -- Finally, if the current use clause is in the context then
- -- the clause is redundant when it is nested within the unit.
+ -- Mark enumeration literals
- elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit
- and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit
- and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause)
- then
- Redundant := Clause;
- Prev_Use := Cur_Use;
+ if Ekind (Id) = E_Enumeration_Literal then
+ Mark_Use_Type (Id);
+
+ -- Mark primitives
+
+ elsif (Ekind (Id) in Overloadable_Kind
+ or else Ekind_In (Id, E_Generic_Function,
+ E_Generic_Procedure))
+ and then (Is_Potentially_Use_Visible (Id)
+ or else Is_Intrinsic_Subprogram (Id)
+ or else (Ekind_In (Id, E_Function, E_Procedure)
+ and then Is_Generic_Actual_Subprogram (Id)))
+ then
+ Mark_Parameters (Id);
+ end if;
+
+ -- Handle nodes
else
- null;
+ -- Mark operators
+
+ if Nkind (Id) in N_Op then
+
+ -- At this point the left operand may not be resolved if we are
+ -- encountering multiple operators next to eachother in an
+ -- expression.
+
+ if Nkind (Id) in N_Binary_Op
+ and then not (Nkind (Left_Opnd (Id)) in N_Op)
+ then
+ Mark_Use_Type (Left_Opnd (Id));
+ end if;
+
+ Mark_Use_Type (Right_Opnd (Id));
+ Mark_Use_Type (Id);
+
+ -- Mark entity identifiers
+
+ elsif Nkind (Id) in N_Has_Entity
+ and then (Is_Potentially_Use_Visible (Entity (Id))
+ or else (Is_Generic_Instance (Entity (Id))
+ and then Is_Immediately_Visible (Entity (Id))))
+ then
+ -- Ignore fully qualified names as they do not count as a "use" of
+ -- a package.
+
+ if Nkind_In (Id, N_Identifier, N_Operator_Symbol)
+ or else (Present (Prefix (Id))
+ and then Scope (Entity (Id)) /= Entity (Prefix (Id)))
+ then
+ Mark_Use_Clauses (Entity (Id));
+ end if;
+ end if;
end if;
+ end Mark_Use_Clauses;
+
+ --------------------------------
+ -- Most_Descendant_Use_Clause --
+ --------------------------------
- if Present (Redundant) then
- Error_Msg_Sloc := Sloc (Prev_Use);
- Error_Msg_NE -- CODEFIX
- ("& is already use-visible through previous use clause #??",
- Redundant, Pack_Name);
+ function Most_Descendant_Use_Clause
+ (Clause1 : Entity_Id;
+ Clause2 : Entity_Id) return Entity_Id
+ is
+ Scope1 : Entity_Id;
+ Scope2 : Entity_Id;
+
+ begin
+ if Clause1 = Clause2 then
+ return Clause1;
end if;
- end Note_Redundant_Use;
+
+ -- We determine which one is the most descendant by the scope distance
+ -- to the ultimate parent unit.
+
+ Scope1 := Entity_Of_Unit (Unit (Parent (Clause1)));
+ Scope2 := Entity_Of_Unit (Unit (Parent (Clause2)));
+ while Scope1 /= Standard_Standard
+ and then Scope2 /= Standard_Standard
+ loop
+ Scope1 := Scope (Scope1);
+ Scope2 := Scope (Scope2);
+
+ if not Present (Scope1) then
+ return Clause1;
+ elsif not Present (Scope2) then
+ return Clause2;
+ end if;
+ end loop;
+
+ if Scope1 = Standard_Standard then
+ return Clause1;
+ end if;
+
+ return Clause2;
+ end Most_Descendant_Use_Clause;
---------------
-- Pop_Scope --
-- Set Default_Storage_Pool field of the library unit if necessary
- if Ekind_In (S, E_Package, E_Generic_Package)
+ if Is_Package_Or_Generic_Package (S)
and then
Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit
then
Scope_Stack.Decrement_Last;
end Pop_Scope;
- ---------------
+ ----------------
-- Push_Scope --
- ---------------
+ ----------------
procedure Push_Scope (S : Entity_Id) is
E : constant Entity_Id := Scope (S);
if Scope_Stack.Last > Scope_Stack.First then
SST.Component_Alignment_Default :=
Scope_Stack.Table
- (Scope_Stack.Last - 1). Component_Alignment_Default;
+ (Scope_Stack.Last - 1).Component_Alignment_Default;
-- Otherwise, this is the first scope being pushed on the scope
-- stack. Inherit the component alignment from the configuration
if Is_Child_Unit (S)
and then Present (E)
- and then Ekind_In (E, E_Package, E_Generic_Package)
+ and then Is_Package_Or_Generic_Package (E)
and then
Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
then
Make_With_Clause (Loc,
Name =>
Make_Expanded_Name (Loc,
- Chars => Chars (System_Aux_Id),
- Prefix => New_Occurrence_Of (Scope (System_Aux_Id), Loc),
+ Chars => Chars (System_Aux_Id),
+ Prefix =>
+ New_Occurrence_Of (Scope (System_Aux_Id), Loc),
Selector_Name => New_Occurrence_Of (System_Aux_Id, Loc)));
Set_Entity (Name (Withn), System_Aux_Id);
- Set_Library_Unit (Withn, Cunit (Unum));
Set_Corresponding_Spec (Withn, System_Aux_Id);
- Set_First_Name (Withn, True);
- Set_Implicit_With (Withn, True);
+ Set_First_Name (Withn);
+ Set_Implicit_With (Withn);
+ Set_Library_Unit (Withn, Cunit (Unum));
Insert_After (With_Sys, Withn);
Mark_Rewrite_Insertion (Withn);
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);
+ Install_Use_Clauses
+ (Scope_Stack.Table (SS_Last).First_Use_Clause,
+ Force_Installation => True);
end if;
end Restore_Scope_Stack;
-------------
procedure Set_Use (L : List_Id) is
- Decl : Node_Id;
- Pack_Name : Node_Id;
- Pack : Entity_Id;
- Id : Entity_Id;
+ Decl : Node_Id;
begin
if Present (L) then
while Present (Decl) loop
if Nkind (Decl) = N_Use_Package_Clause then
Chain_Use_Clause (Decl);
+ Use_One_Package (Decl, Name (Decl));
- Pack_Name := First (Names (Decl));
- while Present (Pack_Name) loop
- Pack := Entity (Pack_Name);
+ elsif Nkind (Decl) = N_Use_Type_Clause then
+ Chain_Use_Clause (Decl);
+ Use_One_Type (Subtype_Mark (Decl));
+
+ end if;
- if Ekind (Pack) = E_Package
- and then Applicable_Use (Pack_Name)
+ Next (Decl);
+ end loop;
+ end if;
+ end Set_Use;
+
+ -----------------------------
+ -- Update_Use_Clause_Chain --
+ -----------------------------
+
+ 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
+ -- to a redundant use clause outside of the current ending scope if such
+ -- a clause exists.
+
+ ---------------------------
+ -- Update_Chain_In_Scope --
+ ---------------------------
+
+ procedure Update_Chain_In_Scope (Level : Int) is
+ Curr : Node_Id;
+ N : Node_Id;
+
+ begin
+ -- Loop through all use clauses within the scope dictated by Level
+
+ Curr := Scope_Stack.Table (Level).First_Use_Clause;
+ while Present (Curr) loop
+
+ -- Retrieve the subtype mark or name within the current current
+ -- use clause.
+
+ if Nkind (Curr) = N_Use_Type_Clause then
+ N := Subtype_Mark (Curr);
+ else
+ N := Name (Curr);
+ end if;
+
+ -- If warnings for unreferenced entities are enabled and the
+ -- current use clause has not been marked effective.
+
+ if Check_Unreferenced
+ and then Comes_From_Source (Curr)
+ and then not Is_Effective_Use_Clause (Curr)
+ and then not In_Instance
+ and then not In_Inlined_Body
+ then
+ -- We are dealing with a potentially unused use_package_clause
+
+ if Nkind (Curr) = N_Use_Package_Clause then
+
+ -- Renamings and formal subprograms may cause the associated
+ -- node to be marked as effective instead of the original.
+
+ if not (Present (Associated_Node (N))
+ and then Present
+ (Current_Use_Clause
+ (Associated_Node (N)))
+ and then Is_Effective_Use_Clause
+ (Current_Use_Clause
+ (Associated_Node (N))))
then
- Use_One_Package (Pack, Decl);
+ Error_Msg_Node_1 := Entity (N);
+ Error_Msg_NE
+ ("use clause for package & has no effect?u?",
+ Curr, Entity (N));
end if;
- Next (Pack_Name);
- end loop;
+ -- We are dealing with an unused use_type_clause
- elsif Nkind (Decl) = N_Use_Type_Clause then
- Chain_Use_Clause (Decl);
+ else
+ Error_Msg_Node_1 := Etype (N);
+ Error_Msg_NE
+ ("use clause for } has no effect?u?", Curr, Etype (N));
+ end if;
+ end if;
- Id := First (Subtype_Marks (Decl));
- while Present (Id) loop
- if Entity (Id) /= Any_Type then
- Use_One_Type (Id);
- end if;
+ -- Verify that we haven't already processed a redundant
+ -- use_type_clause within the same scope before we move the
+ -- current use clause up to a previous one for type T.
- Next (Id);
- end loop;
+ if Present (Prev_Use_Clause (Curr)) then
+ Set_Current_Use_Clause (Entity (N), Prev_Use_Clause (Curr));
end if;
- Next (Decl);
+ Curr := Next_Use_Clause (Curr);
end loop;
+ end Update_Chain_In_Scope;
+
+ -- Start of processing for Update_Use_Clause_Chain
+
+ begin
+ Update_Chain_In_Scope (Scope_Stack.Last);
+
+ -- Deal with use clauses within the context area if the current
+ -- scope is a compilation unit.
+
+ if Is_Compilation_Unit (Current_Scope)
+ and then Sloc (Scope_Stack.Table
+ (Scope_Stack.Last - 1).Entity) = Standard_Location
+ then
+ Update_Chain_In_Scope (Scope_Stack.Last - 1);
end if;
- end Set_Use;
+ end Update_Use_Clause_Chain;
---------------------
-- Use_One_Package --
---------------------
- procedure Use_One_Package (P : Entity_Id; N : Node_Id) is
+ procedure Use_One_Package
+ (N : Node_Id;
+ 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
+ -- from source and the proper warnings are enabled.
+
+ ------------------------
+ -- Note_Redundant_Use --
+ ------------------------
+
+ procedure Note_Redundant_Use (Clause : Node_Id) is
+ 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;
+ Redundant : Node_Id := Empty;
+ -- The Use_Clause which is actually redundant. In the simplest case
+ -- it is Pack itself, but when we compile a body we install its
+ -- context before that of its spec, in which case it is the
+ -- use_clause in the spec that will appear to be redundant, and we
+ -- want the warning to be placed on the body. Similar complications
+ -- appear when the redundancy is between a child unit and one of its
+ -- ancestors.
+
+ begin
+ -- Could be renamed...
+
+ if No (Cur_Use) then
+ Cur_Use := Current_Use_Clause (Renamed_Entity (Pack_Name));
+ end if;
+
+ Set_Redundant_Use (Clause, True);
+
+ if not Comes_From_Source (Clause)
+ or else In_Instance
+ or else not Warn_On_Redundant_Constructs
+ then
+ return;
+ end if;
+
+ if not Is_Compilation_Unit (Current_Scope) then
+
+ -- If the use_clause is in an inner scope, it is made redundant by
+ -- some clause in the current context, with one exception: If we
+ -- are compiling a nested package body, and the use_clause comes
+ -- from then corresponding spec, the clause is not necessarily
+ -- fully redundant, so we should not warn. If a warning was
+ -- warranted, it would have been given when the spec was
+ -- processed.
+
+ if Nkind (Parent (Decl)) = N_Package_Specification then
+ declare
+ Package_Spec_Entity : constant Entity_Id :=
+ Defining_Unit_Name (Parent (Decl));
+ begin
+ if In_Package_Body (Package_Spec_Entity) then
+ return;
+ end if;
+ end;
+ end if;
+
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+
+ elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
+ declare
+ Cur_Unit : constant Unit_Number_Type :=
+ Get_Source_Unit (Cur_Use);
+ New_Unit : constant Unit_Number_Type :=
+ Get_Source_Unit (Clause);
+
+ Scop : Entity_Id;
+
+ begin
+ if Cur_Unit = New_Unit then
+
+ -- Redundant clause in same body
+
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+
+ elsif Cur_Unit = Current_Sem_Unit then
+
+ -- If the new clause is not in the current unit it has been
+ -- analyzed first, and it makes the other one redundant.
+ -- However, if the new clause appears in a subunit, Cur_Unit
+ -- is still the parent, and in that case the redundant one
+ -- is the one appearing in the subunit.
+
+ if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+
+ -- 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;
+ Prev_Use := Clause;
+
+ else
+ -- The new clause may appear in an unrelated unit, when
+ -- the parents of a generic are being installed prior to
+ -- instantiation. In this case there must be no warning.
+ -- We detect this case by checking whether the current
+ -- top of the stack is related to the current
+ -- compilation.
+
+ Scop := Current_Scope;
+ while Present (Scop)
+ and then Scop /= Standard_Standard
+ loop
+ if Is_Compilation_Unit (Scop)
+ and then not Is_Child_Unit (Scop)
+ then
+ return;
+
+ elsif Scop = Cunit_Entity (Current_Sem_Unit) then
+ exit;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ Redundant := Cur_Use;
+ Prev_Use := Clause;
+ end if;
+
+ elsif New_Unit = Current_Sem_Unit then
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+
+ else
+ -- Neither is the current unit, so they appear in parent or
+ -- sibling units. Warning will be emitted elsewhere.
+
+ return;
+ end if;
+ end;
+
+ elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
+ and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit))))
+ then
+ -- Use_clause is in child unit of current unit, and the child unit
+ -- appears in the context of the body of the parent, so it has
+ -- been installed first, even though it is the redundant one.
+ -- Depending on their placement in the context, the visible or the
+ -- private parts of the two units, either might appear as
+ -- redundant, but the message has to be on the current unit.
+
+ if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then
+ Redundant := Cur_Use;
+ Prev_Use := Clause;
+ else
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+ end if;
+
+ -- If the new use clause appears in the private part of a parent
+ -- unit it may appear to be redundant w.r.t. a use clause in a
+ -- child unit, but the previous use clause was needed in the
+ -- 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))
+ then
+ declare
+ Par : constant Entity_Id := Defining_Entity (Parent (Decl));
+ Spec : constant Node_Id :=
+ Specification (Unit (Cunit (Current_Sem_Unit)));
+ Cur_List : constant List_Id := List_Containing (Cur_Use);
+ begin
+ if Is_Compilation_Unit (Par)
+ and then Par /= Cunit_Entity (Current_Sem_Unit)
+ then
+ if Cur_List = Context_Items (Cunit (Current_Sem_Unit))
+ or else Cur_List = Visible_Declarations (Spec)
+ then
+ return;
+ end if;
+ 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.
+
+ elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit
+ and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit
+ and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause)
+ then
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+ 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.
+
+ if Nkind (Prev_Use) = N_Use_Package_Clause
+ and then
+ (Nkind (Parent (Prev_Use)) /= N_Compilation_Unit
+ or else Most_Descendant_Use_Clause
+ (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use)
+ then
+ Prev_Use := Find_Most_Prev (Prev_Use);
+ end if;
+
+ Error_Msg_Sloc := Sloc (Prev_Use);
+ Error_Msg_NE -- CODEFIX
+ ("& is already use-visible through previous use_clause #??",
+ Redundant, Pack_Name);
+ end if;
+ end Note_Redundant_Use;
+
+ -- Local variables
+
+ Current_Instance : Entity_Id := Empty;
Id : Entity_Id;
+ P : Entity_Id;
Prev : Entity_Id;
- Current_Instance : Entity_Id := Empty;
- Real_P : Entity_Id;
Private_With_OK : Boolean := False;
+ Real_P : Entity_Id;
+
+ -- Start of processing for Use_One_Package
begin
- if Ekind (P) /= E_Package then
- return;
+ -- Use_One_Package may have been called recursively to handle an
+ -- implicit use for a auxiliary system package, so set P accordingly
+ -- and skip redundancy checks.
+
+ if No (Pack_Name) and then Present_System_Aux (N) then
+ P := System_Aux_Id;
+
+ -- Check for redundant use_package_clauses
+
+ else
+ -- Ignore cases where we are dealing with a non user defined package
+ -- like Standard_Standard or something other than a valid package.
+
+ if not Is_Entity_Name (Pack_Name)
+ or else No (Entity (Pack_Name))
+ or else Ekind (Entity (Pack_Name)) /= E_Package
+ then
+ return;
+ end if;
+
+ -- When a renaming exists we must check it for redundancy. The
+ -- original package would have already been seen at this point.
+
+ if Present (Renamed_Object (Entity (Pack_Name))) then
+ P := Renamed_Object (Entity (Pack_Name));
+ else
+ P := Entity (Pack_Name);
+ end if;
+
+ -- Check for redundant clauses then set the current use clause for
+ -- P if were are not "forcing" an installation from a scope
+ -- reinstallation that is done throughout analysis for various
+ -- reasons.
+
+ 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
+
+ elsif not Force
+ and then In_Open_Scopes (P)
+ and then not Is_Hidden_Open_Scope (P)
+ then
+ if Warn_On_Redundant_Constructs and then P = Current_Scope then
+ Error_Msg_NE -- CODEFIX
+ ("& is already use-visible within itself?r?",
+ Pack_Name, P);
+ end if;
+
+ return;
+ end if;
+
+ -- Set P back to the non-renamed package so that visiblilty of the
+ -- entities within the package can be properly set below.
+
+ P := Entity (Pack_Name);
end if;
Set_In_Use (P);
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));
-- current one would have been visible, so make the other one
-- not use_visible.
+ -- In certain pathological cases it is possible that unrelated
+ -- homonyms from distinct formal packages may exist in an
+ -- uninstalled scope. We must test for that here.
+
elsif Present (Current_Instance)
and then Is_Potentially_Use_Visible (Prev)
and then not Is_Overloadable (Prev)
and then Scope (Id) /= Scope (Prev)
and then Used_As_Generic_Actual (Scope (Prev))
and then Used_As_Generic_Actual (Scope (Id))
+ and then Is_List_Member (Scope (Prev))
and then not In_Same_List (Current_Use_Clause (Scope (Prev)),
Current_Use_Clause (Scope (Id)))
then
and then Scope (Real_P) = Standard_Standard
and then Present_System_Aux (N)
then
- Use_One_Package (System_Aux_Id, N);
+ Use_One_Package (N);
end if;
-
end Use_One_Package;
------------------
-- Use_One_Type --
------------------
- procedure Use_One_Type (Id : Node_Id; Installed : Boolean := False) is
- Elmt : Elmt_Id;
- Is_Known_Used : Boolean;
- Op_List : Elist_Id;
- T : Entity_Id;
-
+ procedure Use_One_Type
+ (Id : Node_Id;
+ Installed : Boolean := False;
+ Force : Boolean := False)
+ is
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
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;
-------------------------------
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;
+ (Op : Entity_Id;
+ T : Entity_Id) return Boolean;
-- Determine whether a subprogram has a class-wide parameter or
-- result that is T'Class.
---------------------------------
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;
if Etype (Formal) = Class_Wide_Type (T) then
return True;
end if;
+
Next_Formal (Formal);
end loop;
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
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
+ if Entity (Id) = Any_Type then
+ return;
+ end if;
+
-- It is the type determined by the subtype mark (8.4(8)) whose
-- operations become potentially use-visible.
T := Base_Type (Entity (Id));
- -- Either the type itself is used, the package where it is declared
- -- is in use or the entity is declared in the current package, thus
+ -- Either the type itself is used, the package where it is declared is
+ -- in use or the entity is declared in the current package, thus
-- use-visible.
Is_Known_Used :=
- In_Use (T)
- or else In_Use (Scope (T))
- or else Scope (T) = Current_Scope;
+ (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));
elsif In_Open_Scopes (Scope (T)) then
null;
- -- A limited view cannot appear in a use_type clause. However, an access
+ -- A limited view cannot appear in a use_type_clause. However, an access
-- type whose designated type is limited has the flag but is not itself
-- a limited view unless we only have a limited view of its enclosing
-- package.
-- even if it is redundant at the place of the instantiation.
elsif Redundant_Use (Id) then
+
+ -- We must avoid incorrectly setting the Current_Use_Clause when we
+ -- are working with a redundant clause that has already been linked
+ -- in the Prev_Use_Clause chain, otherwise the chain will break.
+
+ if Present (Current_Use_Clause (T))
+ and then Present (Prev_Use_Clause (Current_Use_Clause (T)))
+ and then Parent (Id) = Prev_Use_Clause (Current_Use_Clause (T))
+ then
+ null;
+ else
+ Set_Current_Use_Clause (T, Parent (Id));
+ end if;
+
Set_Used_Operations (Parent (Id), New_Elmt_List);
-- If the subtype mark designates a subtype in a different package,
-- we have to check that the parent type is visible, otherwise the
- -- use type clause is a noop. Not clear how to do that???
+ -- use_type_clause is a no-op. Not clear how to do that???
else
+ 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 deemed available. Note that this is really necessary only
+ -- in semantics-only mode, because the primitive operators are not
+ -- fully constructed in this mode, but we do it in all modes for the
+ -- sake of uniformity, as this should not matter in practice.
if Is_Tagged_Type (T) then
Set_In_Use (Class_Wide_Type (T));
end if;
- Set_Current_Use_Clause (T, Parent (Id));
-
-- Iterate over primitive operations of the type. If an operation is
-- already use_visible, it is the result of a previous use_clause,
-- and already appears on the corresponding entity chain. If the
-- If warning on redundant constructs, check for unnecessary WITH
- if Warn_On_Redundant_Constructs
+ if not Force
+ and then Warn_On_Redundant_Constructs
and then Is_Known_Used
-- with P; with P; use P;
and then not Spec_Reloaded_For_Body
and then not In_Instance
+ and then not In_Inlined_Body
then
-- The type already has a use clause
if Present (Current_Use_Clause (T)) then
Use_Clause_Known : declare
- Clause1 : constant Node_Id := Parent (Id);
- Clause2 : constant Node_Id := 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;
Err_No : Node_Id;
Unit1 : Node_Id;
Unit2 : Node_Id;
- function Entity_Of_Unit (U : Node_Id) return Entity_Id;
- -- Return the appropriate entity for determining which unit
- -- has a deeper scope: the defining entity for U, unless U
- -- is a package instance, in which case we retrieve the
- -- entity of the instance spec.
-
- --------------------
- -- Entity_Of_Unit --
- --------------------
-
- function Entity_Of_Unit (U : Node_Id) return Entity_Id is
- begin
- if Nkind (U) = N_Package_Instantiation
- and then Analyzed (U)
- then
- return Defining_Entity (Instance_Spec (U));
- else
- return Defining_Entity (U);
- end if;
- end Entity_Of_Unit;
-
-- Start of processing for Use_Clause_Known
begin
- -- If both current use type clause and the use type clause
+ -- If both current use_type_clause and the use_type_clause
-- for the type are at the compilation unit level, one of
-- the units must be an ancestor of the other, and the
-- warning belongs on the descendant.
-- of the other, or one of them is in a subunit, report
-- redundancy on the later one.
- if Unit1 = Unit2 then
- Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
- Error_Msg_NE -- CODEFIX
- ("& is already use-visible through previous "
- & "use_type_clause #??", Clause1, T);
- return;
-
- elsif Nkind (Unit1) = N_Subunit then
+ if Unit1 = Unit2 or else Nkind (Unit1) = N_Subunit then
Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
Error_Msg_NE -- CODEFIX
("& is already use-visible through previous "
return;
end if;
- -- There is a redundant use type clause in a child unit.
+ -- There is a redundant use_type_clause in a child unit.
-- Determine which of the units is more deeply nested.
-- If a unit is a package instance, retrieve the entity
-- and its scope from the instance spec.
else
declare
- S1, S2 : Entity_Id;
+ S1 : Entity_Id;
+ S2 : Entity_Id;
begin
S1 := Scope (Ent1);
end;
end if;
- Error_Msg_NE -- CODEFIX
- ("& is already use-visible through previous "
- & "use_type_clause #??", Err_No, Id);
+ if Parent (Id) /= Err_No then
+ if Most_Descendant_Use_Clause
+ (Err_No, Parent (Id)) = Parent (Id)
+ then
+ Error_Msg_Sloc := Sloc (Err_No);
+ Err_No := Parent (Id);
+ end if;
- -- Case where current use type clause and the use type
- -- clause for the type are not both at the compilation unit
- -- level. In this case we don't have location information.
+ Error_Msg_NE -- CODEFIX
+ ("& is already use-visible through previous "
+ & "use_type_clause #??", Err_No, Id);
+ end if;
+
+ -- Case where current use_type_clause and use_type_clause
+ -- for the type are not both at the compilation unit level.
+ -- In this case we don't have location information.
else
Error_Msg_NE -- CODEFIX
("& is already use-visible through previous "
- & "use type clause??", Id, T);
+ & "use_type_clause??", Id, T);
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
("& is already use-visible through previous "
- & "use type clause??", Id, T);
+ & "use_type_clause??", Id, T);
end if;
-- The package where T is declared is already used
elsif In_Use (Scope (T)) then
- Error_Msg_Sloc := Sloc (Current_Use_Clause (Scope (T)));
- Error_Msg_NE -- CODEFIX
- ("& is already use-visible through package use clause #??",
- Id, T);
+ -- Due to expansion of contracts we could be attempting to issue
+ -- a spurious warning - so verify there is a previous use clause.
+
+ if Current_Use_Clause (Scope (T)) /=
+ Find_Most_Prev (Current_Use_Clause (Scope (T)))
+ then
+ 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);
+ end if;
-- The current scope is the package where T is declared
projects / thirdparty / gcc.git / blobdiff