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 A2769385DC3E for ; Tue, 19 Dec 2023 14:30:38 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A2769385DC3E Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org A2769385DC3E Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::32f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1702996241; cv=none; b=IAZmF6wVgFRZlQovwcZiWBNTAIcpR0YKxlp/vMGYHnTwjvtghquOhCskfdU+RegH5rlTYPpCh1JBd8sMjMhlXfdGbN7vEUUWVnUF65z7Dtd17yvlaekOgyjV2nHLy5QAHiYCfyuNSiYPOseVYdBEhC35VrVrTgyhDDMdZjHMjZY= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1702996241; c=relaxed/simple; bh=A163d8fsrZXckIZ4Ef3GwUvNllqhPSJiMZMWD2z1Wtg=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=Ov0l8E3Wm0POnjl5dJG9uzS7pYUVZEqMA1ovD2l/qoyv+GgG9w33N2xdWT2AbrfutUV+5YZiR6IggPVKhlLY/U4dk0qZNz4wacKWjH8Eux7I1+ot5z4Ha08ZcpIW/JCQ6x2HyK0BvLnbNwagUBFzfiDwXgMYiUzxOq685qRQEfw= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32f.google.com with SMTP id 5b1f17b1804b1-40c236624edso50937565e9.1 for ; Tue, 19 Dec 2023 06:30:38 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1702996237; x=1703601037; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=z7PKXppEhrGUQ6eV8PGfRbzBAmxzcXmORqZ9pKVwRqM=; b=IZcFaURi+1gxJPE/m49bStJ8raJxlSZYuMOMxxZhDcVe9bz0YgW9oUVEvnEUaVKmRZ 7AU1apuaX1vWsIfWuf0gdSPJfypL0EzzMWfVxwomHmie//AObGXOeZDTEvmrKAEIIs0z YP3VuMcVJQeEBdOBm4HGnLQKnIzcLD5CpVKvkfcOa7+IVu96jGMbSd/vnnh5RYiX2t0a tj4TU61lc8MMygTvd2WBNxJZRv1pAtC9yucg5s1fFvtOOIbN9/Xw3/R1T7C10ac9ELql Xpecqu6iyiB+f1oMsSncdjNLjlER0eG7wdSqUs/5KBvDcU7+1fW6bIevDhjbRwmUUv3Z 6Zyg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1702996237; x=1703601037; 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=z7PKXppEhrGUQ6eV8PGfRbzBAmxzcXmORqZ9pKVwRqM=; b=kpzosfhkVUcL6ChXu5hSDYIZ5mYICTNdIQ1z0Hi0FoNyChXViS/xKZfsAaU/zJPhoT 4h5+FADIFLke8GIeOGB2v7tB+dwn5Uf9gTI3lqfJy/q4ACeBkYna0oNeCxOKHSz/UbOK NtoxJkxLgHs0d+7XvuQL+5NxAAdJAmhHZTBxLJyAoayoPA4EZa82OGxNr5QefNGTXmlv 8FphwtL0VJw+GEnfGww2ku2RuOS+UlCFTVdw3KFeB+fgy0bT+BuZ2ly70ttKKrbBuuAI zSgbbGN6srw6Cm85LOJyKH57j39ClcwBXHs3C8LA31Qp6ZmJ38A03tmsb+6q9+m+zwld +06A== X-Gm-Message-State: AOJu0YzRecyETNEIl8LlEpMXcFhqfzx/mU7X/2rOIqlqHELnTCUqfK9E WlAo0Av7MbS3jm37B47sPEjo2ikPxrbSp+a0lOw= X-Google-Smtp-Source: AGHT+IHyQRZr4RTwZGO+0FvHaAHWaFwpIRG436YURHdCwOgp5JNTNJmrhyVzVGUF4hJC0FXN3/SC3Q== X-Received: by 2002:a7b:cbcb:0:b0:40c:34b1:b98d with SMTP id n11-20020a7bcbcb000000b0040c34b1b98dmr9377491wmi.96.1702996237430; Tue, 19 Dec 2023 06:30:37 -0800 (PST) Received: from poulhies-Precision-5550.lan ([2001:861:3382:1a90:fe1e:443:c34f:edaa]) by smtp.gmail.com with ESMTPSA id s20-20020a05600c45d400b0040b36ad5413sm3024239wmo.46.2023.12.19.06.30.36 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 19 Dec 2023 06:30:37 -0800 (PST) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Fix spurious visibility error on parent's component in instance Date: Tue, 19 Dec 2023 15:30:35 +0100 Message-ID: <20231219143035.454977-1-poulhies@adacore.com> X-Mailer: git-send-email 2.43.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 This occurs for an aggregate of a derived tagged type in the body of the instance, because the full view of the parent type, which was visible in the generic construct (otherwise the aggregate would have been illegal), is not restored in the body of the instance. Copy_Generic_Node already contains code to restore the full view in this case, but it works only if the derived tagged type is itself global to the generic construct, and not if the derived tagged type is local but the parent type global, as is the case here. gcc/ada/ * gen_il-fields.ads (Aggregate_Bounds): Rename to Aggregate_Bounds_Or_Ancestor_Type. * gen_il-gen-gen_nodes.adb (Aggregate_Bounds): Likewise. * sem_aggr.adb (Resolve_Record_Aggregate): Remove obsolete bypass. * sem_ch12.adb (Check_Generic_Actuals): Add decoration. (Copy_Generic_Node): For an extension aggregate, restore only the full view, if any. For a full aggregate, restore the full view as well as that of its Ancestor_Type, if any, and up to the root type. (Save_References_In_Aggregate): For a full aggregate of a local derived tagged type with a global ancestor, set Ancestor_Type to this ancestor. For a full aggregate of a global derived tagged type, set Ancestor_Type to the parent type. * sinfo-utils.ads (Aggregate_Bounds): New function renaming. (Ancestor_Type): Likewise. (Set_Aggregate_Bounds): New procedure renaming. (Set_Ancestor_Type): Likewise. * sinfo.ads (Ancestor_Type): Document new field. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gen_il-fields.ads | 2 +- gcc/ada/gen_il-gen-gen_nodes.adb | 2 +- gcc/ada/sem_aggr.adb | 8 +-- gcc/ada/sem_ch12.adb | 107 +++++++++++++++++++++++-------- gcc/ada/sinfo-utils.ads | 16 +++++ gcc/ada/sinfo.ads | 7 +- 6 files changed, 107 insertions(+), 35 deletions(-) diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index c565e19701d..632ce489b08 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -66,7 +66,7 @@ package Gen_IL.Fields is Acts_As_Spec, Actual_Designated_Subtype, Address_Warning_Posted, - Aggregate_Bounds, + Aggregate_Bounds_Or_Ancestor_Type, Aliased_Present, All_Others, All_Present, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 087f78567f4..064d25fbd79 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -493,7 +493,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Is_Parenthesis_Aggregate, Flag), Sy (Is_Homogeneous_Aggregate, Flag), Sy (Is_Enum_Array_Aggregate, Flag), - Sm (Aggregate_Bounds, Node_Id), + Sm (Aggregate_Bounds_Or_Ancestor_Type, Node_Id), Sm (Entity_Or_Associated_Node, Node_Id), -- just Associated_Node Sm (Compile_Time_Known_Aggregate, Flag), Sm (Expansion_Delayed, Flag), diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index e1e7b8bac37..a61326c9ae2 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -5644,18 +5644,14 @@ package body Sem_Aggr is Parent_Typ := Etype (Parent_Typ); -- Check whether a private parent requires the use of - -- an extension aggregate. This test does not apply in - -- an instantiation: if the generic unit is legal so is - -- the instance. + -- an extension aggregate. if Nkind (Parent (Base_Type (Parent_Typ))) = N_Private_Type_Declaration or else Nkind (Parent (Base_Type (Parent_Typ))) = N_Private_Extension_Declaration then - if Nkind (N) /= N_Extension_Aggregate - and then not In_Instance - then + if Nkind (N) /= N_Extension_Aggregate then Error_Msg_NE ("type of aggregate has private ancestor&!", N, Parent_Typ); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e229d217555..2b8436d7c18 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7059,10 +7059,14 @@ package body Sem_Ch12 is end if; end Check_Actual_Type; + -- Local variables + Astype : Entity_Id; E : Entity_Id; Formal : Node_Id; + -- Start of processing for Check_Generic_Actuals + begin E := First_Entity (Instance); while Present (E) loop @@ -8495,38 +8499,46 @@ package body Sem_Ch12 is Set_Associated_Node (N, New_N); else - if Present (Get_Associated_Node (N)) - and then Nkind (Get_Associated_Node (N)) = Nkind (N) - then - -- In the generic the aggregate has some composite type. If at - -- the point of instantiation the type has a private view, - -- install the full view (and that of its ancestors, if any). + -- If, in the generic, the aggregate has a global composite type + -- and, at the point of instantiation, the type has a private view + -- then install the full view. - declare - T : Entity_Id := Etype (Get_Associated_Node (N)); - Rt : Entity_Id; + declare + Assoc : constant Node_Id := Get_Associated_Node (N); - begin - if Present (T) and then Is_Private_Type (T) then - Switch_View (T); - end if; + begin + if Present (Assoc) + and then Nkind (Assoc) = Nkind (N) + and then Present (Etype (Assoc)) + and then Is_Private_Type (Etype (Assoc)) + then + Switch_View (Etype (Assoc)); + end if; + end; - if Present (T) - and then Is_Tagged_Type (T) - and then Is_Derived_Type (T) - then - Rt := Root_Type (T); + -- Moreover, for a full aggregate, if the type is a derived tagged + -- type and has a global ancestor, then also restore the full view + -- of this ancestor, and do so up to the root type. - loop - T := Etype (T); + if Nkind (N) = N_Aggregate + and then Present (Ancestor_Type (N)) + then + declare + Root_Typ : constant Entity_Id := + Root_Type (Ancestor_Type (N)); - if Is_Private_Type (T) then - Switch_View (T); - end if; + Typ : Entity_Id := Ancestor_Type (N); - exit when T = Rt; - end loop; - end if; + begin + loop + if Is_Private_Type (Typ) then + Switch_View (Typ); + end if; + + exit when Typ = Root_Typ; + + Typ := Etype (Typ); + end loop; end; end if; end if; @@ -16505,6 +16517,36 @@ package body Sem_Ch12 is if No (N2) or else No (Typ) or else not Is_Global (Typ) then Set_Associated_Node (N, Empty); + -- For a full aggregate, if the type is local but is a derived + -- tagged type of a global ancestor, we will need to have the + -- full view of this global ancestor available in the instance + -- in order to analyze the full aggregate. + + if Present (N2) + and then Nkind (N2) = N_Aggregate + and then Present (Typ) + and then Is_Tagged_Type (Typ) + and then Is_Derived_Type (Typ) + then + declare + Root_Typ : constant Entity_Id := Root_Type (Typ); + + Parent_Typ : Entity_Id := Typ; + + begin + loop + Parent_Typ := Etype (Parent_Typ); + + if Is_Global (Parent_Typ) then + Set_Ancestor_Type (N, Parent_Typ); + exit; + end if; + + exit when Parent_Typ = Root_Typ; + end loop; + end; + end if; + -- If the aggregate is an actual in a call, it has been -- resolved in the current context, to some local type. The -- enclosing call may have been disambiguated by the aggregate, @@ -16543,6 +16585,19 @@ package body Sem_Ch12 is Subtype_Mark => Nam, Expression => Relocate_Node (N)); end if; + + -- For a full aggregate, if the type is global and a derived + -- tagged type, we will also need to have the full view of its + -- ancestor available in the instance in order to analyze the + -- full aggregate. + + elsif Present (N2) + and then Nkind (N2) = N_Aggregate + and then Present (Typ) + and then Is_Tagged_Type (Typ) + and then Is_Derived_Type (Typ) + then + Set_Ancestor_Type (N, Etype (Typ)); end if; if Nkind (N) = N_Aggregate then diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads index 6ce624888b1..75d8d257c11 100644 --- a/gcc/ada/sinfo-utils.ads +++ b/gcc/ada/sinfo-utils.ads @@ -157,6 +157,22 @@ package Sinfo.Utils is (N : N_Inclusive_Has_Entity; Val : Node_Id) renames Set_Entity_Or_Associated_Node; + --------------------------------------------------- + -- Aliases for Aggregate_Bounds_Or_Ancestor_Type -- + --------------------------------------------------- + + function Aggregate_Bounds (N : Node_Id) return Node_Id + renames Aggregate_Bounds_Or_Ancestor_Type; + + function Ancestor_Type (N : Node_Id) return Node_Id + renames Aggregate_Bounds_Or_Ancestor_Type; + + procedure Set_Aggregate_Bounds (N : Node_Id; Val : Node_Id) + renames Set_Aggregate_Bounds_Or_Ancestor_Type; + + procedure Set_Ancestor_Type (N : Node_Id; Val : Node_Id) + renames Set_Aggregate_Bounds_Or_Ancestor_Type; + --------------- -- Debugging -- --------------- diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 1a6317054cf..fc4589d2087 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -845,6 +845,11 @@ package Sinfo is -- is used for translation of the at end handler into a normal exception -- handler. + -- Ancestor_Type + -- Present in record N_Aggregate nodes. Used to store the first global + -- ancestor of the type of the aggregate in a generic context, if any, + -- when the type is a derived tagged type. Otherwise Empty. + -- Aspect_On_Partial_View -- Present on an N_Aspect_Specification node. For an aspect that applies -- to a type entity, indicates whether the specification appears on the @@ -4081,7 +4086,7 @@ package Sinfo is -- Expressions (set to No_List if none or null record case) -- Component_Associations (set to No_List if none) -- Null_Record_Present - -- Aggregate_Bounds + -- Aggregate_Bounds (array) or Ancestor_Type (record) -- Associated_Node -- Compile_Time_Known_Aggregate -- Expansion_Delayed -- 2.43.0