[Ada] New warning on use clauses
Arnaud Charlet
charlet@adacore.com
Tue Nov 15 14:42:00 GMT 2005
Tested on i686-linux, committed on trunk
This patch implements a new warning mechanism that reports the presence
of a redundant use clause. A use clause is redundant if the designated
package is already use-visible through another use clause in the current
unit, or a use clause in a related library unit or parent unit. The
warning indicates the use clause that makes the current one redunndant.
Also fix handling of generic and subprogram renaming.
The following code must compile quietly:
package OOP is
end OOP;
--
with Ada.Streams;
generic
type Root is tagged private;
package OOP.XML_Class_IO is
--
procedure Output
(Stream : access Ada.Streams.Root_Stream_Type'Class;
Object : Root'Class);
end OOP.XML_Class_IO;
--
with Ada.Tags.Generic_Dispatching_Constructor;
with Common.XML;
package body OOP.XML_Class_IO is
--
function Get_Object is new Ada.Tags.Generic_Dispatching_Constructor
(T => Root,
Parameters => Ada.Streams.Root_Stream_Type'Class,
Constructor => Root'Input);
--
procedure Output
(Stream : access Ada.Streams.Root_Stream_Type'Class;
Object : Root'Class)
is
Tag : constant String := Ada.Tags.External_Tag (Object'Tag);
begin
Root'Output (Stream, Object);
end Output;
end OOP.XML_Class_IO;
The following code must be rejected:
--
package C is
type T is (A, B, C);
Enum : T renames A; -- OK
Next_T : T renames T'succ (A); -- OK
Last_T : T renames T'Last; -- Error
end C;
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.
-------------- next part --------------
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 106884)
+++ sem_ch8.adb (working copy)
@@ -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 @@
-- 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 @@
-- 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 @@
(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 @@
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 @@
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 @@
-- 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 @@
-- 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 @@
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 @@
----------------------
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 @@
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 @@
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 @@
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 @@
-- 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 @@
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 @@
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 @@
end if;
Set_In_Use (P);
+ Set_Current_Use_Clause (P, N);
-- Ada 2005 (AI-50217): Check restriction
@@ -5788,6 +6041,7 @@
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;
More information about the Gcc-patches
mailing list