[Ada] Storage error on untagged prefixed subprogram calls with -gnatX

gcc/ada/

	* sem_ch3.adb (Analyze_Full_Type_Declaration): If the full type
	has a primitives list but its base type doesn't, set the base
	type's list to the full type's list (covers certain constrained
	cases, such as for arrays).
	(Analyze_Incomplete_Type_Decl): Unconditionally initialize an
	incomplete type's primitives list.
	(Analyze_Subtype_Declaration): Unconditionally set a subtype's
	primitives list to the base type's list, so the lists are
	shared.
	(Build_Derived_Private_Type): Unconditionally initialize a
	derived private type's list to a new empty list.
	(Build_Derived_Record_Type): Unconditionally initialize a
	derived record type's list to a new empty list (now a single
	call for tagged and untagged cases).
	(Derived_Type_Declaration): Unconditionally initialize a derived
	type's list to a new empty list in error cases (when Parent_Type
	is undefined or illegal).
	(Process_Full_View): Unconditionally copy the primitive
	operations from the private view to the full view (rather than
	conditioning it on whether extensions are enabled).
	* sem_ch7.adb (New_Private_Type): Unconditionally initialize an
	untagged private type's primitives list to a new empty list.

2 files changed, 70 insertions, 60 deletions

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 569e019..edcc1ca 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3308,33 +3308,41 @@ package body Sem_Ch3 is
       --  needed. T may be E_Void in cases of earlier errors, and in that
       --  case we bypass this.
 
-      if Ekind (T) /= E_Void
-        and then not Present (Direct_Primitive_Operations (T))
-      then
-         if Etype (T) = T then
-            Set_Direct_Primitive_Operations (T, New_Elmt_List);
+      if Ekind (T) /= E_Void then
+         if not Present (Direct_Primitive_Operations (T)) then
+            if Etype (T) = T then
+               Set_Direct_Primitive_Operations (T, New_Elmt_List);
+
+            --  If Etype of T is the base type (as opposed to a parent type)
+            --  and already has an associated list of primitive operations,
+            --  then set T's primitive list to the base type's list. Otherwise,
+            --  create a new empty primitives list and share the list between
+            --  T and its base type. The lists need to be shared in common.
 
-         --  If Etype of T is the base type (as opposed to a parent type) and
-         --  already has an associated list of primitive operations, then set
-         --  T's primitive list to the base type's list. Otherwise, create a
-         --  new empty primitives list and share the list between T and its
-         --  base type. The lists need to be shared in common between the two.
+            elsif Etype (T) = Base_Type (T) then
 
-         elsif Etype (T) = Base_Type (T) then
+               if not Present (Direct_Primitive_Operations (Base_Type (T)))
+               then
+                  Set_Direct_Primitive_Operations
+                    (Base_Type (T), New_Elmt_List);
+               end if;
 
-            if not Present (Direct_Primitive_Operations (Base_Type (T))) then
                Set_Direct_Primitive_Operations
-                 (Base_Type (T), New_Elmt_List);
-            end if;
+                 (T, Direct_Primitive_Operations (Base_Type (T)));
 
-            Set_Direct_Primitive_Operations
-              (T, Direct_Primitive_Operations (Base_Type (T)));
+            --  Case where the Etype is a parent type, so we need a new
+            --  primitives list for T.
 
-         --  Case where the Etype is a parent type, so we need a new primitives
-         --  list for T.
+            else
+               Set_Direct_Primitive_Operations (T, New_Elmt_List);
+            end if;
 
-         else
-            Set_Direct_Primitive_Operations (T, New_Elmt_List);
+         --  If T already has a Direct_Primitive_Operations list but its
+         --  base type doesn't then set the base type's list to T's list.
+
+         elsif not Present (Direct_Primitive_Operations (Base_Type (T))) then
+            Set_Direct_Primitive_Operations
+              (Base_Type (T), Direct_Primitive_Operations (T));
          end if;
       end if;
 
@@ -3509,15 +3517,13 @@ package body Sem_Ch3 is
          Make_Class_Wide_Type (T);
       end if;
 
-      --  For tagged types, or when prefixed-call syntax is allowed for
-      --  untagged types, initialize the list of primitive operations to
-      --  an empty list.
+      --  Initialize the list of primitive operations to an empty list,
+      --  to cover tagged types as well as untagged types. For untagged
+      --  types this is used either to analyze the call as legal when
+      --  Extensions_Allowed is True, or to issue a better error message
+      --  otherwise.
 
-      if Tagged_Present (N)
-        or else Extensions_Allowed
-      then
-         Set_Direct_Primitive_Operations (T, New_Elmt_List);
-      end if;
+      Set_Direct_Primitive_Operations (T, New_Elmt_List);
 
       Set_Stored_Constraint (T, No_Elist);
 
@@ -5802,18 +5808,17 @@ package body Sem_Ch3 is
          Inherit_Predicate_Flags (Id, T);
       end if;
 
-      --  When prefixed calls are enabled for untagged types, the subtype
-      --  shares the primitive operations of its base type.
-
-      if Extensions_Allowed then
-         Set_Direct_Primitive_Operations
-           (Id, Direct_Primitive_Operations (Base_Type (T)));
-      end if;
-
       if Etype (Id) = Any_Type then
          goto Leave;
       end if;
 
+      --  When prefixed calls are enabled for untagged types, the subtype
+      --  shares the primitive operations of its base type. Do this even
+      --  when Extensions_Allowed is False to issue better error messages.
+
+      Set_Direct_Primitive_Operations
+        (Id, Direct_Primitive_Operations (Base_Type (T)));
+
       --  Some common processing on all types
 
       Set_Size_Info      (Id, T);
@@ -8290,6 +8295,14 @@ package body Sem_Ch3 is
          Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
 
          if Derive_Subps then
+            --  Initialize the list of primitive operations to an empty list,
+            --  to cover tagged types as well as untagged types. For untagged
+            --  types this is used either to analyze the call as legal when
+            --  Extensions_Allowed is True, or to issue a better error message
+            --  otherwise.
+
+            Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
+
             Derive_Subprograms (Parent_Type, Derived_Type);
          end if;
 
@@ -9640,18 +9653,17 @@ package body Sem_Ch3 is
          end;
       end if;
 
-      --  When prefixed-call syntax is allowed for untagged types, initialize
-      --  the list of primitive operations to an empty list.
+      --  Initialize the list of primitive operations to an empty list,
+      --  to cover tagged types as well as untagged types. For untagged
+      --  types this is used either to analyze the call as legal when
+      --  Extensions_Allowed is True, or to issue a better error message
+      --  otherwise.
 
-      if Extensions_Allowed and then not Is_Tagged then
-         Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
-      end if;
+      Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
 
       --  Set fields for tagged types
 
       if Is_Tagged then
-         Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
-
          --  All tagged types defined in Ada.Finalization are controlled
 
          if Chars (Scope (Derived_Type)) = Name_Finalization
@@ -17211,15 +17223,13 @@ package body Sem_Ch3 is
          Set_Etype        (T, Any_Type);
          Set_Scalar_Range (T, Scalar_Range (Any_Type));
 
-         --  For tagged types, or when prefixed-call syntax is allowed for
-         --  untagged types, initialize the list of primitive operations to
-         --  an empty list.
+         --  Initialize the list of primitive operations to an empty list,
+         --  to cover tagged types as well as untagged types. For untagged
+         --  types this is used either to analyze the call as legal when
+         --  Extensions_Allowed is True, or to issue a better error message
+         --  otherwise.
 
-         if (Is_Tagged_Type (T) and then Is_Record_Type (T))
-           or else Extensions_Allowed
-         then
-            Set_Direct_Primitive_Operations (T, New_Elmt_List);
-         end if;
+         Set_Direct_Primitive_Operations (T, New_Elmt_List);
 
          return;
       end if;
@@ -21440,10 +21450,10 @@ package body Sem_Ch3 is
             end if;
 
          --  For untagged types, copy the primitives across from the private
-         --  view to the full view (when extensions are allowed), for support
-         --  of prefixed calls (when extensions are enabled).
+         --  view to the full view, for support of prefixed calls when
+         --  extensions are enabled, and better error messages otherwise.
 
-         elsif Extensions_Allowed then
+         else
             Priv_List := Primitive_Operations (Priv_T);
             Prim_Elmt := First_Elmt (Priv_List);
 
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index a0bddb1..95d7ad4 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -2633,13 +2633,13 @@ package body Sem_Ch7 is
       elsif Abstract_Present (Def) then
          Error_Msg_N ("only a tagged type can be abstract", N);
 
-      --  When extensions are enabled, we initialize the primitive operations
-      --  list of an untagged private type to an empty element list. (Note:
-      --  This could be done for all private types and shared with the tagged
-      --  case above, but for now we do it separately when the feature of
-      --  prefixed calls for untagged types is enabled.)
+      --  We initialize the primitive operations list of an untagged private
+      --  type to an empty element list. Do this even when Extensions_Allowed
+      --  is False to issue better error messages. (Note: This could be done
+      --  for all private types and shared with the tagged case above, but
+      --  for now we do it separately.)
 
-      elsif Extensions_Allowed then
+      else
          Set_Direct_Primitive_Operations (Id, New_Elmt_List);
       end if;
    end New_Private_Type;