From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: 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 616F43853551 for ; Tue, 6 Sep 2022 07:15:45 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 616F43853551 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wm1-x32f.google.com with SMTP id j26so6389350wms.0 for ; Tue, 06 Sep 2022 00:15:45 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; h=content-disposition:mime-version:message-id:subject:cc:to:from:date :from:to:cc:subject:date; bh=U0utqaJw6tTJfmIjkTF0dap5bNJOdkicFSZWgYSb4yw=; b=FxafWzmaO6jYISYUA8sxFN0DBWudho2K8OcyHoxu1uQ+AwGS5m8gzDRDMVBEakg//M JcEedDpF90xA8eIoluGGhp3Qz3v82A9IYk18l53C19ghMfayvDT736+YGxg9X/7+uoz1 uGS/so2/nG215x3wJa8+bvVUZVn8EfXBfXuQUvpazV8UywJ+Z6WlSTnoEkOrrfs9DTpJ Qli+1FtyRRnTyz9SKm/Dw4+3Z86VOIhC8PtIE8La+kvDnxA7G6BSSCDWeLTa8Nlso0xh ah0Xdo/A+0krNgBXLetHBCkwuYekmikyNYcKrXsJD4ef7xaUAmExHJE5DzKnO3Earji2 ymSQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-disposition:mime-version:message-id:subject:cc:to:from:date :x-gm-message-state:from:to:cc:subject:date; bh=U0utqaJw6tTJfmIjkTF0dap5bNJOdkicFSZWgYSb4yw=; b=x4L67r+hIrvOQAdRC69/DX+dRv0plhI1e37M086NHukuf4qltA+z9esrzNboi+JEod MGR7xiOFrmepu9wiomXpbfzlULWSjnIEJ7JQYqqAuQKoor4aeBTS4Js57gNsVv25yedU v9L6fY09UTftnveiEXZ9Z/5O1v8H0W8nW2MO5ZSbfmQMLQiWXcRTdY19zXM000lrmS2v 5JDrIHMI25jdw71WTzUCfDUytliqYnM2/JjHR2mQEDDJXMvqvI8+HXFTb0ZYh4kImY50 yPuAzqYzbyjQgTE4U2Od+ic/Y4YAWOxg5wctmcVRfzL3wqToK4q4383osUZVZFnbYEO2 2zVg== X-Gm-Message-State: ACgBeo011G+0T4oq2sF7yLMxm3zMspYxWm4DJj4h8as4N6U0MRKkUpQu yrlIPRDgH7sBPTE5HD6iVM+jGT3d9UJClA== X-Google-Smtp-Source: AA6agR6d8drigvIOgAOCIVlZWaEmu4VvTn4jsq/B7M9PK0owV3G4uvdMaOOBjau5Z5dl+8qu7jsisg== X-Received: by 2002:a05:600c:35d0:b0:3a5:f7ee:82be with SMTP id r16-20020a05600c35d000b003a5f7ee82bemr12704688wmq.206.1662448544311; Tue, 06 Sep 2022 00:15:44 -0700 (PDT) Received: from poulhies-Precision-5550 (static-176-191-105-132.ftth.abo.bbox.fr. [176.191.105.132]) by smtp.gmail.com with ESMTPSA id r7-20020a05600c35c700b003a5b6086381sm21760374wmq.48.2022.09.06.00.15.43 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Sep 2022 00:15:43 -0700 (PDT) Date: Tue, 6 Sep 2022 09:15:43 +0200 From: Marc =?iso-8859-1?Q?Poulhi=E8s?= To: gcc-patches@gcc.gnu.org Cc: Steve Baird Subject: [Ada] ICE handling discriminant-dependent index constraint for access component Message-ID: <20220906071543.GA1280232@poulhies-Precision-5550> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="HcAYCG3uE/tztfnV" Content-Disposition: inline X-Spam-Status: No, score=-12.5 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,KAM_ASCII_DIVIDERS,RCVD_IN_DNSWL_NONE,SPF_HELO_NONE,SPF_PASS,TXREP,T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: --HcAYCG3uE/tztfnV Content-Type: text/plain; charset=us-ascii Content-Disposition: inline The compiler would fail with an internal error in some cases involving a discriminated record type that provides a discriminant-dependent index constraint for the subtype of a component of an access-to-array type when a dereference of that component of some object is mentioned in a pre- or postcondition expression. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch4.adb (Analyze_Selected_Component): Define new Boolean-valued function, Constraint_Has_Unprefixed_Discriminant_Reference, which takes a subtype that is subject to a discriminant-dependent constraint and returns True if any of the constraint values are unprefixed discriminant names. Usually, the Etype of a selected component node is set to Etype of the component. However, in the case of an access-to-array component for which this predicate returns True, we instead use the base type of the Etype of the component. Normally such problematic discriminant references are addressed by calling Build_Actual_Subtype_Of_Component, but that doesn't work if Full_Analyze is False. --HcAYCG3uE/tztfnV Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="patch.diff" diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4814,6 +4814,14 @@ package body Sem_Ch4 is Is_Single_Concurrent_Object : Boolean; -- Set True if the prefix is a single task or a single protected object + function Constraint_Has_Unprefixed_Discriminant_Reference + (Typ : Entity_Id) return Boolean; + -- Given a subtype that is subject to a discriminant-dependent + -- constraint, returns True if any of the values of the constraint + -- (i.e., any of the index values for an index constraint, any of + -- the discriminant values for a discriminant constraint) + -- are unprefixed discriminant names. + procedure Find_Component_In_Instance (Rec : Entity_Id); -- In an instance, a component of a private extension may not be visible -- while it was visible in the generic. Search candidate scope for a @@ -4842,6 +4850,56 @@ package body Sem_Ch4 is -- _Procedure, and collect all its interpretations (since it may be an -- overloaded interface primitive); otherwise return False. + ------------------------------------------------------ + -- Constraint_Has_Unprefixed_Discriminant_Reference -- + ------------------------------------------------------ + + function Constraint_Has_Unprefixed_Discriminant_Reference + (Typ : Entity_Id) return Boolean + is + + function Is_Discriminant_Name (N : Node_Id) return Boolean is + ((Nkind (N) = N_Identifier) + and then (Ekind (Entity (N)) = E_Discriminant)); + begin + if Is_Array_Type (Typ) then + declare + Index : Node_Id := First_Index (Typ); + Rng : Node_Id; + begin + while Present (Index) loop + Rng := Index; + if Nkind (Rng) = N_Subtype_Indication then + Rng := Range_Expression (Constraint (Rng)); + end if; + + if Nkind (Rng) = N_Range then + if Is_Discriminant_Name (Low_Bound (Rng)) + or else Is_Discriminant_Name (High_Bound (Rng)) + then + return True; + end if; + end if; + + Next_Index (Index); + end loop; + end; + else + declare + Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Typ)); + begin + while Present (Elmt) loop + if Is_Discriminant_Name (Node (Elmt)) then + return True; + end if; + Next_Elmt (Elmt); + end loop; + end; + end if; + + return False; + end Constraint_Has_Unprefixed_Discriminant_Reference; + -------------------------------- -- Find_Component_In_Instance -- -------------------------------- @@ -5289,6 +5347,33 @@ package body Sem_Ch4 is end; end if; + -- If Etype (Comp) is an access type whose designated subtype + -- is constrained by an unprefixed discriminant value, + -- then ideally we would build a new subtype with an + -- appropriately prefixed discriminant value and use that + -- instead, as is done in Build_Actual_Subtype_Of_Component. + -- That turns out to be difficult in this context (with + -- Full_Analysis = False, we could be processing a selected + -- component that occurs in a Postcondition pragma; + -- PPC pragmas are odd because they can contain references + -- to formal parameters that occur outside the subprogram). + -- So instead we punt on building a new subtype and we + -- use the base type instead. This might introduce + -- correctness problems if N were the target of an + -- assignment (because a required check might be omitted); + -- fortunately, that's impossible because a reference to the + -- current instance of a type does not denote a variable view + -- when the reference occurs within an aspect_specification. + -- GNAT's Precondition and Postcondition pragmas follow the + -- same rules as a Pre or Post aspect_specification. + + elsif Has_Discriminant_Dependent_Constraint (Comp) + and then Ekind (Etype (Comp)) = E_Access_Subtype + and then Constraint_Has_Unprefixed_Discriminant_Reference + (Designated_Type (Etype (Comp))) + then + Set_Etype (N, Base_Type (Etype (Comp))); + -- If Full_Analysis not enabled, just set the Etype else --HcAYCG3uE/tztfnV--