Skip to content

R
riscv-gcc-1
Commit 294ccb21 by Robert Dewar Committed by Arnaud Charlet
Options

sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for renaming… 

sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for renaming entry as subprogram using rename-as-body if...

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

	* sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for
	renaming entry as subprogram using rename-as-body if subprogram spec
	frozen.
	(Use_One_Type): The clause is legal on an access type whose designated
	type has a limited view.
	(Find_Direct_Name): Use Namet.Sp.Is_Bad_Spelling_Of function
	(Find_Expanded_Name): Use Namet.Sp.Is_Bad_Spelling_Of function
	(Analyze_Renamed_Primitive_Operation): new procedure to determine the
	operation denoted by a selected component.
	(Analyze_Renamed_Entry): Resolve the prefix of the entry name, because
	it can be an expression, possibly overloaded, that returns a task or
	an access to one.

From-SVN: r130854
parent d469eabe
Showing with 257 additions and 53 deletions
gcc/ada/sem_ch8.adb
......@@ -37,6 +37,7 @@ with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Namet.Sp; use Namet.Sp;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
......@@ -64,8 +65,6 @@ with Table;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
package body Sem_Ch8 is
------------------------------------
......@@ -388,6 +387,14 @@ package body Sem_Ch8 is
-- Used when the renamed entity is an indexed component. The prefix must
-- denote an entry family.
procedure Analyze_Renamed_Primitive_Operation
(N : Node_Id;
New_S : Entity_Id;
Is_Body : Boolean);
-- If the renamed entity in a subprogram renaming is a primitive operation
-- or a class-wide operation in prefix form, save the target object, which
-- must be added to the list of actuals in any subsequent call.
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
......@@ -974,7 +981,7 @@ package body Sem_Ch8 is
end if;
-- Apply Text_IO kludge here, since we may be renaming one of the
-- children of Text_IO
-- children of Text_IO.
Text_IO_Kludge (Name (N));
......@@ -1014,6 +1021,8 @@ package body Sem_Ch8 is
Set_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
-- Here for OK package renaming
else
-- Entities in the old package are accessible through the renaming
-- entity. The simplest implementation is to have both packages share
......@@ -1036,6 +1045,24 @@ package body Sem_Ch8 is
Check_Library_Unit_Renaming (N, Old_P);
Generate_Reference (Old_P, Name (N));
-- If the renaming is in the visible part of a package, then we set
-- In_Package_Spec for the renamed package, to prevent giving
-- warnings about no entities referenced. Such a warning would be
-- overenthusiastic, since clients can see entities in the renamed
-- package via the visible package renaming.
declare
Ent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
begin
if Ekind (Ent) = E_Package
and then not In_Private_Part (Ent)
and then In_Extended_Main_Source_Unit (N)
and then Ekind (Old_P) = E_Package
then
Set_Renamed_In_Spec (Old_P);
end if;
end;
-- If this is the renaming declaration of a package instantiation
-- within itself, it is the declaration that ends the list of actuals
-- for the instantiation. At this point, the subtypes that rename
......@@ -1084,7 +1111,6 @@ package body Sem_Ch8 is
end;
end if;
end if;
end Analyze_Package_Renaming;
-------------------------------
......@@ -1210,6 +1236,11 @@ package body Sem_Ch8 is
end if;
Inherit_Renamed_Profile (New_S, Old_S);
-- The prefix can be an arbitrary expression that yields a task
-- type, so it must be resolved.
Resolve (Prefix (Nam), Scope (Old_S));
end if;
Set_Convention (New_S, Convention (Old_S));
......@@ -1265,6 +1296,114 @@ package body Sem_Ch8 is
end if;
end Analyze_Renamed_Family_Member;
-----------------------------------------
-- Analyze_Renamed_Primitive_Operation --
-----------------------------------------
procedure Analyze_Renamed_Primitive_Operation
(N : Node_Id;
New_S : Entity_Id;
Is_Body : Boolean)
is
Old_S : Entity_Id;
function Conforms
(Subp : Entity_Id;
Ctyp : Conformance_Type) return Boolean;
-- Verify that the signatures of the renamed entity and the new entity
-- match. The first formal of the renamed entity is skipped because it
-- is the target object in any subsequent call.
function Conforms
(Subp : Entity_Id;
Ctyp : Conformance_Type) return Boolean
is
Old_F : Entity_Id;
New_F : Entity_Id;
begin
if Ekind (Subp) /= Ekind (New_S) then
return False;
end if;
Old_F := Next_Formal (First_Formal (Subp));
New_F := First_Formal (New_S);
while Present (Old_F) and then Present (New_F) loop
if not Conforming_Types (Etype (Old_F), Etype (New_F), Ctyp) then
return False;
end if;
if Ctyp >= Mode_Conformant
and then Ekind (Old_F) /= Ekind (New_F)
then
return False;
end if;
Next_Formal (New_F);
Next_Formal (Old_F);
end loop;
return True;
end Conforms;
begin
if not Is_Overloaded (Selector_Name (Name (N))) then
Old_S := Entity (Selector_Name (Name (N)));
if not Conforms (Old_S, Type_Conformant) then
Old_S := Any_Id;
end if;
else
-- Find the operation that matches the given signature
declare
It : Interp;
Ind : Interp_Index;
begin
Old_S := Any_Id;
Get_First_Interp (Selector_Name (Name (N)), Ind, It);
while Present (It.Nam) loop
if Conforms (It.Nam, Type_Conformant) then
Old_S := It.Nam;
end if;
Get_Next_Interp (Ind, It);
end loop;
end;
end if;
if Old_S = Any_Id then
Error_Msg_N (" no subprogram or entry matches specification", N);
else
if Is_Body then
if not Conforms (Old_S, Subtype_Conformant) then
Error_Msg_N ("subtype conformance error in renaming", N);
end if;
Generate_Reference (New_S, Defining_Entity (N), 'b');
Style.Check_Identifier (Defining_Entity (N), New_S);
else
-- Only mode conformance required for a renaming_as_declaration
if not Conforms (Old_S, Mode_Conformant) then
Error_Msg_N ("mode conformance error in renaming", N);
end if;
end if;
-- Inherit_Renamed_Profile (New_S, Old_S);
-- The prefix can be an arbitrary expression that yields an
-- object, so it must be resolved.
Resolve (Prefix (Name (N)));
end if;
end Analyze_Renamed_Primitive_Operation;
---------------------------------
-- Analyze_Subprogram_Renaming --
---------------------------------
......@@ -1573,14 +1712,17 @@ package body Sem_Ch8 is
Rename_Spec := Find_Corresponding_Spec (N);
-- Case of Renaming_As_Body
if Present (Rename_Spec) then
-- Renaming_As_Body. Renaming declaration is the completion of
-- the declaration of Rename_Spec. We will build an actual body
-- for it at the freezing point.
-- Renaming declaration is the completion of the declaration of
-- Rename_Spec. We build an actual body for it at the freezing point.
Set_Corresponding_Spec (N, Rename_Spec);
-- Deal with special case of Input and Output stream functions
if Nkind (Unit_Declaration_Node (Rename_Spec)) =
N_Abstract_Subprogram_Declaration
then
......@@ -1622,6 +1764,13 @@ package body Sem_Ch8 is
Check_Fully_Conformant (New_S, Rename_Spec);
Set_Public_Status (New_S);
-- The specification does not introduce new formals, but only
-- repeats the formals of the original subprogram declaration.
-- For cross-reference purposes, and for refactoring tools, we
-- treat the formals of the renaming declaration as body formals.
Reference_Body_Formals (Rename_Spec, New_S);
-- Indicate that the entity in the declaration functions like the
-- corresponding body, and is not a new entity. The body will be
-- constructed later at the freeze point, so indicate that the
......@@ -1645,6 +1794,8 @@ package body Sem_Ch8 is
("subprogram& overrides inherited operation", N, Rename_Spec);
end if;
-- Normal subprogram renaming (not renaming as body)
else
Generate_Definition (New_S);
New_Overloaded_Entity (New_S);
......@@ -1671,12 +1822,57 @@ package body Sem_Ch8 is
elsif Nkind (Nam) = N_Selected_Component then
-- Renamed entity is an entry or protected subprogram. For those
-- cases an explicit body is built (at the point of freezing of this
-- entity) that contains a call to the renamed entity.
-- A prefix of the form A.B can designate an entry of task A, a
-- protected operation of protected object A, or finally a primitive
-- operation of object A. In the later case, A is an object of some
-- tagged type, or an access type that denotes one such. To further
-- distinguish these cases, note that the scope of a task entry or
-- protected operation is type of the prefix.
-- The prefix could be an overloaded function call that returns both
-- kinds of operations. This overloading pathology is left to the
-- dedicated reader ???
declare
T : constant Entity_Id := Etype (Prefix (Nam));
begin
if Present (T)
and then
(Is_Tagged_Type (T)
or else
(Is_Access_Type (T)
and then
Is_Tagged_Type (Designated_Type (T))))
and then Scope (Entity (Selector_Name (Nam))) /= T
then
Analyze_Renamed_Primitive_Operation
(N, New_S, Present (Rename_Spec));
return;
else
-- Renamed entity is an entry or protected operation. For those
-- cases an explicit body is built (at the point of freezing of
-- this entity) that contains a call to the renamed entity.
-- This is not allowed for renaming as body if the renamed
-- spec is already frozen (see RM 8.5.4(5) for details).
if Present (Rename_Spec)
and then Is_Frozen (Rename_Spec)
then
Error_Msg_N
("renaming-as-body cannot rename entry as subprogram", N);
Error_Msg_NE
("\since & is already frozen (RM 8.5.4(5))",
N, Rename_Spec);
else
Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec));
end if;
return;
end if;
end;
elsif Nkind (Nam) = N_Explicit_Dereference then
......@@ -2760,8 +2956,8 @@ package body Sem_Ch8 is
Pop_Scope;
while not (Is_List_Member (Decl))
or else Nkind (Parent (Decl)) = N_Protected_Definition
or else Nkind (Parent (Decl)) = N_Task_Definition
or else Nkind_In (Parent (Decl), N_Protected_Definition,
N_Task_Definition)
loop
Decl := Parent (Decl);
end loop;
......@@ -3339,10 +3535,7 @@ package body Sem_Ch8 is
if Nkind (N) = N_Identifier
and then Nkind (Parent (N)) = N_Case_Statement_Alternative
then
Get_Name_String (Chars (N));
declare
Case_Str : constant String := Name_Buffer (1 .. Name_Len);
Case_Stm : constant Node_Id := Parent (Parent (N));
Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm));
Case_Rtp : constant Entity_Id := Root_Type (Case_Typ);
......@@ -3359,9 +3552,7 @@ package body Sem_Ch8 is
Get_Name_String (Chars (Lit));
if Chars (Lit) /= Chars (N)
and then Is_Bad_Spelling_Of
(Case_Str, Name_Buffer (1 .. Name_Len))
then
and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) then
Error_Msg_Node_2 := Lit;
Error_Msg_N
("& is undefined, assume misspelling of &", N);
......@@ -3445,8 +3636,6 @@ package body Sem_Ch8 is
-- Now check for possible misspellings
Get_Name_String (Chars (N));
declare
E : Entity_Id;
Ematch : Entity_Id := Empty;
......@@ -3455,23 +3644,16 @@ package body Sem_Ch8 is
Name_Id (Nat (First_Name_Id) +
Name_Entries_Count - 1);
S : constant String (1 .. Name_Len) :=
Name_Buffer (1 .. Name_Len);
begin
for N in First_Name_Id .. Last_Name_Id loop
E := Get_Name_Entity_Id (N);
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
Get_Name_String (N);
if Is_Bad_Spelling_Of
(S, Name_Buffer (1 .. Name_Len))
then
if Is_Bad_Spelling_Of (Chars (N), Nam) then
Ematch := E;
exit;
end if;
......@@ -3812,6 +3994,18 @@ package body Sem_Ch8 is
<<Found>> begin
-- When distribution features are available (Get_PCS_Name /=
-- Name_No_DSA), a remote access-to-subprogram type is converted
-- into a record type holding whatever information is needed to
-- perform a remote call on an RCI suprogram. In that case we
-- rewrite any occurrence of the RAS type into the equivalent record
-- type here. 'Access attribute references and RAS dereferences are
-- then implemented using specific TSSs. However when distribution is
-- not available (case of Get_PCS_Name = Name_No_DSA), we bypass the
-- generation of these TSSs, and we must keep the RAS type in its
-- original access-to-subprogram form (since all calls through a
-- value of such type will be local anyway in the absence of a PCS).
if Comes_From_Source (N)
and then Is_Remote_Access_To_Subprogram_Type (E)
and then Expander_Active
......@@ -3875,17 +4069,28 @@ package body Sem_Ch8 is
-- to the discriminant in the initialization procedure.
else
-- Entity is unambiguous, indicate that it is referenced here. One
-- slightly odd case is that we do not want to set the Referenced
-- flag if the entity is a label, and the identifier is the label
-- in the source, since this is not a reference from the point of
-- view of the user
-- Entity is unambiguous, indicate that it is referenced here
-- For a renaming of an object, always generate simple reference,
-- we don't try to keep track of assignments in this case.
if Is_Object (E) and then Present (Renamed_Object (E)) then
Generate_Reference (E, N);
-- One odd case is that we do not want to set the Referenced flag
-- if the entity is a label, and the identifier is the label in
-- the source, since this is not a reference from the point of
-- view of the user.
if Nkind (Parent (N)) = N_Label then
elsif Nkind (Parent (N)) = N_Label then
declare
R : constant Boolean := Referenced (E);
begin
if not Is_Actual_Parameter then
-- Generate reference unless this is an actual parameter
-- (see comment below)
if Is_Actual_Parameter then
Generate_Reference (E, N);
Set_Referenced (E, R);
end if;
......@@ -3938,8 +4143,8 @@ package body Sem_Ch8 is
begin
P := Parent (N);
while Present (P)
and then Nkind (P) /= N_Parameter_Specification
and then Nkind (P) /= N_Component_Declaration
and then not Nkind_In (P, N_Parameter_Specification,
N_Component_Declaration)
loop
P := Parent (P);
end loop;
......@@ -4225,16 +4430,8 @@ package body Sem_Ch8 is
-- Check for misspelling of some entity in prefix
Id := First_Entity (P_Name);
Get_Name_String (Chars (Selector));
declare
S : constant String (1 .. Name_Len) :=
Name_Buffer (1 .. Name_Len);
begin
while Present (Id) loop
Get_Name_String (Chars (Id));
if Is_Bad_Spelling_Of
(Name_Buffer (1 .. Name_Len), S)
if Is_Bad_Spelling_Of (Chars (Id), Chars (Selector))
and then not Is_Internal_Name (Chars (Id))
then
Error_Msg_NE
......@@ -4244,7 +4441,6 @@ package body Sem_Ch8 is
Next_Entity (Id);
end loop;
end;
-- Specialize the message if this may be an instantiation
-- of a child unit that was not mentioned in the context.
......@@ -6179,9 +6375,11 @@ package body Sem_Ch8 is
The_Unit := Unit (Cunit (Current_Sem_Unit));
if No (With_Sys)
and then (Nkind (The_Unit) = N_Package_Body
and then
(Nkind (The_Unit) = N_Package_Body
or else (Nkind (The_Unit) = N_Subprogram_Body
and then not Acts_As_Spec (Cunit (Current_Sem_Unit))))
and then
not Acts_As_Spec (Cunit (Current_Sem_Unit))))
then
With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
end if;
......@@ -6193,7 +6391,6 @@ package body Sem_Ch8 is
-- context as well (Current_Sem_Unit is the parent unit);
The_Unit := Parent (N);
while Nkind (The_Unit) /= N_Compilation_Unit loop
The_Unit := Parent (The_Unit);
end loop;
......@@ -6694,7 +6891,14 @@ package body Sem_Ch8 is
if In_Open_Scopes (Scope (T)) then
null;
elsif From_With_Type (T) then
-- 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.
elsif From_With_Type (T)
and then From_With_Type (Scope (T))
then
Error_Msg_N
("incomplete type from limited view "
& "cannot appear in use clause", Id);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment