diff mbox series

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

Message ID 20211201102521.GA1635025@adacore.com
State Committed
Headers show
Series [Ada] Storage error on untagged prefixed subprogram calls with -gnatX | expand

Commit Message

Pierre-Marie de Rodat Dec. 1, 2021, 10:25 a.m. UTC
The compiler can crash when compiling the prefixed form of subprogram
calls for untagged types when extensions are enabled. Problems can also
manifest in cases where such calls occur in the absence of extensions
being enabled.  The source of this is that the
Direct_Primitive_Operations lists were conditionally being initialized,
based on whether extensions are allowed or whether untagged types are
involved. This set of changes is directed at making the lists be
unconditionally initialized and inherited in most cases (note that there
might still be some missing cases).

Tested on x86_64-pc-linux-gnu, committed on trunk

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.
diff mbox series

Patch

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
--- 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
--- 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;