From: Bob Duff <duff@adacore.com>
Date: Wed, 25 May 2022 15:51:52 +0000 (-0400)
Subject: [Ada] Fix missing error on 'Access of constrained array
X-Git-Tag: basepoints/gcc-14~5771
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=3319015b0a498ed1050d6910f75430a6fc401f50;p=thirdparty%2Fgcc.git

[Ada] Fix missing error on 'Access of constrained array

For X'Access, the designated subtype of the access type must statically
match the nominal subtype of X.  This patch fixes a bug where the error
was not detected when there is an unrelated declaration of the form "Y :
T := X;", where T is an unconstrained array subtype.

gcc/ada/

	* exp_util.adb (Expand_Subtype_From_Expr): Generate a new
	subtype when Is_Constr_Subt_For_UN_Aliased is True, so the
	Is_Constr_Subt_For_U_Nominal flag will not be set on the
	preexisting subtype.
	* sem_attr.adb, sem_ch3.adb: Minor.
---

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 0f193182729..2a7afd4fa9e 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -113,7 +113,7 @@ package body Exp_Util is
      (Header_Num => Type_Map_Header,
       Key        => Entity_Id,
       Element    => Node_Or_Entity_Id,
-      No_element => Empty,
+      No_Element => Empty,
       Hash       => Type_Map_Hash,
       Equal      => "=");
 
@@ -5730,8 +5730,17 @@ package body Exp_Util is
             or else not Is_Array_Type (Exp_Typ)
             or else not Aliased_Present (N))
       then
-         if Is_Itype (Exp_Typ) then
+         if Is_Itype (Exp_Typ)
 
+           --  If Exp_Typ was created for a previous declaration whose nominal
+           --  subtype is unconstrained, and that declaration is aliased,
+           --  we need to generate a new subtype, because otherwise the
+           --  Is_Constr_Subt_For_U_Nominal flag will be set on the wrong
+           --  subtype, causing failure to detect non-statically-matching
+           --  subtypes on 'Access of the previously-declared object.
+
+           and then not Is_Constr_Subt_For_UN_Aliased (Exp_Typ)
+         then
             --  Within an initialization procedure, a selected component
             --  denotes a component of the enclosing record, and it appears as
             --  an actual in a call to its own initialization procedure. If
@@ -5770,7 +5779,7 @@ package body Exp_Util is
             --  This type is marked as an itype even though it has an explicit
             --  declaration since otherwise Is_Generic_Actual_Type can get
             --  set, resulting in the generation of spurious errors. (See
-            --  sem_ch8.Analyze_Package_Renaming and sem_type.covers)
+            --  sem_ch8.Analyze_Package_Renaming and Sem_Type.Covers.)
 
             Set_Is_Itype (T);
             Set_Associated_Node_For_Itype (T, Exp);
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index e6e06f605fa..ab6c2c6e536 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -11632,9 +11632,7 @@ package body Sem_Attr is
                end if;
             end if;
 
-            if (Attr_Id = Attribute_Access
-                  or else
-                Attr_Id = Attribute_Unchecked_Access)
+            if Attr_Id in Attribute_Access | Attribute_Unchecked_Access
               and then (Ekind (Btyp) = E_General_Access_Type
                          or else Ekind (Btyp) = E_Anonymous_Access_Type)
             then
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 3bbb788ac0c..84971e3c0b1 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -18276,7 +18276,7 @@ package body Sem_Ch3 is
 
    begin
       --  If the parent is a component_definition node we climb to the
-      --  component_declaration node
+      --  component_declaration node.
 
       if Nkind (P) = N_Component_Definition then
          P := Parent (P);