From: squirek <squi...@adacore.com>
This patch fixes an issue in the compiler whereby assigning to a non-existant
mutably tagged object component failed to result in the expected run-time
exception.
gcc/ada/ChangeLog:
* exp_ch4.adb (Expand_N_Type_Conversion): Add special runtime check
generation for mutably tagged objects.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch4.adb | 32 ++++++++++++++++++++++++++++++--
1 file changed, 30 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 381c9f8fb3d..c16e09d9562 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -11684,6 +11684,34 @@ package body Exp_Ch4 is
end if;
end if;
+ -- Generate a tag check for view conversions of mutably tagged objects,
+ -- which are special in nature and require selecting the tag component
+ -- from the class-wide equivalent type.
+
+ -- Possibly this could be combined with the logic below for better code
+ -- reuse ???
+
+ if Is_View_Conversion (N)
+ and then Is_Variable (Operand)
+ and then Is_Class_Wide_Equivalent_Type (Etype (Operand))
+ then
+ -- Generate:
+ -- [Constraint_Error when Operand.Tag /= Root_Type]
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr_No_Checks (Operand),
+ Selector_Name => Make_Identifier (Loc, Name_uTag)),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_Tag)),
+ Reason => CE_Tag_Check_Failed));
+
-- Case of conversions of tagged types and access to tagged types
-- When needed, that is to say when the expression is class-wide, Add
@@ -11699,8 +11727,8 @@ package body Exp_Ch4 is
-- and then Operand.all not in
-- Designated_Type (Target_Type)'Class]
- if (Is_Access_Type (Target_Type)
- and then Is_Tagged_Type (Designated_Type (Target_Type)))
+ elsif (Is_Access_Type (Target_Type)
+ and then Is_Tagged_Type (Designated_Type (Target_Type)))
or else Is_Tagged_Type (Target_Type)
then
-- Do not do any expansion in the access type case if the parent is a
--
2.43.0
