From patchwork Tue Jan 9 13:15:56 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1884464 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=QExXDQRu; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4T8WrC0pk6z1yPf for ; Wed, 10 Jan 2024 00:24:59 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 24C963861809 for ; Tue, 9 Jan 2024 13:24:57 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x431.google.com (mail-wr1-x431.google.com [IPv6:2a00:1450:4864:20::431]) by sourceware.org (Postfix) with ESMTPS id 8E6923861834 for ; Tue, 9 Jan 2024 13:15:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 8E6923861834 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine 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 8E6923861834 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::431 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1704806160; cv=none; b=e3VvHvq8Vmz51pr5g0FI0Au7ckiFvyL5pH8ceGa0LRSaoCOo1GGd+AweDCBDWx1YwvpU/H2CSFgKgaqDuT1glLFIEGal0MUzokmyh5iEoFAeE2IvX3Jju4/QFHV5O/XMTaU65IW6mgcjLZMfabij66g7/M/SgQpSu/aOjtI2yt4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1704806160; c=relaxed/simple; bh=iTZ6TlURMkeKXiQziHaExfvAbz/Ln/taljES/by6pJ4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=xqXOgeVtYcEAFcfuJkH0xTkO4JSfII3nMIF0rfyINNZSpzwOoAGGj9xQgV9+oL+vszoIZ6y0aKJ6V7HbQQ0etVAyRmxPlc07kepnAVsXAr5bNvdBbYRYgZlj4h+d75sR4KJpaDBE4rUCqDMRlGya0c380X9I1GnwW3d2+oePlmI= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x431.google.com with SMTP id ffacd0b85a97d-3366e78d872so3159866f8f.3 for ; Tue, 09 Jan 2024 05:15:58 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1704806157; x=1705410957; 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=YXG6O5/IYjkt8Y3uWDo+75bLjaT8w0cEH6PwRrOYgso=; b=QExXDQRuN87ToJH5+D2e7U+1b+K/g2Ijk5TBcHRO+u6lRKW6BWmNucXl6d+mzBZvCg d2RZXBBET6ySJczLZN5DlkQk35pDX8JyuHITlPOjUobnFASYN74RvcjzE9PPz9ZVOjy7 fJstafZlRRECrBX1ptz48mfqNhiZiJBbu1z/b3/fhUQiEk9SMan0mjZ+BI35AR1m5Pul 8LZnnLc4MeBTaZOby+3wOkjssxKXSE2yw4rsnwBdU5i0lfGFZoCyxc0+DAkrxd9Tijuw XdPPU3m7IK4qo+zVthK2CAUJwn5shgOluElgl8SjL9bwbpYWx3WDFGfp7oR3mpyz9qNV A3vQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1704806157; x=1705410957; 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=YXG6O5/IYjkt8Y3uWDo+75bLjaT8w0cEH6PwRrOYgso=; b=SBJLOo3Xa+Cao5XFa3zDDYZeffyqjeKxt0++3vml1+23Ya4tOnq0aFVaE6a//vdxBw UXgtoIckiK36JnXqUvfaidTdU0vt9XcVh8yKa2RMc5EJIYT1hMHDOEc9USQMN8G7w0pY DqO4t2sxtA/kGl//eeu34O/WjAyUE2rjepfqq+U0T36aIdsAT3xwQpmIH8zsStbUiqAI wgezG5D6JZDZJzdDEbIg748muM3KVD6n0Mak1uHWJ+mUJBQIRHptGcOTfcoy/RaHQizt R3e1DSoPsBN0eLUIcW5NsWn/XV2metW7GD3IYrvEd1GbAwGOAAN1uKL1fXioE9BMFhWG /X6A== X-Gm-Message-State: AOJu0YxhbSYsx0tXr3e1FRwgWoYXo+1OraaMNwiTo7DpNMwVGCaZ/fAa qXfpEHG8rI+KDIX09wodco95hcReWGXjR2Sm9fITYNgx8g== X-Google-Smtp-Source: AGHT+IHeZeph1ZQ+2uMHGjBne2iu4IUE3ocVrsY5aH1YAv3/YrtNZjR7kZ/CP/X909VmgOT7fYqCUQ== X-Received: by 2002:adf:f685:0:b0:337:4e31:24a5 with SMTP id v5-20020adff685000000b003374e3124a5mr253367wrp.183.1704806157373; Tue, 09 Jan 2024 05:15:57 -0800 (PST) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id e30-20020a5d595e000000b0033776a50472sm1431546wri.10.2024.01.09.05.15.56 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 09 Jan 2024 05:15:56 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [COMMITTED] ada: Allow passing private types to generic formal incomplete types Date: Tue, 9 Jan 2024 14:15:56 +0100 Message-ID: <20240109131556.744810-1-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 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, 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 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Bob Duff It is legal to pass a private type, or a type with a component whose type is private, as a generic actual type if the formal is a generic formal incomplete type. This patch fixes a bug in which the compiler would give an error in some such cases. Also misc cleanup. gcc/ada/ * sem_ch12.adb (Instantiate_Type): Make the relevant error message conditional upon "Ekind (A_Gen_T) /= E_Incomplete_Type". Misc cleanup. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch12.adb | 156 +++++++++++++++++++++---------------------- 1 file changed, 76 insertions(+), 80 deletions(-) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5bddb5a8556..1d17cfacec3 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -14186,124 +14186,120 @@ package body Sem_Ch12 is if Get_Instance_Of (A_Gen_T) /= A_Gen_T then Error_Msg_N ("duplicate instantiation of generic type", Actual); return New_List (Error); + end if; - elsif not Is_Entity_Name (Actual) + if not Is_Entity_Name (Actual) or else not Is_Type (Entity (Actual)) then Error_Msg_NE ("expect valid subtype mark to instantiate &", Actual, Gen_T); Abandon_Instantiation (Actual); + end if; - else - Act_T := Entity (Actual); + Act_T := Entity (Actual); - -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed - -- as a generic actual parameter if the corresponding formal type - -- does not have a known_discriminant_part, or is a formal derived - -- type that is an Unchecked_Union type. + -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed + -- as a generic actual parameter if the corresponding formal type + -- does not have a known_discriminant_part, or is a formal derived + -- type that is an Unchecked_Union type. - if Is_Unchecked_Union (Base_Type (Act_T)) then - if not Has_Discriminants (A_Gen_T) - or else (Is_Derived_Type (A_Gen_T) - and then Is_Unchecked_Union (A_Gen_T)) - then - null; - else - Error_Msg_N ("unchecked union cannot be the actual for a " - & "discriminated formal type", Act_T); + if Is_Unchecked_Union (Base_Type (Act_T)) then + if not Has_Discriminants (A_Gen_T) + or else (Is_Derived_Type (A_Gen_T) + and then Is_Unchecked_Union (A_Gen_T)) + then + null; + else + Error_Msg_N ("unchecked union cannot be the actual for a " + & "discriminated formal type", Act_T); - end if; end if; + end if; - -- Deal with fixed/floating restrictions + -- Deal with fixed/floating restrictions - if Is_Floating_Point_Type (Act_T) then - Check_Restriction (No_Floating_Point, Actual); - elsif Is_Fixed_Point_Type (Act_T) then - Check_Restriction (No_Fixed_Point, Actual); - end if; + if Is_Floating_Point_Type (Act_T) then + Check_Restriction (No_Floating_Point, Actual); + elsif Is_Fixed_Point_Type (Act_T) then + Check_Restriction (No_Fixed_Point, Actual); + end if; - -- Deal with error of using incomplete type as generic actual. - -- This includes limited views of a type, even if the non-limited - -- view may be available. + -- Deal with error of using incomplete type as generic actual. + -- This includes limited views of a type, even if the non-limited + -- view may be available. - if Ekind (Act_T) = E_Incomplete_Type - or else (Is_Class_Wide_Type (Act_T) - and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type) - then - -- If the formal is an incomplete type, the actual can be - -- incomplete as well, but if an actual incomplete type has - -- a full view, then we'll retrieve that. + if Ekind (Act_T) = E_Incomplete_Type + or else (Is_Class_Wide_Type (Act_T) + and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type) + then + -- If the formal is an incomplete type, the actual can be + -- incomplete as well, but if an actual incomplete type has + -- a full view, then we'll retrieve that. - if Ekind (A_Gen_T) = E_Incomplete_Type - and then No (Full_View (Act_T)) - then - null; + if Ekind (A_Gen_T) = E_Incomplete_Type + and then No (Full_View (Act_T)) + then + null; - elsif Is_Class_Wide_Type (Act_T) - or else No (Full_View (Act_T)) - then - Error_Msg_N ("premature use of incomplete type", Actual); - Abandon_Instantiation (Actual); + elsif Is_Class_Wide_Type (Act_T) + or else No (Full_View (Act_T)) + then + Error_Msg_N ("premature use of incomplete type", Actual); + Abandon_Instantiation (Actual); - else - Act_T := Full_View (Act_T); - Set_Entity (Actual, Act_T); + else + Act_T := Full_View (Act_T); + Set_Entity (Actual, Act_T); - if Has_Private_Component (Act_T) then - Error_Msg_N - ("premature use of type with private component", Actual); - end if; + if Has_Private_Component (Act_T) then + Error_Msg_N + ("premature use of type with private component", Actual); end if; + end if; - -- Deal with error of premature use of private type as generic actual + -- Deal with error of premature use of private type as generic actual, + -- which is allowed for incomplete formals. - elsif Is_Private_Type (Act_T) + elsif Ekind (A_Gen_T) /= E_Incomplete_Type then + if Is_Private_Type (Act_T) and then Is_Private_Type (Base_Type (Act_T)) and then not Is_Generic_Type (Act_T) and then not Is_Derived_Type (Act_T) and then No (Full_View (Root_Type (Act_T))) then - -- If the formal is an incomplete type, the actual can be - -- private or incomplete as well. - - if Ekind (A_Gen_T) = E_Incomplete_Type then - null; - else - Error_Msg_N ("premature use of private type", Actual); - end if; + Error_Msg_N ("premature use of private type", Actual); elsif Has_Private_Component (Act_T) then Error_Msg_N ("premature use of type with private component", Actual); end if; + end if; - Set_Instance_Of (A_Gen_T, Act_T); + Set_Instance_Of (A_Gen_T, Act_T); - -- If the type is generic, the class-wide type may also be used + -- If the type is generic, the class-wide type may also be used - if Is_Tagged_Type (A_Gen_T) - and then Is_Tagged_Type (Act_T) - and then not Is_Class_Wide_Type (A_Gen_T) - then - Set_Instance_Of (Class_Wide_Type (A_Gen_T), - Class_Wide_Type (Act_T)); - end if; + if Is_Tagged_Type (A_Gen_T) + and then Is_Tagged_Type (Act_T) + and then not Is_Class_Wide_Type (A_Gen_T) + then + Set_Instance_Of (Class_Wide_Type (A_Gen_T), + Class_Wide_Type (Act_T)); + end if; - if not Is_Abstract_Type (A_Gen_T) - and then Is_Abstract_Type (Act_T) - then - Error_Msg_N - ("actual of non-abstract formal cannot be abstract", Actual); - end if; + if not Is_Abstract_Type (A_Gen_T) + and then Is_Abstract_Type (Act_T) + then + Error_Msg_N + ("actual of non-abstract formal cannot be abstract", Actual); + end if; - -- A generic scalar type is a first subtype for which we generate - -- an anonymous base type. Indicate that the instance of this base - -- is the base type of the actual. + -- A generic scalar type is a first subtype for which we generate + -- an anonymous base type. Indicate that the instance of this base + -- is the base type of the actual. - if Is_Scalar_Type (A_Gen_T) then - Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); - end if; + if Is_Scalar_Type (A_Gen_T) then + Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); end if; Check_Shared_Variable_Control_Aspects;