From patchwork Tue Aug 13 08:31:59 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: 1146118 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-506772-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="lJByvmTA"; 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 4675cm1dJrz9sNy for ; Tue, 13 Aug 2019 18:35:04 +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=d2OoICQb3wOgFpX7gMwUmJuFwaC21RGt+uDrcvCMx6FX7vQdby JKbTXeGftDdMelsb9TwwI5kgCqo4SIKiIr/NqMPKkABU1fjsQYZismt01FT/xw7P fFtVtUyhxciNLpIpNqm31dUWuFpQQ7lh4+cVR944yEqFBXeWL9XE0qCbs= 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=ryElybowm1nsNdhbO3YzVNA83HA=; b=lJByvmTAXf21+1Scd4pC YnpK06bYlIZZ3K/AssS5q9KeAMc3d5/mRiXCBn63C2tPotRc0nbQGY/iVyTrJZg8 Sc+oCXnw02e4U5jA+mYHAlbjluuaKX+iIKPMNYinb+SKRJ/lojfUh5wTb7bqxIaS 2qLc3IpKqk6Zwaf1n1GuqZU= Received: (qmail 112565 invoked by alias); 13 Aug 2019 08:32:23 -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 111966 invoked by uid 89); 13 Aug 2019 08:32:18 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.6 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, SPF_NEUTRAL autolearn=ham version=3.3.1 spammy= 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:32:15 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hxSDp-0001fU-Te for gcc-patches@gcc.gnu.org; Tue, 13 Aug 2019 04:32:04 -0400 Received: from rock.gnat.com ([205.232.38.15]:53709) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1hxSDp-0001ek-JN 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 DF64256100; 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 B+Z4-p8xrPo2; Tue, 13 Aug 2019 04:31:59 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 1538E56102; Tue, 13 Aug 2019 04:31:59 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 125AF6B4; Tue, 13 Aug 2019 04:31:59 -0400 (EDT) Date: Tue, 13 Aug 2019 04:31:59 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [Ada] Build full derivation for private concurrent type Message-ID: <20190813083158.GA38724@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 extends the processing done for the derivation of private discriminated types to concurrent types, which is now required because this derivation is no longer redone when a subtype of the derived concurrent type is built. This increases the number of entities generated internally in the compiler but this case is sufficiently rare as not to be a real concern. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-13 Eric Botcazou gcc/ada/ * sem_ch3.adb (Build_Derived_Concurrent_Type): Add a couple of local variables and use them. When the derived type fully constrains the parent type, rewrite it as a subtype of an implicit (unconstrained) derived type instead of the other way around. (Copy_And_Build): Deal with concurrent types and use predicates. (Build_Derived_Private_Type): Build the full derivation if needed for concurrent types too. (Build_Derived_Record_Type): Add marker comment. (Complete_Private_Subtype): Use predicates. gcc/testsuite/ * gnat.dg/discr56.adb, gnat.dg/discr56.ads, gnat.dg/discr56_pkg1.adb, gnat.dg/discr56_pkg1.ads, gnat.dg/discr56_pkg2.ads: New testcase. --- gcc/ada/sem_ch3.adb +++ gcc/ada/sem_ch3.adb @@ -6831,7 +6831,9 @@ package body Sem_Ch3 is Parent_Type : Entity_Id; Derived_Type : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); + Def : constant Node_Id := Type_Definition (N); + Indic : constant Node_Id := Subtype_Indication (Def); Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); Corr_Decl : Node_Id; @@ -6842,8 +6844,7 @@ package body Sem_Ch3 is -- this case. Constraint_Present : constant Boolean := - Nkind (Subtype_Indication (Type_Definition (N))) = - N_Subtype_Indication; + Nkind (Indic) = N_Subtype_Indication; D_Constraint : Node_Id; New_Constraint : Elist_Id := No_Elist; @@ -6918,36 +6919,50 @@ package body Sem_Ch3 is Expand_To_Stored_Constraint (Parent_Type, Build_Discriminant_Constraints - (Parent_Type, - Subtype_Indication (Type_Definition (N)), True)); + (Parent_Type, Indic, True)); end if; End_Scope; elsif Constraint_Present then - -- Build constrained subtype, copying the constraint, and derive - -- from it to create a derived constrained type. + -- Build an unconstrained derived type and rewrite the derived type + -- as a subtype of this new base type. declare - Loc : constant Source_Ptr := Sloc (N); - Anon : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Derived_Type), 'T')); - Decl : Node_Id; + Parent_Base : constant Entity_Id := Base_Type (Parent_Type); + New_Base : Entity_Id; + New_Decl : Node_Id; + New_Indic : Node_Id; begin - Decl := + New_Base := + Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); + + New_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => New_Base, + Type_Definition => + Make_Derived_Type_Definition (Loc, + Abstract_Present => Abstract_Present (Def), + Limited_Present => Limited_Present (Def), + Subtype_Indication => + New_Occurrence_Of (Parent_Base, Loc))); + + Mark_Rewrite_Insertion (New_Decl); + Insert_Before (N, New_Decl); + Analyze (New_Decl); + + New_Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (New_Base, Loc), + Constraint => Relocate_Node (Constraint (Indic))); + + Rewrite (N, Make_Subtype_Declaration (Loc, - Defining_Identifier => Anon, - Subtype_Indication => - New_Copy_Tree (Subtype_Indication (Type_Definition (N)))); - Insert_Before (N, Decl); - Analyze (Decl); + Defining_Identifier => Derived_Type, + Subtype_Indication => New_Indic)); - Rewrite (Subtype_Indication (Type_Definition (N)), - New_Occurrence_Of (Anon, Loc)); - Set_Analyzed (Derived_Type, False); Analyze (N); return; end; @@ -6978,10 +6993,7 @@ package body Sem_Ch3 is -- Verify that new discriminants are used to constrain old ones - D_Constraint := - First - (Constraints - (Constraint (Subtype_Indication (Type_Definition (N))))); + D_Constraint := First (Constraints (Constraint (Indic))); Old_Disc := First_Discriminant (Parent_Type); @@ -7662,14 +7674,15 @@ package body Sem_Ch3 is Full_Parent := Underlying_Full_View (Full_Parent); end if; - -- For record, access and most enumeration types, derivation from - -- the full view requires a fully-fledged declaration. In the other - -- cases, just use an itype. + -- For record, concurrent, access and most enumeration types, the + -- derivation from full view requires a fully-fledged declaration. + -- In the other cases, just use an itype. - if Ekind (Full_Parent) in Record_Kind - or else Ekind (Full_Parent) in Access_Kind + if Is_Record_Type (Full_Parent) + or else Is_Concurrent_Type (Full_Parent) + or else Is_Access_Type (Full_Parent) or else - (Ekind (Full_Parent) in Enumeration_Kind + (Is_Enumeration_Type (Full_Parent) and then not Is_Standard_Character_Type (Full_Parent) and then not Is_Generic_Type (Root_Type (Full_Parent))) then @@ -7698,7 +7711,7 @@ package body Sem_Ch3 is -- is now installed. Subprograms have been derived on the partial -- view, the completion does not derive them anew. - if Ekind (Full_Parent) in Record_Kind then + if Is_Record_Type (Full_Parent) then -- If parent type is tagged, the completion inherits the proper -- primitive operations. @@ -7900,12 +7913,10 @@ package body Sem_Ch3 is -- Build the full derivation if this is not the anonymous derived -- base type created by Build_Derived_Record_Type in the constrained -- case (see point 5. of its head comment) since we build it for the - -- derived subtype. And skip it for synchronized types altogether, as - -- gigi does not use these types directly. + -- derived subtype. if Present (Full_View (Parent_Type)) and then not Is_Itype (Derived_Type) - and then not Is_Concurrent_Type (Full_View (Parent_Type)) then declare Der_Base : constant Entity_Id := Base_Type (Derived_Type); @@ -8652,6 +8663,8 @@ package body Sem_Ch3 is end if; end Check_Generic_Ancestors; + -- Start of processing for Build_Derived_Record_Type + begin if Ekind (Parent_Type) = E_Record_Type_With_Private and then Present (Full_View (Parent_Type)) @@ -12265,10 +12278,9 @@ package body Sem_Ch3 is Save_Next_Entity := Next_Entity (Full); Save_Homonym := Homonym (Priv); - if Ekind (Full_Base) in Private_Kind - or else Ekind (Full_Base) in Protected_Kind - or else Ekind (Full_Base) in Record_Kind - or else Ekind (Full_Base) in Task_Kind + if Is_Private_Type (Full_Base) + or else Is_Record_Type (Full_Base) + or else Is_Concurrent_Type (Full_Base) then Copy_Node (Priv, Full); @@ -12411,7 +12423,7 @@ package body Sem_Ch3 is -- If the full base is itself derived from private, build a congruent -- subtype of its underlying full view, for use by the back end. - elsif Ekind (Full_Base) in Private_Kind + elsif Is_Private_Type (Full_Base) and then Present (Underlying_Full_View (Full_Base)) then declare --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/discr56.adb @@ -0,0 +1,5 @@ +-- { dg-do compile } + +package body Discr56 is + procedure Dummy is null; +end Discr56; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/discr56.ads @@ -0,0 +1,9 @@ +with Discr56_Pkg2; + +package Discr56 is + + Obj : Discr56_Pkg2.Buffer (1); + + procedure Dummy; + +end Discr56; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/discr56_pkg1.adb @@ -0,0 +1,6 @@ +package body Discr56_Pkg1 is + + protected body Buffer is + end Buffer; + +end Discr56_Pkg1; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/discr56_pkg1.ads @@ -0,0 +1,14 @@ +package Discr56_Pkg1 is + + type Buffer (Size : Positive) is limited private; + +private + + type Arr is array (Natural range <>) of Integer; + + protected type Buffer (Size : Positive) is + private + Store : Arr (0..Size); + end Buffer; + +end Discr56_Pkg1; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/discr56_pkg2.ads @@ -0,0 +1,11 @@ +with Discr56_Pkg1; + +package Discr56_Pkg2 is + + type Buffer (Size : Positive) is limited private; + +private + + type Buffer (Size : Positive) is new Discr56_Pkg1.Buffer (Size); + +end Discr56_Pkg2;