From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id 11EC93858018; Wed, 1 Dec 2021 10:25:29 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 11EC93858018 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-5658] [Ada] Storage error on untagged prefixed subprogram calls with -gnatX X-Act-Checkin: gcc X-Git-Author: Gary Dismukes X-Git-Refname: refs/heads/master X-Git-Oldrev: ab5996842789356d512a5eb16e00be244b0b2875 X-Git-Newrev: 7b4069fb7c00564523f822c7fd94210862eeeae4 Message-Id: <20211201102529.11EC93858018@sourceware.org> Date: Wed, 1 Dec 2021 10:25:29 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Wed, 01 Dec 2021 10:25:29 -0000 https://gcc.gnu.org/g:7b4069fb7c00564523f822c7fd94210862eeeae4 commit r12-5658-g7b4069fb7c00564523f822c7fd94210862eeeae4 Author: Gary Dismukes Date: Fri Nov 5 19:30:05 2021 -0400 [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. Diff: --- gcc/ada/sem_ch3.adb | 118 ++++++++++++++++++++++++++++------------------------ gcc/ada/sem_ch7.adb | 12 +++--- 2 files changed, 70 insertions(+), 60 deletions(-) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 569e0199dde..edcc1ca26cb 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 a0bddb19288..95d7ad4c1cd 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;