From: Eric Botcazou <[email protected]>
The first issue is that the special case for tagged types mentioned in the
RM 4.5.2(3.1) rule is not implemented, leading to legal code being rejected.
The second issue is that the RM 4.5.2(30-30.3) dynamic semantic rules are
not correctly implemented when both tested expression and tested type are
of a specific tagged type, leading to a wrong run-time outcome of the test.
The changes are mostly straightforward, except for the unexpected fallout
for the implementation of the RM 6.5(8.2) rule prescribing a tag check for
an anonymous access return designating a specific tagged type, which was
implemented using a direct membership test on tagged types, and now needs
to be changed to use an indirect membership test on tagged types, which is
not affected by the adjusted implementation of dynamic semantic rules.
gcc/ada/ChangeLog:
* accessibility.adb (Accessibility_Level): Deal with the associated
entity created during expansion for 'Old attribute references.
* exp_ch4.ads (Tagged_Membership): New declaration from...
* exp_ch4.adb (Tagged_Membership): ...here. Retrieve the designated
types first, if any. Do not retrieve the root type of a CW type for
the left operand, instead compute a full type for this operand. Do
not generate a tag equality test in the direct case if both left and
right operands are of specific tagged type.
(Expand_N_In): In the anonymous access type case, pass the left
operand directly to the Accessibility_Level routine.
* exp_ch6.adb: Add clauses for SCIL_LL package.
(Expand_Simple_Function_Return): Use an indirect membership test to
implement the tag check for an anonymous access return designating
a specific tagged type.
* sem_ch4.adb (Analyze_Membership_Op): Deal specifically with a
right operand that denotes a tagged type.
* sem_res.ads (Valid_Tagged_Conversion): New declaration from...
* sem_res.adb (Valid_Tagged_Conversion): ...here.
(Resolve_Membership_Op): Deal specifically with a right operand that
denotes a tagged type and remove obsolete special case.
(Valid_Conversion): Adjust calls to Valid_Tagged_Conversion.
* sem_type.adb (Intersect_Types): Minor tweaks.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 7 +
gcc/ada/exp_ch4.adb | 70 ++++----
gcc/ada/exp_ch4.ads | 7 +
gcc/ada/exp_ch6.adb | 61 ++++---
gcc/ada/sem_ch4.adb | 59 +++++--
gcc/ada/sem_res.adb | 358 ++++++++++++++++++--------------------
gcc/ada/sem_res.ads | 7 +
gcc/ada/sem_type.adb | 4 +-
8 files changed, 312 insertions(+), 261 deletions(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 702ab6c5f37..34d5e6b085f 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -593,6 +593,13 @@ package body Accessibility is
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
+ -- For 'Old return the level of the associated entity, if any
+
+ elsif Attribute_Name (E) = Name_Old
+ and then Is_Entity_Name (Expr)
+ then
+ return Accessibility_Level (Entity (Expr));
+
-- 'Access can be taken further against other special attributes,
-- so handle these cases explicitly.
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index fde321a0ba5..8fa214f0185 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -274,13 +274,6 @@ package body Exp_Ch4 is
-- its expression. If N is neither comparison nor a type conversion, the
-- call has no effect.
- procedure Tagged_Membership
- (N : Node_Id;
- SCIL_Node : out Node_Id;
- Result : out Node_Id);
- -- Construct the expression corresponding to the tagged membership test.
- -- Deals with a second operand being (or not) a class-wide type.
-
function Safe_In_Place_Array_Op
(Lhs : Node_Id;
Op1 : Node_Id;
@@ -7218,20 +7211,11 @@ package body Exp_Ch4 is
and then Ekind (Ltyp) = E_Anonymous_Access_Type
then
declare
- Expr_Entity : Entity_Id := Empty;
New_N : Node_Id;
Param_Level : Node_Id;
Type_Level : Node_Id;
begin
- if Is_Entity_Name (Lop) then
- Expr_Entity := Param_Entity (Lop);
-
- if No (Expr_Entity) then
- Expr_Entity := Entity (Lop);
- end if;
- end if;
-
-- When restriction No_Dynamic_Accessibility_Checks is in
-- effect, expand the membership test to a static value
-- since we cannot rely on dynamic levels.
@@ -7262,8 +7246,7 @@ package body Exp_Ch4 is
-- objects of an anonymous access type.
else
- Param_Level := Accessibility_Level
- (Expr_Entity, Dynamic_Level);
+ Param_Level := Accessibility_Level (Lop, Dynamic_Level);
Type_Level :=
Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
@@ -15294,9 +15277,12 @@ package body Exp_Ch4 is
-- Tagged_Membership --
-----------------------
- -- There are two different cases to consider depending on whether the right
- -- operand is a class-wide type or not. If not we just compare the actual
- -- tag of the left expr to the target type tag:
+ -- There are two main cases to consider depending on whether the right
+ -- operand is a class-wide type or not. If not, when the left operand
+ -- is also of a specific tagged type, we just return True in the direct
+ -- case because the left operand is statically known to be convertible
+ -- to the type of right operand; otherwise, we compare the actual tag
+ -- of the left operand to the target type tag:
--
-- Left_Expr.Tag = Right_Type'Tag;
--
@@ -15326,6 +15312,7 @@ package body Exp_Ch4 is
Orig_Right_Type : constant Entity_Id :=
Base_Type (Available_View (Etype (Right)));
+ Full_L_Typ : Entity_Id;
Full_R_Typ : Entity_Id;
Left_Type : Entity_Id := Base_Type (Available_View (Etype (Left)));
Right_Type : Entity_Id := Orig_Right_Type;
@@ -15334,19 +15321,8 @@ package body Exp_Ch4 is
begin
SCIL_Node := Empty;
- -- We have to examine the corresponding record type when dealing with
- -- protected types instead of the original, unexpanded, type.
-
- if Ekind (Right_Type) = E_Protected_Type then
- Right_Type := Corresponding_Record_Type (Right_Type);
- end if;
-
- if Ekind (Left_Type) = E_Protected_Type then
- Left_Type := Corresponding_Record_Type (Left_Type);
- end if;
-
-- In the case where the type is an access type, the test is applied
- -- using the designated types (needed in Ada 2012 for implicit anonymous
+ -- to the designated types (needed in Ada 2012 for implicit anonymous
-- access conversions, for AI05-0149).
if Is_Access_Type (Right_Type) then
@@ -15354,8 +15330,21 @@ package body Exp_Ch4 is
Right_Type := Designated_Type (Right_Type);
end if;
+ -- We have to examine the corresponding record type when dealing with
+ -- protected types instead of the original, unexpanded, type.
+
+ if Is_Protected_Type (Left_Type) then
+ Left_Type := Corresponding_Record_Type (Left_Type);
+ end if;
+
+ if Is_Protected_Type (Right_Type) then
+ Right_Type := Corresponding_Record_Type (Right_Type);
+ end if;
+
if Is_Class_Wide_Type (Left_Type) then
- Left_Type := Root_Type (Left_Type);
+ Full_L_Typ := Underlying_Type (Root_Type (Left_Type));
+ else
+ Full_L_Typ := Underlying_Type (Left_Type);
end if;
if Is_Class_Wide_Type (Right_Type) then
@@ -15368,7 +15357,7 @@ package body Exp_Ch4 is
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Left),
Selector_Name =>
- New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
+ New_Occurrence_Of (First_Tag_Component (Full_L_Typ), Loc));
if Is_Class_Wide_Type (Right_Type) then
@@ -15476,6 +15465,17 @@ package body Exp_Ch4 is
if Is_Abstract_Type (Right_Type) then
Result := New_Occurrence_Of (Standard_False, Loc);
+ -- No need to check the tag of the object in the direct case if
+ -- Left_Type is of a specific tagged type.
+
+ elsif not Is_Access_Type (Orig_Right_Type)
+ and then not Is_Interface (Left_Type)
+ and then not Is_Class_Wide_Type (Left_Type)
+ then
+ Result := New_Occurrence_Of (Standard_True, Loc);
+
+ -- Otherwise generate the tag equality test
+
else
Result :=
Make_Op_Eq (Loc,
diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads
index 0264e4a1ec0..7a48ca8559f 100644
--- a/gcc/ada/exp_ch4.ads
+++ b/gcc/ada/exp_ch4.ads
@@ -130,4 +130,11 @@ package Exp_Ch4 is
-- routine is to find the real type by looking up the tree. We also
-- determine if the operation must be rounded.
+ procedure Tagged_Membership
+ (N : Node_Id;
+ SCIL_Node : out Node_Id;
+ Result : out Node_Id);
+ -- Construct the expression corresponding to the tagged membership test.
+ -- Deals with a second operand being (or not) a class-wide type.
+
end Exp_Ch4;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index b28913eff70..21275bbfe18 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -75,6 +75,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
+with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw; use Validsw;
@@ -7571,46 +7572,50 @@ package body Exp_Ch6 is
end;
end if;
- -- Ada 2012 (AI05-0073): If the result subtype of the function is
+ -- Ada 2005 (AI05-0073): If the result subtype of the function is
-- defined by an access_definition designating a specific tagged
-- type T, a check is made that the result value is null or the tag
-- of the object designated by the result value identifies T.
- -- The return expression is referenced twice in the code below, so it
- -- must be made free of side effects. Given that different compilers
- -- may evaluate these parameters in different order, both occurrences
- -- perform a copy.
-
elsif Ekind (R_Type) = E_Anonymous_Access_Type
and then Is_Tagged_Type (Designated_Type (R_Type))
and then not Is_Class_Wide_Type (Designated_Type (R_Type))
- and then Nkind (Original_Node (Exp)) /= N_Null
and then not Tag_Checks_Suppressed (Designated_Type (R_Type))
+ and then Present (Underlying_Type (Designated_Type (R_Type)))
+ and then Nkind (Original_Node (Exp)) /= N_Null
then
- -- Generate:
- -- [Constraint_Error
- -- when Exp /= null
- -- and then Exp.all not in Designated_Type]
+ declare
+ -- Generate:
+ -- [Constraint_Error when not (Exp in R_Type)]
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr (Exp),
- Right_Opnd => Make_Null (Loc)),
+ In_Test : constant Node_Id :=
+ Make_Not_In
+ (Loc,
+ Duplicate_Subexpr (Exp),
+ New_Occurrence_Of (R_Type, Loc));
- Right_Opnd =>
- Make_Not_In (Loc,
- Left_Opnd =>
- Make_Explicit_Dereference (Loc,
- Prefix => Duplicate_Subexpr (Exp)),
- Right_Opnd =>
- New_Occurrence_Of (Designated_Type (R_Type), Loc))),
+ Result : Node_Id;
+ SCIL_Node : Node_Id;
- Reason => CE_Tag_Check_Failed),
- Suppress => All_Checks);
+ begin
+ -- We need to invoke Tagged_Membership directly because it is
+ -- invoked only in Ada 2012 for anonymous access types.
+
+ Tagged_Membership (In_Test, SCIL_Node, Result);
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition => Make_Op_Not (Loc, Right_Opnd => Result),
+ Reason => CE_Tag_Check_Failed),
+ Suppress => All_Checks);
+
+ -- Update decoration of relocated node referenced by the
+ -- SCIL node.
+
+ if Generate_SCIL and then Present (SCIL_Node) then
+ Set_SCIL_Node (Result, SCIL_Node);
+ end if;
+ end;
end if;
-- Generate a run-time accessibility check if needed
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 6e7828b9977..a8e5e36ff32 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -3501,6 +3501,18 @@ package body Sem_Ch4 is
if Nkind (R) = N_Error then
Found := False;
+ elsif Is_Entity_Name (R) and then Is_Type (Entity (R)) then
+ -- If the tested type is tagged, then the tested expression
+ -- shall resolve to be of a type that is convertible to the
+ -- tested type; if untagged, the expected type of the tested
+ -- expression is the tested type (RM 4.5.2(3.1)).
+
+ if Is_Tagged_Type (Entity (R)) then
+ Found := Valid_Tagged_Conversion (N, Entity (R), T, False);
+ else
+ Found := Covers (Entity (R), T);
+ end if;
+
-- Loop through the interpretations of the right operand
elsif not Is_Overloaded (R) then
@@ -3564,6 +3576,8 @@ package body Sem_Ch4 is
begin
Analyze_Expression (L);
+ -- If there is no right operand, then a set of alternatives is present
+
if No (R) then
pragma Assert (Ada_Version >= Ada_2012);
@@ -3589,22 +3603,22 @@ package body Sem_Ch4 is
end loop;
end;
- elsif Nkind (R) = N_Range
- or else (Nkind (R) = N_Attribute_Reference
- and then Attribute_Name (R) = Name_Range)
- then
- Analyze_Expression (R);
-
- Dummy := Find_Interp;
-
- -- If not a range, it can be a subtype mark, or else it is a degenerate
- -- membership test with a singleton value, i.e. a test for equality,
- -- if the types are compatible.
+ -- Either a range, or a subtype mark, or else a degenerate membership
+ -- test with a singleton value, i.e. a test for equality.
else
Analyze_Expression (R);
- if Is_Entity_Name (R) and then Is_Type (Entity (R)) then
+ if Nkind (R) = N_Range
+ or else (Nkind (R) = N_Attribute_Reference
+ and then Attribute_Name (R) = Name_Range)
+ then
+ -- The error will be given during resolution if no valid
+ -- interpretation of the operands is found.
+
+ Dummy := Find_Interp;
+
+ elsif Is_Entity_Name (R) and then Is_Type (Entity (R)) then
Find_Type (R);
Check_Fully_Declared (Entity (R), R);
@@ -3613,6 +3627,27 @@ package body Sem_Ch4 is
("subtype& has ghost predicate, "
& "not allowed in membership test",
R, Entity (R));
+
+ -- If no valid interpretation of the left operand is found, then
+ -- give an error message when the type is tagged; when it is not,
+ -- the error will be given during resolution instead.
+
+ elsif not Find_Interp
+ and then Is_Tagged_Type (Entity (R))
+ then
+ if Is_Class_Wide_Type (Etype (R))
+ and then Is_Interface (Etype (R))
+ then
+ Error_Msg_NE ("(Ada 2005) does not implement interface }",
+ L, Root_Type (Entity (R)));
+
+ elsif From_Limited_With (Entity (R)) then
+ Error_Msg_NE ("limited view of& not compatible with context",
+ R, Entity (R));
+
+ else
+ Error_Msg_N ("incompatible types", N);
+ end if;
end if;
elsif Ada_Version >= Ada_2012 and then Find_Interp then
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index f2eeaf8fbfd..54915607d68 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -10253,7 +10253,6 @@ package body Sem_Res is
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
- T : Entity_Id;
procedure Resolve_Set_Membership;
-- Analysis has determined a unique type for the left operand. Use it as
@@ -10265,6 +10264,7 @@ package body Sem_Res is
procedure Resolve_Set_Membership is
Alt : Node_Id;
+ T : Entity_Id;
begin
-- If the left operand is overloaded, find type compatible with not
@@ -10365,6 +10365,10 @@ package body Sem_Res is
end if;
end Resolve_Set_Membership;
+ -- Local variables
+
+ T : Entity_Id;
+
-- Start of processing for Resolve_Membership_Op
begin
@@ -10436,25 +10440,14 @@ package body Sem_Res is
Analyze (R);
end if;
- -- Ada 2005 (AI-251): Support the following case:
+ -- If the right operand is a tagged type, the type of the left operand
+ -- needs to be convertible to it, which was checked during analysis.
- -- type I is interface;
- -- type T is tagged ...
-
- -- function Test (O : 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_2005
- and then Is_Class_Wide_Type (Etype (L))
- and then Is_Interface (Etype (L))
- and then not Is_Interface (Etype (R))
+ elsif Is_Entity_Name (R)
+ and then Is_Type (Entity (R))
+ and then Is_Tagged_Type (Entity (R))
then
- return;
+ T := Etype (L);
else
T := Intersect_Types (L, R);
@@ -13746,11 +13739,6 @@ package body Sem_Res is
-- discriminant selected from a dereference of another such "bad"
-- conversion argument.
- function Valid_Tagged_Conversion
- (Target_Type : Entity_Id;
- Opnd_Type : Entity_Id) return Boolean;
- -- Specifically test for validity of tagged conversions
-
function Valid_Array_Conversion return Boolean;
-- Check index and component conformance, and accessibility levels if
-- the component types are anonymous access types (Ada 2005).
@@ -14023,165 +14011,6 @@ package body Sem_Res is
return True;
end Valid_Array_Conversion;
- -----------------------------
- -- Valid_Tagged_Conversion --
- -----------------------------
-
- function Valid_Tagged_Conversion
- (Target_Type : Entity_Id;
- Opnd_Type : Entity_Id) return Boolean
- is
- begin
- -- Upward conversions are allowed (RM 4.6(22))
-
- if Covers (Target_Type, Opnd_Type)
- or else Is_Ancestor (Target_Type, Opnd_Type)
- then
- return True;
-
- -- Downward conversion are allowed if the operand is class-wide
- -- (RM 4.6(23)).
-
- elsif Is_Class_Wide_Type (Opnd_Type)
- and then Covers (Opnd_Type, Target_Type)
- then
- return True;
-
- elsif Covers (Opnd_Type, Target_Type)
- or else Is_Ancestor (Opnd_Type, Target_Type)
- then
- -- Deal with non-extension derivation involving an
- -- untagged view of a tagged type.
-
- if not Is_Tagged_Type (Target_Type) then
- return True;
- end if;
-
- return
- Conversion_Check (False,
- "downward conversion of tagged objects not allowed");
-
- -- Ada 2005 (AI-251): A conversion is valid if the operand and target
- -- types are both class-wide types and the specific type associated
- -- with at least one of them is an interface type (RM 4.6 (23.1/2));
- -- at run-time a check will verify the validity of this interface
- -- type conversion.
-
- elsif Is_Class_Wide_Type (Target_Type)
- and then Is_Class_Wide_Type (Opnd_Type)
- and then (Is_Interface (Target_Type)
- or else Is_Interface (Opnd_Type))
- then
- return True;
-
- -- Report errors
-
- elsif Is_Class_Wide_Type (Target_Type)
- and then Is_Interface (Target_Type)
- and then not Is_Interface (Opnd_Type)
- and then not Interface_Present_In_Ancestor
- (Typ => Opnd_Type,
- Iface => Target_Type)
- then
- Error_Msg_Name_1 := Chars (Etype (Target_Type));
- Error_Msg_Name_2 := Chars (Opnd_Type);
- Report_Error_N
- ("wrong interface conversion (% is not a progenitor "
- & "of %)", N, Report_Errs);
- return False;
-
- elsif Is_Class_Wide_Type (Opnd_Type)
- and then Is_Interface (Opnd_Type)
- and then not Is_Interface (Target_Type)
- and then not Interface_Present_In_Ancestor
- (Typ => Target_Type,
- Iface => Opnd_Type)
- then
- Error_Msg_Name_1 := Chars (Etype (Opnd_Type));
- Error_Msg_Name_2 := Chars (Target_Type);
- Report_Error_N
- ("wrong interface conversion (% is not a progenitor "
- & "of %)", N, Report_Errs);
-
- -- Search for interface types shared between the target type and
- -- the operand interface type to complete the text of the error
- -- since the source of this error is a missing type conversion
- -- to such interface type.
-
- if Has_Interfaces (Target_Type) then
- declare
- Operand_Ifaces_List : Elist_Id;
- Operand_Iface_Elmt : Elmt_Id;
- Target_Ifaces_List : Elist_Id;
- Target_Iface_Elmt : Elmt_Id;
- First_Candidate : Boolean := True;
-
- begin
- Collect_Interfaces (Base_Type (Target_Type),
- Target_Ifaces_List);
- Collect_Interfaces (Root_Type (Base_Type (Opnd_Type)),
- Operand_Ifaces_List);
-
- Operand_Iface_Elmt := First_Elmt (Operand_Ifaces_List);
- while Present (Operand_Iface_Elmt) loop
- Target_Iface_Elmt := First_Elmt (Target_Ifaces_List);
- while Present (Target_Iface_Elmt) loop
- if Node (Operand_Iface_Elmt)
- = Node (Target_Iface_Elmt)
- then
- Error_Msg_Name_1 :=
- Chars (Node (Target_Iface_Elmt));
-
- if First_Candidate then
- First_Candidate := False;
- Report_Error_N
- ("\must convert to `%''Class` before downward "
- & "conversion", Operand, Report_Errs);
- else
- Report_Error_N
- ("\or must convert to `%''Class` before "
- & "downward conversion",
- Operand, Report_Errs);
- end if;
- end if;
-
- Next_Elmt (Target_Iface_Elmt);
- end loop;
-
- Next_Elmt (Operand_Iface_Elmt);
- end loop;
- end;
- end if;
-
- return False;
-
- elsif not Is_Class_Wide_Type (Target_Type)
- and then Is_Interface (Target_Type)
- then
- Report_Error_N
- ("wrong use of interface type in tagged conversion",
- N, Report_Errs);
- Report_Error_N
- ("\add ''Class to the target interface type",
- N, Report_Errs);
- return False;
-
- elsif not Is_Class_Wide_Type (Opnd_Type)
- and then Is_Interface (Opnd_Type)
- then
- Report_Error_N
- ("must convert to class-wide interface type before downward "
- & "conversion", Operand, Report_Errs);
- return False;
-
- else
- Report_Error_NE
- ("invalid tagged conversion, not compatible with}",
- N, First_Subtype (Opnd_Type), Report_Errs);
- return False;
- end if;
- end Valid_Tagged_Conversion;
-
-- Start of processing for Valid_Conversion
begin
@@ -14602,7 +14431,7 @@ package body Sem_Res is
begin
if Is_Tagged_Type (Target) then
- return Valid_Tagged_Conversion (Target, Opnd);
+ return Valid_Tagged_Conversion (N, Target, Opnd, Report_Errs);
else
if not Same_Base then
@@ -14797,7 +14626,8 @@ package body Sem_Res is
and then
Is_Tagged_Type (Implementation_Base_Type (Opnd_Type)))
then
- return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
+ return
+ Valid_Tagged_Conversion (N, Target_Type, Opnd_Type, Report_Errs);
-- Types derived from the same root type are convertible
@@ -14861,4 +14691,164 @@ package body Sem_Res is
end if;
end Valid_Conversion;
+ -----------------------------
+ -- Valid_Tagged_Conversion --
+ -----------------------------
+
+ function Valid_Tagged_Conversion
+ (N : Node_Id;
+ Target_Type : Entity_Id;
+ Opnd_Type : Entity_Id;
+ Report_Errs : Boolean := True) return Boolean
+ is
+ begin
+ -- Upward conversions are allowed (RM 4.6(22))
+
+ if Covers (Target_Type, Opnd_Type)
+ or else Is_Ancestor (Target_Type, Opnd_Type)
+ then
+ return True;
+
+ -- Downward conversion are allowed if the operand is class-wide
+ -- (RM 4.6(23)).
+
+ elsif Is_Class_Wide_Type (Opnd_Type)
+ and then Covers (Opnd_Type, Target_Type)
+ then
+ return True;
+
+ elsif Covers (Opnd_Type, Target_Type)
+ or else Is_Ancestor (Opnd_Type, Target_Type)
+ then
+ -- Deal with non-extension derivation involving an
+ -- untagged view of a tagged type.
+
+ if Is_Tagged_Type (Target_Type) then
+ Report_Error_N
+ ("downward conversion of tagged objects not allowed",
+ N, Report_Errs);
+ return False;
+ else
+ return True;
+ end if;
+
+ -- Ada 2005 (AI-251): A conversion is valid if the operand and target
+ -- types are both class-wide types and the specific type associated
+ -- with at least one of them is an interface type (RM 4.6 (23.1/2));
+ -- at run-time a check will verify the validity of this interface
+ -- type conversion.
+
+ elsif Is_Class_Wide_Type (Target_Type)
+ and then Is_Class_Wide_Type (Opnd_Type)
+ and then (Is_Interface (Target_Type)
+ or else Is_Interface (Opnd_Type))
+ then
+ return True;
+
+ -- Report errors
+
+ elsif Is_Class_Wide_Type (Target_Type)
+ and then Is_Interface (Target_Type)
+ and then not Is_Interface (Opnd_Type)
+ and then not Interface_Present_In_Ancestor
+ (Typ => Opnd_Type,
+ Iface => Target_Type)
+ then
+ Error_Msg_Name_1 := Chars (Etype (Target_Type));
+ Error_Msg_Name_2 := Chars (Opnd_Type);
+ Report_Error_N
+ ("wrong interface conversion (% is not a progenitor "
+ & "of %)", N, Report_Errs);
+ return False;
+
+ elsif Is_Class_Wide_Type (Opnd_Type)
+ and then Is_Interface (Opnd_Type)
+ and then not Is_Interface (Target_Type)
+ and then not Interface_Present_In_Ancestor
+ (Typ => Target_Type,
+ Iface => Opnd_Type)
+ then
+ Error_Msg_Name_1 := Chars (Etype (Opnd_Type));
+ Error_Msg_Name_2 := Chars (Target_Type);
+ Report_Error_N
+ ("wrong interface conversion (% is not a progenitor "
+ & "of %)", N, Report_Errs);
+
+ -- Search for interface types shared between the target type and
+ -- the operand interface type to complete the text of the error
+ -- since the source of this error is a missing type conversion
+ -- to such interface type.
+
+ if Has_Interfaces (Target_Type) then
+ declare
+ Operand_Ifaces_List : Elist_Id;
+ Operand_Iface_Elmt : Elmt_Id;
+ Target_Ifaces_List : Elist_Id;
+ Target_Iface_Elmt : Elmt_Id;
+ First_Candidate : Boolean := True;
+
+ begin
+ Collect_Interfaces (Base_Type (Target_Type),
+ Target_Ifaces_List);
+ Collect_Interfaces (Root_Type (Base_Type (Opnd_Type)),
+ Operand_Ifaces_List);
+
+ Operand_Iface_Elmt := First_Elmt (Operand_Ifaces_List);
+ while Present (Operand_Iface_Elmt) loop
+ Target_Iface_Elmt := First_Elmt (Target_Ifaces_List);
+ while Present (Target_Iface_Elmt) loop
+ if Node (Operand_Iface_Elmt) = Node (Target_Iface_Elmt)
+ then
+ Error_Msg_Name_1 :=
+ Chars (Node (Target_Iface_Elmt));
+
+ if First_Candidate then
+ First_Candidate := False;
+ Report_Error_N
+ ("\must convert to `%''Class` before downward "
+ & "conversion", N, Report_Errs);
+ else
+ Report_Error_N
+ ("\or must convert to `%''Class` before "
+ & "downward conversion", N, Report_Errs);
+ end if;
+ end if;
+
+ Next_Elmt (Target_Iface_Elmt);
+ end loop;
+
+ Next_Elmt (Operand_Iface_Elmt);
+ end loop;
+ end;
+ end if;
+
+ return False;
+
+ elsif not Is_Class_Wide_Type (Target_Type)
+ and then Is_Interface (Target_Type)
+ then
+ Report_Error_N
+ ("wrong use of interface type in tagged conversion",
+ N, Report_Errs);
+ Report_Error_N
+ ("\add ''Class to the target interface type",
+ N, Report_Errs);
+ return False;
+
+ elsif not Is_Class_Wide_Type (Opnd_Type)
+ and then Is_Interface (Opnd_Type)
+ then
+ Report_Error_N
+ ("must convert to class-wide interface type before downward "
+ & "conversion", N, Report_Errs);
+ return False;
+
+ else
+ Report_Error_NE
+ ("invalid tagged conversion, not compatible with}",
+ N, First_Subtype (Opnd_Type), Report_Errs);
+ return False;
+ end if;
+ end Valid_Tagged_Conversion;
+
end Sem_Res;
diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads
index 77324846d98..1985d86eca3 100644
--- a/gcc/ada/sem_res.ads
+++ b/gcc/ada/sem_res.ads
@@ -154,6 +154,13 @@ package Sem_Res is
-- whether the conversion is legal. Reports errors in the case of illegal
-- conversions, unless Report_Errs is False.
+ function Valid_Tagged_Conversion
+ (N : Node_Id;
+ Target_Type : Entity_Id;
+ Opnd_Type : Entity_Id;
+ Report_Errs : Boolean := True) return Boolean;
+ -- Specific version of Valid_Conversion for when Target_Type is tagged
+
private
procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve;
pragma Inline (Resolve_Implicit_Type);
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 0f8e7cb66cd..8f7cdbcd266 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -2849,10 +2849,10 @@ package body Sem_Type is
-- Ada 2005 (AI-251): Complete the error notification
elsif Is_Class_Wide_Type (Etype (R))
- and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
+ and then Is_Interface (Etype (R))
then
Error_Msg_NE ("(Ada 2005) does not implement interface }",
- L, Etype (Class_Wide_Type (Etype (R))));
+ L, Root_Type (Etype (R)));
-- Specialize message if one operand is a limited view, a priori
-- unrelated to all other types.
--
2.53.0
