From patchwork Tue Aug 13 08:31:58 2019 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: 1146131 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-506782-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="XrWmJ4lu"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4675gK3Srgz9sN1 for ; Tue, 13 Aug 2019 18:37:15 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=LmcpeFpyqQ3rurJaa9qbHLz3gS6RalSeRUo5vUaU9dhMXh/jEl uTEqT6iNrPazxv0mJSNuHrrA0r3Z0ESoXa96OfCrLbD7Sk/b6nT1ws2YPN79A5kK cyaOjpVDSSyVr0BSqmAg5f2w7+B0xDsY5cDiIoUGO4A5uB6uo7IMlpx+c= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=sK5g7ZryE1XbF1651PiQYWzjTy4=; b=XrWmJ4lu4NtcAYFH4h1g LUrLbxTtSEYmAuwXVqpKYq1n1E1G626zDSdSfqquLbOu+iMJTWyVPzngIRP+IPQO KHKVOW11CqR11hr+GKI+vR84AL4X7IEHhYmT+lFejInVi0v0WzVGfRWodQIimNjN CWCE8Ne9YbS7WBlr/auE+kg= Received: (qmail 5998 invoked by alias); 13 Aug 2019 08:35:38 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 5930 invoked by uid 89); 13 Aug 2019 08:35:38 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.3 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, SPF_NEUTRAL autolearn=ham version=3.3.1 spammy=deeper X-HELO: eggs.gnu.org Received: from eggs.gnu.org (HELO eggs.gnu.org) (209.51.188.92) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 13 Aug 2019 08:35:36 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hxSDp-0001f9-L1 for gcc-patches@gcc.gnu.org; Tue, 13 Aug 2019 04:32:04 -0400 Received: from rock.gnat.com ([205.232.38.15]:53708) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1hxSDp-0001ed-Dd for gcc-patches@gcc.gnu.org; Tue, 13 Aug 2019 04:32:01 -0400 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id D2C77560FE; Tue, 13 Aug 2019 04:31:59 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id zsQbFvpsnhnZ; Tue, 13 Aug 2019 04:31:59 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id E6BD756101; Tue, 13 Aug 2019 04:31:58 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id E5A426B4; Tue, 13 Aug 2019 04:31:58 -0400 (EDT) Date: Tue, 13 Aug 2019 04:31:58 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Legality rule on ancestors of type extensions in generic bodies Message-ID: <20190813083158.GA38712@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 205.232.38.15 X-IsSubscribed: yes This patch adds an RM reference for the rule that in a generic body a type extension cannot have ancestors that are generic formal types. The patch also extends the check to interface progenitors that may appear in a derived type declaration or private extension declaration. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-13 Ed Schonberg gcc/ada/ * sem_ch3.adb (Check_Generic_Ancestor): New subprogram, aubsidiary to Build_Derived_Record_Type. to enforce the rule that a type extension declared in a generic body cznnot have an ancestor that is a generic formal (RM 3.9.1 (4/2)). The rule applies to all ancestors of the type, including interface progenitors. gcc/testsuite/ * gnat.dg/tagged4.adb: New testcase. --- gcc/ada/sem_ch3.adb +++ gcc/ada/sem_ch3.adb @@ -8574,6 +8574,84 @@ package body Sem_Ch3 is -- An empty Discs list means that there were no constraints in the -- subtype indication or that there was an error processing it. + procedure Check_Generic_Ancestors; + -- In Ada 2005 (AI-344), the restriction that a derived tagged type + -- cannot be declared at a deeper level than its parent type is + -- removed. The check on derivation within a generic body is also + -- relaxed, but there's a restriction that a derived tagged type + -- cannot be declared in a generic body if it's derived directly + -- or indirectly from a formal type of that generic. This applies + -- to progenitors as well. + + ----------------------------- + -- Check_Generic_Ancestors -- + ----------------------------- + + procedure Check_Generic_Ancestors is + Ancestor_Type : Entity_Id; + Intf_List : List_Id; + Intf_Name : Node_Id; + + procedure Check_Ancestor; + -- For parent and progenitors. + + -------------------- + -- Check_Ancestor -- + -------------------- + + procedure Check_Ancestor is + begin + -- If the derived type does have a formal type as an ancestor + -- then it's an error if the derived type is declared within + -- the body of the generic unit that declares the formal type + -- in its generic formal part. It's sufficient to check whether + -- the ancestor type is declared inside the same generic body + -- as the derived type (such as within a nested generic spec), + -- in which case the derivation is legal. If the formal type is + -- declared outside of that generic body, then it's certain + -- that the derived type is declared within the generic body + -- of the generic unit declaring the formal type. + + if Is_Generic_Type (Ancestor_Type) + and then Enclosing_Generic_Body (Ancestor_Type) /= + Enclosing_Generic_Body (Derived_Type) + then + Error_Msg_NE + ("ancestor type& is formal type of enclosing" + & " generic unit (RM 3.9.1 (4/2))", + Indic, Ancestor_Type); + end if; + end Check_Ancestor; + + begin + if Nkind (N) = N_Private_Extension_Declaration then + Intf_List := Interface_List (N); + else + Intf_List := Interface_List (Type_Definition (N)); + end if; + + if Present (Enclosing_Generic_Body (Derived_Type)) then + Ancestor_Type := Parent_Type; + + while not Is_Generic_Type (Ancestor_Type) + and then Etype (Ancestor_Type) /= Ancestor_Type + loop + Ancestor_Type := Etype (Ancestor_Type); + end loop; + + Check_Ancestor; + + if Present (Intf_List) then + Intf_Name := First (Intf_List); + while Present (Intf_Name) loop + Ancestor_Type := Entity (Intf_Name); + Check_Ancestor; + Next (Intf_Name); + end loop; + end if; + end if; + end Check_Generic_Ancestors; + begin if Ekind (Parent_Type) = E_Record_Type_With_Private and then Present (Full_View (Parent_Type)) @@ -8680,7 +8758,8 @@ package body Sem_Ch3 is -- Indic can either be an N_Identifier if the subtype indication -- contains no constraint or an N_Subtype_Indication if the subtype - -- indication has a constraint. + -- indecation has a constraint. In either case it can include an + -- interface list. Indic := Subtype_Indication (Type_Def); Constraint_Present := (Nkind (Indic) = N_Subtype_Indication); @@ -8909,52 +8988,8 @@ package body Sem_Ch3 is Freeze_Before (N, Parent_Type); end if; - -- In Ada 2005 (AI-344), the restriction that a derived tagged type - -- cannot be declared at a deeper level than its parent type is - -- removed. The check on derivation within a generic body is also - -- relaxed, but there's a restriction that a derived tagged type - -- cannot be declared in a generic body if it's derived directly - -- or indirectly from a formal type of that generic. - if Ada_Version >= Ada_2005 then - if Present (Enclosing_Generic_Body (Derived_Type)) then - declare - Ancestor_Type : Entity_Id; - - begin - -- Check to see if any ancestor of the derived type is a - -- formal type. - - Ancestor_Type := Parent_Type; - while not Is_Generic_Type (Ancestor_Type) - and then Etype (Ancestor_Type) /= Ancestor_Type - loop - Ancestor_Type := Etype (Ancestor_Type); - end loop; - - -- If the derived type does have a formal type as an - -- ancestor, then it's an error if the derived type is - -- declared within the body of the generic unit that - -- declares the formal type in its generic formal part. It's - -- sufficient to check whether the ancestor type is declared - -- inside the same generic body as the derived type (such as - -- within a nested generic spec), in which case the - -- derivation is legal. If the formal type is declared - -- outside of that generic body, then it's guaranteed that - -- the derived type is declared within the generic body of - -- the generic unit declaring the formal type. - - if Is_Generic_Type (Ancestor_Type) - and then Enclosing_Generic_Body (Ancestor_Type) /= - Enclosing_Generic_Body (Derived_Type) - then - Error_Msg_NE - ("parent type of& must not be descendant of formal type" - & " of an enclosing generic body", - Indic, Derived_Type); - end if; - end; - end if; + Check_Generic_Ancestors; elsif Type_Access_Level (Derived_Type) /= Type_Access_Level (Parent_Type) --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/tagged4.adb @@ -0,0 +1,28 @@ +-- { dg-do compile } + +procedure Tagged4 is + type T0 is tagged null record; + + generic + type F1 is tagged private; + procedure Gen1; + + procedure Gen1 is + type Inst1 is new F1 with null record; -- { dg-error "ancestor type \"F1\" is formal type of enclosing generic unit \\(RM 3\\.9\\.1 \\(4\\/2\\)\\)" } + begin + null; + end Gen1; + + generic + type F2 is interface; + procedure Gen2; + + procedure Gen2 is + type Inst2 is new T0 and F2 with null record; -- { dg-error "ancestor type \"F2\" is formal type of enclosing generic unit \\(RM 3\\.9\\.1 \\(4\\/2\\)\\)" } + begin + null; + end Gen2; + +begin + null; +end Tagged4;