Skip to content

R
riscv-gcc-1
Commit 1420b484 by Javier Miranda Committed by Arnaud Charlet
Options

sem_res.adb (Resolve_Membership_Op): In case of the membership test… 

sem_res.adb (Resolve_Membership_Op): In case of the membership test "Iface_CW_Typ in T'Class" we have nothing else...

2005-09-01  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* sem_res.adb (Resolve_Membership_Op): In case of the membership test
	"Iface_CW_Typ in T'Class" we have nothing else to do in the frontend;
	the expander will generate the corresponding run-time check to evaluate
	the expression.
	(Resolve_Call): Check for legal type of procedure name or prefix that
	appears as a trigger in a triggering alternative.
	(Valid_Conversion): If expression is ambiguous and the context involves
	an extension of System, remove System.Address interpretations.
	(Resolve_Qualified_Expression): Reject the case of a specific-type
	qualification applied to a class-wide argument. Enhance comment
	to explain checking of Original_Node.
	(Resolve_Type_Conversion): The location of the error message was not
	general enough to handle the general case and hence it has been removed.
	In addition, this patch improves the text of the message.
	(Resolve_Type_Conversion): Add missing support for access to interface
	types.
	(Resolve_Type_Conversion): If the target is a class-wide interface type,
	do not expand if the expression is the actual in a call, because proper
	expansion will take place when the call itself is expanded.
	(Resolve_Allocator): If the context is an unchecked conversion, the
	allocator inherits its storage pool, if any, from the target type of
	the conversion.

From-SVN: r103886
parent 9cca32af
Showing with 103 additions and 71 deletions
gcc/ada/sem_res.adb
......@@ -244,15 +244,11 @@ package body Sem_Res is
("\possible interpretations: Character, Wide_Character!", C);
E := Current_Entity (C);
if Present (E) then
while Present (E) loop
Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
E := Homonym (E);
end loop;
end if;
end if;
end Ambiguous_Character;
-------------------------
......@@ -557,7 +553,6 @@ package body Sem_Res is
else
D := PN;
P := Parent (PN);
while Nkind (P) /= N_Component_Declaration
and then Nkind (P) /= N_Subtype_Indication
and then Nkind (P) /= N_Entry_Declaration
......@@ -742,9 +737,7 @@ package body Sem_Res is
elsif Is_Record_Type (T) then
Comp := First_Component (T);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = N_Component_Declaration
then
......@@ -996,9 +989,7 @@ package body Sem_Res is
else
Get_First_Interp (Nod, I, It);
while Present (It.Typ) loop
if Scope (Base_Type (It.Typ)) = S then
return True;
end if;
......@@ -1066,9 +1057,7 @@ package body Sem_Res is
else
E := First_Entity (Pack);
while Present (E) loop
if Test (E)
and then not In_Decl
then
......@@ -1672,10 +1661,9 @@ package body Sem_Res is
-- is compatible with the context (i.e. the type passed to Resolve)
else
Get_First_Interp (N, I, It);
-- Loop through possible interpretations
Get_First_Interp (N, I, It);
Interp_Loop : while Present (It.Typ) loop
-- We are only interested in interpretations that are compatible
......@@ -1726,10 +1714,11 @@ package body Sem_Res is
or else Nkind (N) = N_Procedure_Call_Statement
then
declare
A : Node_Id := First_Actual (N);
A : Node_Id;
E : Node_Id;
begin
A := First_Actual (N);
while Present (A) loop
E := A;
......@@ -2076,10 +2065,9 @@ package body Sem_Res is
begin
Error_Msg_N ("\possible interpretations:", N);
Get_First_Interp (Name (N), Index, It);
Get_First_Interp (Name (N), Index, It);
while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_Node_2 := It.Typ;
Error_Msg_NE ("\& declared#, type&",
......@@ -2769,10 +2757,9 @@ package body Sem_Res is
if Ada_Version >= Ada_05
and then Is_Access_Type (F_Typ)
and then (Can_Never_Be_Null (F)
or else Can_Never_Be_Null (F_Typ))
and then Can_Never_Be_Null (F_Typ)
and then Nkind (A) = N_Null
then
if Nkind (A) = N_Null then
Apply_Compile_Time_Constraint_Error
(N => A,
Msg => "(Ada 2005) NULL not allowed in "
......@@ -2780,7 +2767,6 @@ package body Sem_Res is
Reason => CE_Null_Not_Allowed);
end if;
end if;
end if;
if Ekind (F) = E_Out_Parameter
or else Ekind (F) = E_In_Out_Parameter
......@@ -3013,7 +2999,6 @@ package body Sem_Res is
if Has_Discriminants (Subtyp) then
Discrim := First_Discriminant (Base_Type (Subtyp));
Constr := First (Constraints (Constraint (Original_Node (E))));
while Present (Discrim) and then Present (Constr) loop
if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
if Nkind (Constr) = N_Discriminant_Association then
......@@ -3104,7 +3089,6 @@ package body Sem_Res is
if No_Pool_Assigned (Typ) then
declare
Loc : constant Source_Ptr := Sloc (N);
begin
Error_Msg_N ("?allocation from empty storage pool!", N);
Error_Msg_N ("?Storage_Error will be raised at run time!", N);
......@@ -3112,6 +3096,17 @@ package body Sem_Res is
Make_Raise_Storage_Error (Loc,
Reason => SE_Empty_Storage_Pool));
end;
-- If the context is an unchecked conversion, as may happen within
-- an inlined subprogram, the allocator is being resolved with its
-- own anonymous type. In that case, if the target type has a specific
-- storage pool, it must be inherited explicitly by the allocator type.
elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
and then No (Associated_Storage_Pool (Typ))
then
Set_Associated_Storage_Pool
(Typ, Associated_Storage_Pool (Etype (Parent (N))));
end if;
end Resolve_Allocator;
......@@ -3161,9 +3156,7 @@ package body Sem_Res is
or else T = Universal_Real;
else
Get_First_Interp (N, Index, It);
while Present (It.Typ) loop
if Base_Type (It.Typ) = Base_Type (Standard_Integer)
or else It.Typ = Universal_Integer
or else It.Typ = Universal_Real
......@@ -3251,7 +3244,6 @@ package body Sem_Res is
-- interpretation or an integer interpretation, but not both.
Get_First_Interp (N, Index, It);
while Present (It.Typ) loop
if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
......@@ -3548,9 +3540,9 @@ package body Sem_Res is
-- return type that is compatible with the context. Analysis of
-- the node has established that one exists.
Get_First_Interp (Subp, I, It);
Nam := Empty;
Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop
if Covers (Typ, Etype (It.Typ)) then
Nam := It.Typ;
......@@ -3609,10 +3601,9 @@ package body Sem_Res is
else
pragma Assert (Is_Overloaded (Subp));
Nam := Empty; -- We know that it will be assigned in loop below.
Nam := Empty; -- We know that it will be assigned in loop below
Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop
if Covers (Typ, It.Typ) then
Nam := It.Nam;
......@@ -3714,7 +3705,23 @@ package body Sem_Res is
and then Nkind (N) /= N_Entry_Call_Statement
and then Entry_Call_Statement (Parent (N)) = N
then
if Ada_Version < Ada_05 then
Error_Msg_N ("entry call required in select statement", N);
-- Ada 2005 (AI-345): If a procedure_call_statement is used
-- for a procedure_or_entry_call, the procedure_name or pro-
-- cedure_prefix of the procedure_call_statement shall denote
-- an entry renamed by a procedure, or (a view of) a primitive
-- subprogram of a limited interface whose first parameter is
-- a controlling parameter.
elsif Nkind (N) = N_Procedure_Call_Statement
and then not Is_Renamed_Entry (Nam)
and then not Is_Controlling_Limited_Procedure (Nam)
then
Error_Msg_N
("procedure or entry call required in select statement", N);
end if;
end if;
-- Check that this is not a call to a protected procedure or
......@@ -4050,7 +4057,6 @@ package body Sem_Res is
else
C := Current_Entity (N);
while Present (C) loop
if Etype (C) = B_Typ then
Set_Entity_With_Style_Check (N, C);
......@@ -4092,6 +4098,7 @@ package body Sem_Res is
if Scope (Entity (N)) /= Standard_Standard then
T := Etype (First_Entity (Entity (N)));
else
T := Find_Unique_Type (L, R);
......@@ -4475,7 +4482,6 @@ package body Sem_Res is
-- the type in the same declarative part.
Tsk := Next_Entity (S);
while Etype (Tsk) /= S loop
Next_Entity (Tsk);
end loop;
......@@ -4515,9 +4521,7 @@ package body Sem_Res is
begin
Get_First_Interp (Pref, I, It);
while Present (It.Typ) loop
if Scope (Ent) = It.Typ then
Set_Etype (Pref, It.Typ);
exit;
......@@ -4586,9 +4590,7 @@ package body Sem_Res is
begin
Get_First_Interp (Selector_Name (Entry_Name), I, It);
while Present (It.Typ) loop
if Covers (Typ, It.Typ) then
Set_Entity (Selector_Name (Entry_Name), It.Nam);
Set_Etype (Entry_Name, It.Typ);
......@@ -4740,7 +4742,7 @@ package body Sem_Res is
Set_Analyzed (N, True);
-- Protected functions can return on the secondary stack, in which
-- case we must trigger the transient scope mechanism
-- case we must trigger the transient scope mechanism.
elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
......@@ -4780,7 +4782,7 @@ package body Sem_Res is
function Find_Unique_Access_Type return Entity_Id is
Acc : Entity_Id;
E : Entity_Id;
S : Entity_Id := Current_Scope;
S : Entity_Id;
begin
if Ekind (Etype (R)) = E_Allocator_Type then
......@@ -4793,11 +4795,10 @@ package body Sem_Res is
return Empty;
end if;
S := Current_Scope;
while S /= Standard_Standard loop
E := First_Entity (S);
while Present (E) loop
if Is_Type (E)
and then Is_Access_Type (E)
and then Ekind (E) /= E_Allocator_Type
......@@ -4826,12 +4827,10 @@ package body Sem_Res is
end if;
if T /= Any_Type then
if T = Any_String
or else T = Any_Composite
or else T = Any_Character
then
if T = Any_Character then
Ambiguous_Character (L);
else
......@@ -4936,7 +4935,6 @@ package body Sem_Res is
and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N))))
then
null;
else
Check_Fully_Declared (Typ, N);
end if;
......@@ -4950,7 +4948,6 @@ package body Sem_Res is
while Present (It.Typ) loop
exit when Is_Access_Type (It.Typ)
and then Covers (Typ, Designated_Type (It.Typ));
Get_Next_Interp (I, It);
end loop;
......@@ -5044,12 +5041,7 @@ package body Sem_Res is
begin
Get_First_Interp (P, I, It);
-- the task has access discriminants, the designated type may be
-- incomplete at the point the expression is resolved. This resolution
-- takes place within the body of the initialization proc
while Present (It.Typ) loop
if (Is_Array_Type (It.Typ)
and then Covers (Typ, Component_Type (It.Typ)))
or else (Is_Access_Type (It.Typ)
......@@ -5153,7 +5145,6 @@ package body Sem_Res is
begin
Op := Entity (N);
while Scope (Op) /= Standard_Standard loop
Op := Homonym (Op);
pragma Assert (Present (Op));
......@@ -5231,7 +5222,6 @@ package body Sem_Res is
begin
Op := Entity (N);
while Scope (Op) /= Standard_Standard loop
Op := Homonym (Op);
pragma Assert (Present (Op));
......@@ -5334,6 +5324,28 @@ package body Sem_Res is
and then Is_Overloaded (L)
then
T := Etype (R);
-- Ada 2005 (AI-251): Give support to the following case:
-- type I is interface;
-- type T is tagged ...
-- function Test (O : in I'Class) is
-- begin
-- return O in T'Class.
-- end Test;
-- In this case we have nothing else to do; the membership test will be
-- done at run-time.
elsif Ada_Version >= Ada_05
and then Is_Class_Wide_Type (Etype (L))
and then Is_Interface (Etype (L))
and then Is_Class_Wide_Type (Etype (R))
and then not Is_Interface (Etype (R))
then
return;
else
T := Intersect_Types (L, R);
end if;
......@@ -5465,9 +5477,7 @@ package body Sem_Res is
begin
Get_First_Interp (Arg, I, It);
while Present (It.Nam) loop
if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
or else Base_Type (Etype (It.Nam)) =
Base_Type (Component_Type (Typ))
......@@ -5725,9 +5735,16 @@ package body Sem_Res is
Resolve (Expr, Target_Typ);
-- A qualified expression requires an exact match of the type,
-- class-wide matching is not allowed.
-- class-wide matching is not allowed. However, if the qualifying
-- type is specific and the expression has a class-wide type, it
-- may still be okay, since it can be the result of the expansion
-- of a call to a dispatching function, so we also have to check
-- class-wideness of the type of the expression's original node.
if Is_Class_Wide_Type (Target_Typ)
if (Is_Class_Wide_Type (Target_Typ)
or else
(Is_Class_Wide_Type (Etype (Expr))
and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
then
Wrong_Type (Expr, Target_Typ);
......@@ -5944,9 +5961,7 @@ package body Sem_Res is
if Is_Record_Type (T) then
Comp := First_Entity (T);
while Present (Comp) loop
if Chars (Comp) = Chars (S)
and then Covers (Etype (Comp), Typ)
then
......@@ -5974,7 +5989,6 @@ package body Sem_Res is
-- Find the component with the right name.
Comp1 := First_Entity (It1.Typ);
while Present (Comp1)
and then Chars (Comp1) /= Chars (S)
loop
......@@ -6118,9 +6132,7 @@ package body Sem_Res is
begin
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
if (Is_Array_Type (It.Typ)
and then Covers (Typ, It.Typ))
or else (Is_Access_Type (It.Typ)
......@@ -6630,6 +6642,10 @@ package body Sem_Res is
end if;
if Is_Interface (Target_Type) then
if Is_Access_Type (Opnd_Type) then
Opnd_Type := Directly_Designated_Type (Opnd_Type);
end if;
if Is_Class_Wide_Type (Opnd_Type) then
Opnd_Type := Etype (Opnd_Type);
end if;
......@@ -6638,22 +6654,28 @@ package body Sem_Res is
(Typ => Opnd_Type,
Iface => Target_Type)
then
if Nkind (Operand) = N_Attribute_Reference then
Error_Msg_Name_1 := Chars (Prefix (Operand));
else
Error_Msg_Name_1 := Chars (Operand);
end if;
Error_Msg_Name_2 := Chars (Target_Type);
Error_Msg_NE
("(Ada 2005) % does not implement interface %",
("(Ada 2005) does not implement interface }",
Operand, Target_Type);
else
-- If a conversion to an interface type appears as an actual in
-- a source call, it will be expanded when the enclosing call
-- itself is examined in Expand_Interface_Formals. Otherwise,
-- generate the proper conversion code now, using the tag of
-- the interface.
if (Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Function_Call)
and then Comes_From_Source (N)
then
null;
else
Expand_Interface_Conversion (N);
end if;
end if;
end if;
end if;
end Resolve_Type_Conversion;
----------------------
......@@ -7000,7 +7022,6 @@ package body Sem_Res is
Scop := Current_Scope;
while Scop /= Standard_Standard loop
T2 := First_Entity (Scop);
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Current_Entity (T2) = T2
......@@ -7027,7 +7048,6 @@ package body Sem_Res is
if Nkind (Item) = N_With_Clause then
Scop := Entity (Name (Item));
T2 := First_Entity (Scop);
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Scope (Base_Type (T2)) = Scop
......@@ -7160,14 +7180,26 @@ package body Sem_Res is
-- in this context, but which cannot be removed by type checking,
-- because the context does not impose a type.
-- When compiling for VMS, spurious ambiguities can be produced
-- when arithmetic operations have a literal operand and return
-- System.Address or a descendant of it. These ambiguities are
-- otherwise resolved by the context, but for conversions there
-- is no context type and the removal of the spurious operations
-- must be done explicitly here.
Get_First_Interp (Operand, I, It);
while Present (It.Typ) loop
if It.Typ = Standard_Void_Type then
Remove_Interp (I);
end if;
if Present (System_Aux_Id)
and then Is_Descendent_Of_Address (It.Typ)
then
Remove_Interp (I);
end if;
Get_Next_Interp (I, It);
end loop;
......@@ -7557,10 +7589,10 @@ package body Sem_Res is
O_Gen : constant Node_Id :=
Enclosing_Generic_Body (Opnd_Type);
T_Gen : Node_Id :=
Enclosing_Generic_Body (Target_Type);
T_Gen : Node_Id;
begin
T_Gen := Enclosing_Generic_Body (Target_Type);
while Present (T_Gen) and then T_Gen /= O_Gen loop
T_Gen := Enclosing_Generic_Body (T_Gen);
end loop;
......
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