sem_ch8.adb (Analyze_Subprogram_Renaming): In a generic context...
2005-11-14 Ed Schonberg <schonberg@adacore.com> * sem_ch8.adb (Analyze_Subprogram_Renaming): In a generic context, do not try to rewrite a renamed stream attribute, because the operations on the type may not have been generated. Handle properly a renaming_as_body generated for a stream operation whose default is abstract because the object type itself is abstract. (Find_Type): If the type is incomplete and appears as the prefix of a 'Class reference, it is tagged, and its list of primitive operations must be initialized properly. (Chain_Use_Clauses): When chaining the use clauses that appear in the private declaration of a parent unit, prior to compiling the private part of a child unit, find on the scope stack the proper parent entity on which to link the use clause. (Note_Redundant_Use): Emit a warning when a redundant use clause is detected. (Analyze_Object_Renaming): An attribute reference is not a legal object if it is not a function call. From-SVN: r107003
This commit is contained in:
parent
a59e9305af
commit
d4810530b8
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2005, 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- --
|
||||
|
@ -424,8 +424,13 @@ package body Sem_Ch8 is
|
|||
-- an instance of the parent.
|
||||
|
||||
procedure Chain_Use_Clause (N : Node_Id);
|
||||
-- Chain use clause onto list of uses clauses headed by First_Use_Clause
|
||||
-- in the top scope table entry.
|
||||
-- Chain use clause onto list of uses clauses headed by First_Use_Clause in
|
||||
-- the proper scope table entry. This is usually the current scope, but it
|
||||
-- will be an inner scope when installing the use clauses of the private
|
||||
-- declarations of a parent unit prior to compiling the private part of a
|
||||
-- child unit. This chain is traversed when installing/removing use clauses
|
||||
-- when compiling a subunit or instantiating a generic body on the fly,
|
||||
-- when it is necessary to save and restore full environments.
|
||||
|
||||
function Has_Implicit_Character_Literal (N : Node_Id) return Boolean;
|
||||
-- Find a type derived from Character or Wide_Character in the prefix of N.
|
||||
|
@ -473,6 +478,11 @@ package body Sem_Ch8 is
|
|||
-- 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.
|
||||
|
||||
procedure Premature_Usage (N : Node_Id);
|
||||
-- Diagnose usage of an entity before it is visible
|
||||
|
||||
|
@ -768,9 +778,13 @@ package body Sem_Ch8 is
|
|||
(Attribute_Name (Original_Node (Nam))))
|
||||
|
||||
-- Weird but legal, equivalent to renaming a function call
|
||||
-- Illegal if the literal is the result of constant-folding
|
||||
-- an attribute reference that is not a function.
|
||||
|
||||
or else (Is_Entity_Name (Nam)
|
||||
and then Ekind (Entity (Nam)) = E_Enumeration_Literal)
|
||||
and then Ekind (Entity (Nam)) = E_Enumeration_Literal
|
||||
and then
|
||||
Nkind (Original_Node (Nam)) /= N_Attribute_Reference)
|
||||
|
||||
or else (Nkind (Nam) = N_Type_Conversion
|
||||
and then Is_Tagged_Type (Entity (Subtype_Mark (Nam))))
|
||||
|
@ -833,7 +847,7 @@ package body Sem_Ch8 is
|
|||
Error_Msg_N
|
||||
("expect package name in renaming", Name (N));
|
||||
|
||||
-- Ada 2005 (AI-50217): Limited withed packages can not be renamed
|
||||
-- Ada 2005 (AI-50217): Limited withed packages cannot be renamed
|
||||
|
||||
elsif Ekind (Old_P) = E_Package
|
||||
and then From_With_Type (Old_P)
|
||||
|
@ -1049,7 +1063,7 @@ package body Sem_Ch8 is
|
|||
Style.Check_Identifier (Defining_Entity (N), New_S);
|
||||
|
||||
else
|
||||
-- Only mode conformance required for a renaming_as_declaration.
|
||||
-- Only mode conformance required for a renaming_as_declaration
|
||||
|
||||
Check_Mode_Conformant (New_S, Old_S, N);
|
||||
end if;
|
||||
|
@ -1190,7 +1204,13 @@ package body Sem_Ch8 is
|
|||
-- rewrite an actual given by a stream attribute as the name
|
||||
-- of the corresponding stream primitive of the type.
|
||||
|
||||
if Is_Actual and then Is_Abstract (Formal_Spec) then
|
||||
-- In a generic context the stream operations are not generated,
|
||||
-- and this must be treated as a normal attribute reference, to
|
||||
-- be expanded in subsequent instantiations.
|
||||
|
||||
if Is_Actual and then Is_Abstract (Formal_Spec)
|
||||
and then Expander_Active
|
||||
then
|
||||
declare
|
||||
Stream_Prim : Entity_Id;
|
||||
Prefix_Type : constant Entity_Id := Entity (Prefix (Nam));
|
||||
|
@ -1354,6 +1374,37 @@ package body Sem_Ch8 is
|
|||
-- for it at the freezing point.
|
||||
|
||||
Set_Corresponding_Spec (N, Rename_Spec);
|
||||
if Nkind (Unit_Declaration_Node (Rename_Spec)) =
|
||||
N_Abstract_Subprogram_Declaration
|
||||
then
|
||||
-- Input and Output stream functions are abstract if the object
|
||||
-- type is abstract. However, these functions may receive explicit
|
||||
-- declarations in representation clauses, making the attribute
|
||||
-- subprograms usable as defaults in subsequent type extensions.
|
||||
-- In this case we rewrite the declaration to make the subprogram
|
||||
-- non-abstract. We remove the previous declaration, and insert
|
||||
-- the new one at the point of the renaming, to prevent premature
|
||||
-- access to unfrozen types. The new declaration reuses the
|
||||
-- specification of the previous one, and must not be analyzed.
|
||||
|
||||
pragma Assert (Is_TSS (Rename_Spec, TSS_Stream_Output)
|
||||
or else Is_TSS (Rename_Spec, TSS_Stream_Input));
|
||||
|
||||
declare
|
||||
Old_Decl : constant Node_Id :=
|
||||
Unit_Declaration_Node (Rename_Spec);
|
||||
New_Decl : constant Node_Id :=
|
||||
Make_Subprogram_Declaration (Sloc (N),
|
||||
Specification =>
|
||||
Relocate_Node (Specification (Old_Decl)));
|
||||
begin
|
||||
Remove (Old_Decl);
|
||||
Insert_After (N, New_Decl);
|
||||
Set_Is_Abstract (Rename_Spec, False);
|
||||
Set_Analyzed (New_Decl);
|
||||
end;
|
||||
end if;
|
||||
|
||||
Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S);
|
||||
|
||||
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
|
||||
|
@ -1914,13 +1965,13 @@ package body Sem_Ch8 is
|
|||
return False;
|
||||
|
||||
elsif In_Use (Pack) then
|
||||
Set_Redundant_Use (Pack_Name, True);
|
||||
Note_Redundant_Use (Pack_Name);
|
||||
return False;
|
||||
|
||||
elsif Present (Renamed_Object (Pack))
|
||||
and then In_Use (Renamed_Object (Pack))
|
||||
then
|
||||
Set_Redundant_Use (Pack_Name, True);
|
||||
Note_Redundant_Use (Pack_Name);
|
||||
return False;
|
||||
|
||||
else
|
||||
|
@ -2142,10 +2193,38 @@ package body Sem_Ch8 is
|
|||
----------------------
|
||||
|
||||
procedure Chain_Use_Clause (N : Node_Id) is
|
||||
Pack : Entity_Id;
|
||||
Level : Int := Scope_Stack.Last;
|
||||
|
||||
begin
|
||||
if not Is_Compilation_Unit (Current_Scope)
|
||||
or else not Is_Child_Unit (Current_Scope)
|
||||
then
|
||||
null; -- Common case
|
||||
|
||||
elsif Defining_Entity (Parent (N)) = Current_Scope then
|
||||
null; -- Common case for compilation unit
|
||||
|
||||
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
|
||||
|
||||
else
|
||||
-- Find entry for parent unit in scope stack
|
||||
|
||||
while Scope_Stack.Table (Level).Entity /= Pack loop
|
||||
Level := Level - 1;
|
||||
end loop;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Set_Next_Use_Clause (N,
|
||||
Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause);
|
||||
Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := N;
|
||||
Scope_Stack.Table (Level).First_Use_Clause);
|
||||
Scope_Stack.Table (Level).First_Use_Clause := N;
|
||||
end Chain_Use_Clause;
|
||||
|
||||
---------------------------
|
||||
|
@ -2476,6 +2555,7 @@ package body Sem_Ch8 is
|
|||
|
||||
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
|
||||
|
@ -2510,6 +2590,7 @@ package body Sem_Ch8 is
|
|||
|
||||
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
|
||||
|
@ -4552,7 +4633,9 @@ package body Sem_Ch8 is
|
|||
|
||||
T := Base_Type (Entity (Prefix (N)));
|
||||
|
||||
-- Case of non-tagged type
|
||||
-- Case type is not known to be tagged. Its appearance in
|
||||
-- the prefix of the 'Class attribute indicates that the full
|
||||
-- view will be tagged.
|
||||
|
||||
if not Is_Tagged_Type (T) then
|
||||
if Ekind (T) = E_Incomplete_Type then
|
||||
|
@ -4561,6 +4644,7 @@ package body Sem_Ch8 is
|
|||
-- type. The full type will have to be tagged, of course.
|
||||
|
||||
Set_Is_Tagged_Type (T);
|
||||
Set_Primitive_Operations (T, New_Elmt_List);
|
||||
Make_Class_Wide_Type (T);
|
||||
Set_Entity (N, Class_Wide_Type (T));
|
||||
Set_Etype (N, Class_Wide_Type (T));
|
||||
|
@ -5118,12 +5202,12 @@ package body Sem_Ch8 is
|
|||
if Ekind (Id) = E_Package then
|
||||
|
||||
if In_Use (Id) then
|
||||
Set_Redundant_Use (P, True);
|
||||
Note_Redundant_Use (P);
|
||||
|
||||
elsif Present (Renamed_Object (Id))
|
||||
and then In_Use (Renamed_Object (Id))
|
||||
then
|
||||
Set_Redundant_Use (P, True);
|
||||
Note_Redundant_Use (P);
|
||||
|
||||
elsif Force_Installation or else Applicable_Use (P) then
|
||||
Use_One_Package (Id, U);
|
||||
|
@ -5294,6 +5378,174 @@ package body Sem_Ch8 is
|
|||
end if;
|
||||
end New_Scope;
|
||||
|
||||
------------------------
|
||||
-- Note_Redundant_Use --
|
||||
------------------------
|
||||
|
||||
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);
|
||||
|
||||
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
|
||||
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.
|
||||
|
||||
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 =
|
||||
Defining_Entity (
|
||||
Unit (Library_Unit (Cunit (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 redudant 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)));
|
||||
|
||||
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;
|
||||
end if;
|
||||
|
||||
else
|
||||
null;
|
||||
end if;
|
||||
|
||||
if Present (Redundant) then
|
||||
Error_Msg_Sloc := Sloc (Prev_Use);
|
||||
Error_Msg_NE (
|
||||
"& is already use_visible through declaration #?",
|
||||
Redundant, Pack_Name);
|
||||
end if;
|
||||
end Note_Redundant_Use;
|
||||
|
||||
---------------
|
||||
-- Pop_Scope --
|
||||
---------------
|
||||
|
@ -5760,6 +6012,7 @@ package body Sem_Ch8 is
|
|||
end if;
|
||||
|
||||
Set_In_Use (P);
|
||||
Set_Current_Use_Clause (P, N);
|
||||
|
||||
-- Ada 2005 (AI-50217): Check restriction
|
||||
|
||||
|
@ -5788,6 +6041,7 @@ package body Sem_Ch8 is
|
|||
|
||||
if Present (Renamed_Object (P)) then
|
||||
Set_In_Use (Renamed_Object (P));
|
||||
Set_Current_Use_Clause (Renamed_Object (P), N);
|
||||
Real_P := Renamed_Object (P);
|
||||
else
|
||||
Real_P := P;
|
||||
|
|
Loading…
Reference in New Issue