From patchwork Wed Dec 1 10:25:21 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 48327 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 50D3F385842A for ; Wed, 1 Dec 2021 10:28:48 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 50D3F385842A DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1638354528; bh=XWu7DJUbBZq05mfTEvb4r7HAWMAQhqwnS7xVlW8qbss=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=ULqIy5ieoacAMbM+Sm2dTJbATaLULzcMPaUH0KChotIMYiJtpq3RcHWnpmn7uat4/ ANj/6eothRXccGr6SKJ04mLaqxdy+4THZLRoLcNkr+urZ2M18C1lG/afw6Llx7w9iD w6Av4LZ/iC4zHbU4LHss4/a+jYbLnIJaPlyoC4DI= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32f.google.com (mail-wm1-x32f.google.com [IPv6:2a00:1450:4864:20::32f]) by sourceware.org (Postfix) with ESMTPS id 51ADD3858422 for ; Wed, 1 Dec 2021 10:25:24 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 51ADD3858422 Received: by mail-wm1-x32f.google.com with SMTP id j140-20020a1c2392000000b003399ae48f58so21822876wmj.5 for ; Wed, 01 Dec 2021 02:25:24 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=XWu7DJUbBZq05mfTEvb4r7HAWMAQhqwnS7xVlW8qbss=; b=Yu6RW+itlw0OldeSau/klLQ1nxfEQtolfCjY9enf4uhq9vlC6xmyqB/6hJGmjJqoxf LauftqKdJ7+wc0JNXgche5NB6/PlndG89DXi6uP72jAfpfEMp7uIIWQt6+MbsceCfYLA 61TTDn3os5SbuBfvJmSsx8f+iaapJJqa0ztzKxMRlL1Fjr9kLZhNoJNUzgnlnppABDcA Dj38oWkFZrISTqEVpp98oYM/DEU048zPZSkSDlKQZ7Y2LeTZsNpigpT5Rs5i4ZW5UP1H z6yWdOE7rFnVuD/EXvcfyU6aXyMrYtDvs0Jv6Hl2dgKfl8SMu7KixxQ82ZjPTamZNfSb pZDg== X-Gm-Message-State: AOAM533mDrK9HjAJ/5IRMvpDXK1IVnSL0NcMRd99GENwr4dwR7xirPhd twDrcttegLNBaZJMfAJZJwU9ibNPSF7ESgkP X-Google-Smtp-Source: ABdhPJyUy1Z/R1v226042rg906z7gq+GS3yxPsZZNrRRns/pyvFNUbPMpcss9yOR0zTcidjxQ0T4Bw== X-Received: by 2002:a05:600c:2f01:: with SMTP id r1mr5915794wmn.153.1638354323333; Wed, 01 Dec 2021 02:25:23 -0800 (PST) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id m7sm525266wml.38.2021.12.01.02.25.22 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 01 Dec 2021 02:25:22 -0800 (PST) Date: Wed, 1 Dec 2021 10:25:21 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Storage error on untagged prefixed subprogram calls with -gnatX Message-ID: <20211201102521.GA1635025@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Gary Dismukes Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" 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 --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;