From: Eric Botcazou <[email protected]>
The problem is that the full view of a private tagged type, which is visible
in the generic unit, is not restored when expanding -gnateV in the instance.
The fix uses a two-pronged approach:
1. the Valid_Scalars attribute, on which -gnateV is piggybacked, is fixed
to properly handle tagged extensions (only the components declared in
the root type are currently tested for validity).
2. the special case for tagged extensions in instance bodies implemented
by Try_Selected_Component_In_Instance is extended to whole instances.
gcc/ada/ChangeLog:
PR ada/124923
* exp_attr.adb (Build_Record_VS_Func): Rename first parameter, fix
description and implement support for tagged extensions.
(Expand_N_Attribute_Reference) <Attribute_Valid_Scalars>: Also bail
out for the class-wide type of private tagged types and Adjust call
to Build_Record_VS_Func.
* sem_attr.adb (Analyze_Attribute) <Attribute_Valid_Scalars>: Also
warn for the class-wide type of private tagged types.
* sem_ch4.adb (Try_Selected_Component_In_Instance): Extend a special
case from instance bodies to whole instances.
* sem_util.ads (Validated_View): Adjust description.
* sem_util.adb (Validated_View): Do not recurse on the parent type
for tagged extensions.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_attr.adb | 147 +++++++++++++++++++++++++------------------
gcc/ada/sem_attr.adb | 6 +-
gcc/ada/sem_ch4.adb | 11 ++--
gcc/ada/sem_util.adb | 2 +-
gcc/ada/sem_util.ads | 2 +-
5 files changed, 98 insertions(+), 70 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index aa5d9696804..d04187fd148 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -131,20 +131,13 @@ package body Exp_Attr is
-- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
function Build_Record_VS_Func
- (Attr : Node_Id;
+ (N : Node_Id;
Formal_Typ : Entity_Id;
Rec_Typ : Entity_Id) return Entity_Id;
- -- Validate the components, discriminants, and variants of a record type by
- -- means of a function. Return the entity of the validation function. The
- -- parameters are as follows:
- --
- -- * Attr - the 'Valid_Scalars attribute for which the function is
- -- generated.
- --
- -- * Formal_Typ - the type of the generated function's only formal
- -- parameter.
- --
- -- * Rec_Typ - the record type whose internals are to be validated
+ -- Insert before N the body of a function implementing the validation of
+ -- the components, discriminants, and variants of record type Rec_Type.
+ -- Formal_Typ is the type of the generated function's formal parameter.
+ -- Return the entity of the validation function.
function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean;
-- In most cases, references to unavailable streaming attributes
@@ -677,7 +670,7 @@ package body Exp_Attr is
--------------------------
function Build_Record_VS_Func
- (Attr : Node_Id;
+ (N : Node_Id;
Formal_Typ : Entity_Id;
Rec_Typ : Entity_Id) return Entity_Id
is
@@ -688,7 +681,7 @@ package body Exp_Attr is
-- NOTE: The routines within Build_Record_VS_Func are intentionally
-- unnested to avoid deep indentation of code.
- Loc : constant Source_Ptr := Sloc (Attr);
+ Loc : constant Source_Ptr := Sloc (N);
procedure Validate_Component_List
(Obj_Id : Entity_Id;
@@ -715,6 +708,13 @@ package body Exp_Attr is
-- Fields. Obj_Id denotes the entity of the validation parameter. All
-- new code is added to list Stmts.
+ procedure Validate_Record
+ (Obj_Id : Entity_Id;
+ Typ : Entity_Id;
+ Stmts : in out List_Id);
+ -- Process record type Typ. Obj_Id denotes the entity of the validation
+ -- parameter. All new code is added to list Stmts.
+
procedure Validate_Variant
(Obj_Id : Entity_Id;
Var : Node_Id;
@@ -852,7 +852,7 @@ package body Exp_Attr is
if Present (Cond) then
Append_New_To (Stmts,
- Make_Implicit_If_Statement (Attr,
+ Make_Implicit_If_Statement (N,
Condition => Cond,
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
@@ -860,6 +860,63 @@ package body Exp_Attr is
end if;
end Validate_Fields;
+ ---------------------
+ -- Validate_Record --
+ ---------------------
+
+ procedure Validate_Record
+ (Obj_Id : Entity_Id;
+ Typ : Entity_Id;
+ Stmts : in out List_Id)
+ is
+ Typ_Decl : constant Node_Id := Declaration_Node (Typ);
+ Typ_Def : constant Node_Id := Type_Definition (Typ_Decl);
+
+ Comps : Node_Id;
+ Typ_Ext : Node_Id;
+
+ begin
+ -- The components of a derived type are located in the extension part
+
+ if Nkind (Typ_Def) = N_Derived_Type_Definition then
+ Typ_Ext := Record_Extension_Part (Typ_Def);
+
+ if Present (Typ_Ext) then
+ Comps := Component_List (Typ_Ext);
+ else
+ Comps := Empty;
+ end if;
+
+ -- Otherwise the components are available in the definition
+
+ else
+ Comps := Component_List (Typ_Def);
+ end if;
+
+ -- Validate the discriminants
+
+ if not Is_Unchecked_Union (Typ) then
+ Validate_Fields
+ (Obj_Id => Obj_Id,
+ Fields => Discriminant_Specifications (Typ_Decl),
+ Stmts => Stmts);
+ end if;
+
+ -- Validate the components and variant parts
+
+ Validate_Component_List
+ (Obj_Id => Obj_Id,
+ Comp_List => Comps,
+ Stmts => Stmts);
+
+ -- Recurse on the parent subtype, if any
+
+ if Present (Parent_Subtype (Typ)) then
+ Validate_Record
+ (Obj_Id, Validated_View (Parent_Subtype (Typ)), Stmts);
+ end if;
+ end Validate_Record;
+
----------------------
-- Validate_Variant --
----------------------
@@ -960,15 +1017,12 @@ package body Exp_Attr is
-- Local variables
- Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V',
- Related_Node => Attr);
+ Func_Id : constant Entity_Id :=
+ Make_Temporary (Loc, 'V', Related_Node => N);
Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
- Comps : Node_Id;
- Stmts : List_Id;
- Typ : Entity_Id;
- Typ_Decl : Node_Id;
- Typ_Def : Node_Id;
- Typ_Ext : Node_Id;
+
+ Stmts : List_Id;
+ Typ : Entity_Id;
-- Start of processing for Build_Record_VS_Func
@@ -981,26 +1035,6 @@ package body Exp_Attr is
Typ := Validated_View (Root_Type (Typ));
end if;
- Typ_Decl := Declaration_Node (Typ);
- Typ_Def := Type_Definition (Typ_Decl);
-
- -- The components of a derived type are located in the extension part
-
- if Nkind (Typ_Def) = N_Derived_Type_Definition then
- Typ_Ext := Record_Extension_Part (Typ_Def);
-
- if Present (Typ_Ext) then
- Comps := Component_List (Typ_Ext);
- else
- Comps := Empty;
- end if;
-
- -- Otherwise the components are available in the definition
-
- else
- Comps := Component_List (Typ_Def);
- end if;
-
-- The code generated by this routine is as follows:
--
-- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
@@ -1039,21 +1073,7 @@ package body Exp_Attr is
Stmts := No_List;
- -- Validate the discriminants
-
- if not Is_Unchecked_Union (Rec_Typ) then
- Validate_Fields
- (Obj_Id => Obj_Id,
- Fields => Discriminant_Specifications (Typ_Decl),
- Stmts => Stmts);
- end if;
-
- -- Validate the components and variant parts
-
- Validate_Component_List
- (Obj_Id => Obj_Id,
- Comp_List => Comps,
- Stmts => Stmts);
+ Validate_Record (Obj_Id, Typ, Stmts);
-- Generate:
-- return True;
@@ -1076,7 +1096,7 @@ package body Exp_Attr is
Set_Debug_Info_Off (Func_Id);
end if;
- Insert_Action (Attr,
+ Insert_Action (N,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
@@ -8583,7 +8603,12 @@ package body Exp_Attr is
-- Attribute 'Valid_Scalars is not supported on private tagged types;
-- see a detailed explanation where this attribute is analyzed.
- if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then
+ if Is_Tagged_Type (Ptyp) and then Is_Private_Type (Ptyp) then
+ null;
+
+ elsif Is_Class_Wide_Type (Ptyp)
+ and then Is_Private_Type (Root_Type (Ptyp))
+ then
null;
-- Attribute 'Valid_Scalars evaluates to True when the type lacks
@@ -8634,7 +8659,7 @@ package body Exp_Attr is
Name =>
New_Occurrence_Of
(Build_Record_VS_Func
- (Attr => N,
+ (N => N,
Formal_Typ => Ptyp,
Rec_Typ => Val_Typ),
Loc),
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 8033506108a..709f4f2e3f9 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -7839,8 +7839,10 @@ package body Sem_Attr is
-- Do not emit any diagnostics related to private types to avoid
-- disclosing the structure of the type.
- elsif Is_Private_Type (P_Type) then
-
+ elsif Is_Private_Type (P_Type)
+ or else (Is_Class_Wide_Type (P_Type)
+ and then Is_Private_Type (Root_Type (P_Type)))
+ then
-- Attribute 'Valid_Scalars is not supported on private tagged
-- types due to a code generation issue. Is_Visible_Component
-- does not allow for a component of a private tagged type to
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 3a8edfb26df..8eb017ee838 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -5396,18 +5396,19 @@ package body Sem_Ch4 is
-- Another special case: the type is an extension of a private
-- type T, either is an actual in an instance or is immediately
- -- visible, and we are in the body of the instance, which means
- -- the generic body had a full view of the type declaration for
- -- T or some ancestor that defines the component in question.
+ -- visible, and we are in an instance, which means the generic
+ -- unit had a full view of the type declaration of T or some
+ -- ancestor that defines the component in question.
+
-- This happens because Is_Visible_Component returned False on
-- this component, as T or the ancestor is still private since
-- the Has_Private_View mechanism is bypassed because T or the
- -- ancestor is not directly referenced in the generic body.
+ -- ancestor is not directly referenced in the generic unit.
if Is_Derived_Type (Typ)
and then (Used_As_Generic_Actual (Base_Type (Typ))
or else Is_Immediately_Visible (Typ))
- and then In_Instance_Body
+ and then In_Instance
and then Present (Parent_Subtype (Typ))
then
Find_Component_In_Instance (Parent_Subtype (Typ));
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index d66dd90c2ff..7feaa6b9879 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -30483,7 +30483,7 @@ package body Sem_Util is
return Typ;
end if;
- elsif Is_Derived_Type (Typ) then
+ elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
return Validated_View (Etype (Typ));
elsif Is_Private_Type (Typ) then
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 6934bd42a70..5f345273023 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -3564,7 +3564,7 @@ package Sem_Util is
-- Obtain the "validated view" of arbitrary type Typ which is suitable for
-- verification by attribute 'Valid_Scalars. This view is the type itself
-- or its full view or nonlimited view, while stripping away concurrency,
- -- derivations, and privacy.
+ -- untagged derivation, and privacy.
function Visible_Ancestors (Typ : Entity_Id) return Elist_Id;
-- [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors
--
2.53.0
