From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x32d.google.com (mail-wm1-x32d.google.com [IPv6:2a00:1450:4864:20::32d]) by sourceware.org (Postfix) with ESMTPS id CED9D3858280 for ; Tue, 13 Jun 2023 07:38:23 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org CED9D3858280 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-x32d.google.com with SMTP id 5b1f17b1804b1-3f8d1eb535eso1094645e9.3 for ; Tue, 13 Jun 2023 00:38:23 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1686641902; x=1689233902; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=Ec/rHnM6cMfHs2vda885swmjq5VR9nHteWOxbosuKaw=; b=eD2OViugRHYq8BeTUZTz+ubDtQHPBRe3QOu9mkmF8Q+8pmju7KQZlA2Buhm+kAELK/ PbhUx/MzSRV7qGNzmbmwgXnsl8LFh6odEuMpIPDrb/4J+lVpMmmijZA2nJe/vMn3mjAa Lu2A50zKkcLhVPhPr2Vgf0Tlio1EQhg+Fr4OsQUQwWnnaESCpAGgtScCGfOexvkCPrro OlBXL0oHqIGs+Vemle7yAGKP+uF3Vi3T3p8DP3Km0LbHK4h398wHbrPE/swOU4UbgnnA lCv+0TSrscL5ghH2B3Eue5MBTJ80xzVgMEZUS4+sxF6GytCUceYUn6MnjrDD7FK7WU/m ZvGQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1686641902; x=1689233902; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=Ec/rHnM6cMfHs2vda885swmjq5VR9nHteWOxbosuKaw=; b=Jk004oTlPvEvdis7yqziU0bPzjnLgDPVfzL8+4MaHtZX5WWg7eQ5PE39h93rz4p/9R nrL50X0PSNt9jnQM6I/CeY1pZIOoDUzIzJuhxq5Ya71oPM1/5Dzn+sqOZwMx36gVvIu7 Te176eMBIA/pGlT70ExJJGFJnZQYaPvdtl7JiPYmRbIuRwJPjrvyGfx30/wtD7ob22R5 Kg8ZEAifdSkQjwkF/QZHwT1m+KJgkQHq0OjA8D1ldTC2GbpdfwShg8pXzyZvSHYk8+Nz TrtP1VldSgUgzSek9W/G8wLApUNMwSsRl/oyJm5vheWpTEstiNGroFANDf7/jIgn1fVl o2Og== X-Gm-Message-State: AC+VfDziaRmSbiE4vQPrBUKCr3+p0iKNTdg+rKkpoMs3j2BF/zX2cOb4 PhbeRmvN2rlVigzBkXBhHWAsCRk518VYZPL8j0x27Q== X-Google-Smtp-Source: ACHHUZ5rBBi9bqGc3Kd/n6B6ogff556AeBwDfwoD71DqglFoVvQEKPyFh2XgPwqD+vtfkh5uquPTtw== X-Received: by 2002:a05:600c:2254:b0:3f7:e535:ff3b with SMTP id a20-20020a05600c225400b003f7e535ff3bmr7093678wmm.3.1686641902583; Tue, 13 Jun 2023 00:38:22 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:bfa8:5d29:40e5:cc66]) by smtp.gmail.com with ESMTPSA id u26-20020a05600c00da00b003eddc6aa5fasm13594663wmm.39.2023.06.13.00.38.21 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 13 Jun 2023 00:38:21 -0700 (PDT) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Fix spurious error on call to function returning private in generic Date: Tue, 13 Jun 2023 09:38:21 +0200 Message-Id: <20230613073821.240073-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.2 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: From: Eric Botcazou The spurious error is given on a call to a parameterless function returning a private type, present in the body of a generic construct both declared and instantiated in the presence of the full view of the type, because this full view is not properly restored for the instantiation. This is supposed to be handled by the Has_Private_View mechanism, but it is bypassed here because the call to the parameterless function is first parsed as a simple identifier before being later analyzed as a function call. Fixing this first issue uncovered another one, whereby the Has_Private_View flag was not properly set on an operator returning a private type that ends up being later resolved as a function call. Finally a small loophole in Eval_Attribute exposed by the change also needs to be plugged. gcc/ada/ * sem_attr.adb (Eval_Attribute): Add more exceptions to the early return for a prefix which is a nonfrozen generic actual type. * sem_ch12.adb (Copy_Generic_Node): Also check private views in the case of an entity name or operator analyzed as a function call. (Set_Global_Type): Make it a child of Save_Global_References. (Save_References_In_Operator): In the case where the operator has been turned into a function call, call Set_Global_Type on the entity if it is global. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_attr.adb | 8 ++- gcc/ada/sem_ch12.adb | 113 ++++++++++++++++++++++--------------------- 2 files changed, 63 insertions(+), 58 deletions(-) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 24f57ac43ff..dc06435e7b0 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -8437,9 +8437,13 @@ package body Sem_Attr is -- However, the attribute Unconstrained_Array must be evaluated, -- since it is documented to be a static attribute (and can for -- example appear in a Compile_Time_Warning pragma). The frozen - -- status of the type does not affect its evaluation. + -- status of the type does not affect its evaluation. Likewise + -- for attributes intended to be used with generic definitions. - and then Id /= Attribute_Unconstrained_Array + and then Id not in Attribute_Unconstrained_Array + | Attribute_Has_Access_Values + | Attribute_Has_Discriminants + | Attribute_Has_Tagged_Values then return; end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 2562d1a0812..0ef894e153b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -8178,6 +8178,7 @@ package body Sem_Ch12 is and then Is_Entity_Name (Name (Assoc)) then Set_Entity (New_N, Entity (Name (Assoc))); + Check_Private_View (N); elsif Nkind (Assoc) in N_Entity and then (Expander_Active @@ -15716,6 +15717,13 @@ package body Sem_Ch12 is -- This is the recursive procedure that does the work, once the -- enclosing generic scope has been established. + procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); + -- If the type of N2 is global to the generic unit, save the type in + -- the generic node. Just as we perform name capture for explicit + -- references within the generic, we must capture the global types + -- of local entities because they may participate in resolution in + -- the instance. + --------------- -- Is_Global -- --------------- @@ -15909,67 +15917,12 @@ package body Sem_Ch12 is ------------------ procedure Reset_Entity (N : Node_Id) is - procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); - -- If the type of N2 is global to the generic unit, save the type in - -- the generic node. Just as we perform name capture for explicit - -- references within the generic, we must capture the global types - -- of local entities because they may participate in resolution in - -- the instance. - function Top_Ancestor (E : Entity_Id) return Entity_Id; -- Find the ultimate ancestor of the current unit. If it is not a -- generic unit, then the name of the current unit in the prefix of -- an expanded name must be replaced with its generic homonym to -- ensure that it will be properly resolved in an instance. - --------------------- - -- Set_Global_Type -- - --------------------- - - procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is - Typ : constant Entity_Id := Etype (N2); - - begin - Set_Etype (N, Typ); - - -- If the entity of N is not the associated node, this is a - -- nested generic and it has an associated node as well, whose - -- type is already the full view (see below). Indicate that the - -- original node has a private view. - - if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then - Set_Has_Private_View (N); - end if; - - -- If not a private type, nothing else to do - - if not Is_Private_Type (Typ) then - null; - - -- If it is a derivation of a private type in a context where no - -- full view is needed, nothing to do either. - - elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then - null; - - -- Otherwise mark the type for flipping and use the full view when - -- available. - - else - Set_Has_Private_View (N); - - if Present (Full_View (Typ)) then - Set_Etype (N2, Full_View (Typ)); - end if; - end if; - - if Is_Floating_Point_Type (Typ) - and then Has_Dimension_System (Typ) - then - Copy_Dimensions (N2, N); - end if; - end Set_Global_Type; - ------------------ -- Top_Ancestor -- ------------------ @@ -16678,7 +16631,7 @@ package body Sem_Ch12 is E := Entity (Name (N2)); if Present (E) and then Is_Global (E) then - Set_Etype (N, Etype (N2)); + Set_Global_Type (N, N2); else Set_Associated_Node (N, Empty); Set_Etype (N, Empty); @@ -16845,6 +16798,54 @@ package body Sem_Ch12 is end if; end Save_References; + --------------------- + -- Set_Global_Type -- + --------------------- + + procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is + Typ : constant Entity_Id := Etype (N2); + + begin + Set_Etype (N, Typ); + + -- If the entity of N is not the associated node, this is a + -- nested generic and it has an associated node as well, whose + -- type is already the full view (see below). Indicate that the + -- original node has a private view. + + if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then + Set_Has_Private_View (N); + end if; + + -- If not a private type, nothing else to do + + if not Is_Private_Type (Typ) then + null; + + -- If it is a derivation of a private type in a context where no + -- full view is needed, nothing to do either. + + elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then + null; + + -- Otherwise mark the type for flipping and use the full view when + -- available. + + else + Set_Has_Private_View (N); + + if Present (Full_View (Typ)) then + Set_Etype (N2, Full_View (Typ)); + end if; + end if; + + if Is_Floating_Point_Type (Typ) + and then Has_Dimension_System (Typ) + then + Copy_Dimensions (N2, N); + end if; + end Set_Global_Type; + -- Start of processing for Save_Global_References begin -- 2.40.0