From patchwork Fri Jan 20 10:32:19 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 717578 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org 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 3v4cV86T0Vz9sxN for ; Fri, 20 Jan 2017 21:32:48 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="Z+ptM+ad"; dkim-atps=neutral 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=GzPJevyfm0vBIkERKQmutLp5rD5zcYtVa3cJ9rH0Ml5x2fNjXH t+t4IBmYMXQlc213Qd6HyKHIRS945J0tQHhqgfPeMoA0gZEyMIX6NUWcBiVCxBgm oVjl5ZygTSjic/pKyiq6f+2OC6VzMxhgcTI9i7s9ExHLQmHGyp41XOKlM= 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=ayw1IYmK6TuoswbYpeV7YQzeNKg=; b=Z+ptM+adxdpJWIuDoTxY Log6tzSKs5GX72K6kUIJvJAoZjAkLvNQu3ahS6TN0xp4giQV3N3PNeRjroOSTQbz /gNRo44ggE7lXYfZv36p5A6BFHuZQlqcjwaaXPcMoqBRHuMCV7V1jHXnFjPANjzg Ros5l6ICft/QA3uG1im785Q= Received: (qmail 18717 invoked by alias); 20 Jan 2017 10:32:33 -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 17347 invoked by uid 89); 20 Jan 2017 10:32:20 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 20 Jan 2017 10:32:20 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 243F4117BAC; Fri, 20 Jan 2017 05:32:19 -0500 (EST) 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 NR-4oyLz8YXw; Fri, 20 Jan 2017 05:32:19 -0500 (EST) 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 1222B117B68; Fri, 20 Jan 2017 05:32:19 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4192) id 0E4964B7; Fri, 20 Jan 2017 05:32:19 -0500 (EST) Date: Fri, 20 Jan 2017 05:32:19 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Spurious error on Default_Initial_Condition Message-ID: <20170120103219.GA74180@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch modifies the generation of the Default_Initial_Condition procedure to disregard class-wide types and the underlying full views of private types. In addition, the patch preserves the attributes of freeze nodes when the partial and/or full views of a private type inherit the freeze node of the underlying full view. ------------ -- Source -- ------------ -- pack_1.ads package Pack_1 is type Untag_Par (Size : Natural) is private with Default_Initial_Condition => Is_OK_UP (Untag_Par); type Tag_Par (Size : Natural) is tagged private with Default_Initial_Condition => Is_OK_TP (Tag_Par); type Lim_Untag_Par (Size : Natural) is limited private with Default_Initial_Condition => Is_OK_LUP (Lim_Untag_Par); type Lim_Tag_Par (Size : Natural) is tagged limited private with Default_Initial_Condition => Is_OK_LTP (Lim_Tag_Par); function Is_OK_UP (Obj : Untag_Par) return Boolean; function Is_OK_TP (Obj : Tag_Par) return Boolean; function Is_OK_LUP (Obj : Lim_Untag_Par) return Boolean; function Is_OK_LTP (Obj : Lim_Tag_Par) return Boolean; private type Untag_Par (Size : Natural) is record Comp : Natural := Size; end record; type Tag_Par (Size : Natural) is tagged record Comp : Natural := Size; end record; type Lim_Untag_Par (Size : Natural) is limited record Comp : Natural := Size; end record; type Lim_Tag_par (Size : Natural) is tagged limited record Comp : Natural := Size; end record; end Pack_1; -- pack_1.adb with Ada.Text_IO; use Ada.Text_IO; package body Pack_1 is function Is_OK_UP (Obj : Untag_Par) return Boolean is begin Put_Line ("Untag_Par"); return True; end Is_OK_UP; function Is_OK_TP (Obj : Tag_Par) return Boolean is begin Put_Line ("Tag_Par"); return True; end Is_OK_TP; function Is_OK_LUP (Obj : Lim_Untag_Par) return Boolean is begin Put_Line ("Lim_Untag_Par"); return True; end Is_OK_LUP; function Is_OK_LTP (Obj : Lim_Tag_Par) return Boolean is begin Put_Line ("Lim_Tag_Par"); return True; end Is_OK_LTP; end Pack_1; -- pack_2.ads with Pack_1; use Pack_1; package Pack_2 is type Deriv_1 is private with Default_Initial_Condition => Is_OK_Deriv_1 (Deriv_1); type Deriv_2 is tagged private with Default_Initial_Condition => Is_OK_Deriv_2 (Deriv_2); type Deriv_3 is limited private with Default_Initial_Condition => Is_OK_Deriv_3 (Deriv_3); type Deriv_4 is tagged limited private with Default_Initial_Condition => Is_OK_Deriv_4 (Deriv_4); type Deriv_5 is private with Default_Initial_Condition; type Deriv_6 is tagged private with Default_Initial_Condition; type Deriv_7 is limited private with Default_Initial_Condition; type Deriv_8 is tagged limited private with Default_Initial_Condition; function Is_OK_Deriv_1 (Obj : Deriv_1) return Boolean; function Is_OK_Deriv_2 (Obj : Deriv_2) return Boolean; function Is_OK_Deriv_3 (Obj : Deriv_3) return Boolean; function Is_OK_Deriv_4 (Obj : Deriv_4) return Boolean; private type Deriv_1 is new Untag_Par (1); type Deriv_2 is new Tag_Par (2) with null record; type Deriv_3 is new Lim_Untag_Par (3); type Deriv_4 is new Lim_Tag_Par (4) with null record; type Deriv_5 is new Untag_Par (5); type Deriv_6 is new Tag_Par (6) with null record; type Deriv_7 is new Lim_Untag_Par (7); type Deriv_8 is new Lim_Tag_Par (8) with null record; end Pack_2; -- pack_2.adb with Ada.Text_IO; use Ada.Text_IO; package body Pack_2 is function Is_OK_Deriv_1 (Obj : Deriv_1) return Boolean is begin Put_Line ("Deriv_1"); return True; end Is_OK_Deriv_1; function Is_OK_Deriv_2 (Obj : Deriv_2) return Boolean is begin Put_Line ("Deriv_2"); return True; end Is_OK_Deriv_2; function Is_OK_Deriv_3 (Obj : Deriv_3) return Boolean is begin Put_Line ("Deriv_3"); return True; end Is_OK_Deriv_3; function Is_OK_Deriv_4 (Obj : Deriv_4) return Boolean is begin Put_Line ("Deriv_4"); return True; end Is_OK_Deriv_4; end Pack_2; -- main.adb with Pack_2; use Pack_2; procedure Main is Obj_1 : Deriv_1; Obj_2 : Deriv_2; Obj_3 : Deriv_3; Obj_4 : Deriv_4; Obj_5 : Deriv_5; Obj_6 : Deriv_6; Obj_7 : Deriv_7; Obj_8 : Deriv_8; begin null; end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnata main.adb $ ./main Deriv_1 Deriv_2 Deriv_3 Deriv_4 Tested on x86_64-pc-linux-gnu, committed on trunk 2017-01-20 Hristian Kirtchev * einfo.adb Flag298 now denotes Is_Underlying_Full_View. (Is_Underlying_Full_View): New routine. (Set_Is_Underlying_Full_View): New routine. (Write_Entity_Flags): Add an entry for Is_Underlying_Full_View. * einfo.ads Add new attribute Is_Underlying_Full_View. (Is_Underlying_Full_View): New routine along with pragma Inline. (Set_Is_Underlying_Full_View): New routine along with pragma Inline. * exp_util.adb (Build_DIC_Procedure_Body): Do not consider class-wide types and underlying full views. The first subtype is used as the working type for all Itypes, not just array base types. (Build_DIC_Procedure_Declaration): Do not consider class-wide types and underlying full views. The first subtype is used as the working type for all Itypes, not just array base types. * freeze.adb (Freeze_Entity): Inherit the freeze node of a full view or an underlying full view without clobbering the attributes of a previous freeze node. (Inherit_Freeze_Node): New routine. * sem_ch3.adb (Build_Derived_Private_Type): Mark an underlying full view as such. (Build_Underlying_Full_View): Mark an underlying full view as such. * sem_ch7.adb (Install_Private_Declarations): Mark an underlying full view as such. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 244691) +++ sem_ch3.adb (working copy) @@ -7444,6 +7444,7 @@ Set_Full_View (Derived_Type, Full_Der); else Set_Underlying_Full_View (Derived_Type, Full_Der); + Set_Is_Underlying_Full_View (Full_Der); end if; if not Is_Base_Type (Derived_Type) then @@ -7501,6 +7502,7 @@ Set_Full_View (Derived_Type, Full_Der); else Set_Underlying_Full_View (Derived_Type, Full_Der); + Set_Is_Underlying_Full_View (Full_Der); end if; -- In any case, the primitive operations are inherited from the @@ -7607,6 +7609,7 @@ else Build_Full_Derivation; Set_Underlying_Full_View (Derived_Type, Full_Der); + Set_Is_Underlying_Full_View (Full_Der); end if; -- The full view will be used to swap entities on entry/exit to @@ -10018,6 +10021,7 @@ Analyze (Indic); Set_Underlying_Full_View (Typ, Full_View (Subt)); + Set_Is_Underlying_Full_View (Full_View (Subt)); end Build_Underlying_Full_View; ------------------------------- Index: exp_util.adb =================================================================== --- exp_util.adb (revision 244691) +++ exp_util.adb (working copy) @@ -1736,13 +1736,24 @@ -- Start of processing for Build_DIC_Procedure_Body begin - Work_Typ := Typ; + Work_Typ := Base_Type (Typ); - -- The input type denotes the implementation base type of a constrained - -- array type. Work with the first subtype as the DIC pragma is on its - -- rep item chain. + -- Do not process class-wide types as these are Itypes, but lack a first + -- subtype (see below). - if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then + if Is_Class_Wide_Type (Work_Typ) then + return; + + -- Do not process the underlying full view of a private type. There is + -- no way to get back to the partial view, plus the body will be built + -- by the full view or the base type. + + elsif Is_Underlying_Full_View (Work_Typ) then + return; + + -- Use the first subtype when dealing with various base types + + elsif Is_Itype (Work_Typ) then Work_Typ := First_Subtype (Work_Typ); -- The input denotes the corresponding record type of a protected or a @@ -1964,13 +1975,24 @@ -- The working type begin - Work_Typ := Typ; + Work_Typ := Base_Type (Typ); - -- The input type denotes the implementation base type of a constrained - -- array type. Work with the first subtype as the DIC pragma is on its - -- rep item chain. + -- Do not process class-wide types as these are Itypes, but lack a first + -- subtype (see below). - if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then + if Is_Class_Wide_Type (Work_Typ) then + return; + + -- Do not process the underlying full view of a private type. There is + -- no way to get back to the partial view, plus the body will be built + -- by the full view or the base type. + + elsif Is_Underlying_Full_View (Work_Typ) then + return; + + -- Use the first subtype when dealing with various base types + + elsif Is_Itype (Work_Typ) then Work_Typ := First_Subtype (Work_Typ); -- The input denotes the corresponding record type of a protected or a Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 244691) +++ sem_ch7.adb (working copy) @@ -2178,6 +2178,7 @@ then Set_Full_View (Id, Underlying_Full_View (Full)); Set_Underlying_Full_View (Id, Full); + Set_Is_Underlying_Full_View (Full); Set_Underlying_Full_View (Full, Empty); Set_Is_Frozen (Full_View (Id)); Index: einfo.adb =================================================================== --- einfo.adb (revision 244691) +++ einfo.adb (working copy) @@ -614,8 +614,8 @@ -- Is_Ignored_Transient Flag295 -- Has_Partial_Visible_Refinement Flag296 -- Is_Entry_Wrapper Flag297 + -- Is_Underlying_Full_View Flag298 - -- (unused) Flag298 -- (unused) Flag299 -- (unused) Flag300 @@ -2612,6 +2612,11 @@ return Flag117 (Implementation_Base_Type (Id)); end Is_Unchecked_Union; + function Is_Underlying_Full_View (Id : E) return B is + begin + return Flag298 (Id); + end Is_Underlying_Full_View; + function Is_Underlying_Record_View (Id : E) return B is begin return Flag246 (Id); @@ -5709,6 +5714,12 @@ Set_Flag117 (Id, V); end Set_Is_Unchecked_Union; + procedure Set_Is_Underlying_Full_View (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag298 (Id, V); + end Set_Is_Underlying_Full_View; + procedure Set_Is_Underlying_Record_View (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Record_Type); @@ -9457,6 +9468,7 @@ W ("Is_Trivial_Subprogram", Flag235 (Id)); W ("Is_True_Constant", Flag163 (Id)); W ("Is_Unchecked_Union", Flag117 (Id)); + W ("Is_Underlying_Full_View", Flag298 (Id)); W ("Is_Underlying_Record_View", Flag246 (Id)); W ("Is_Unimplemented", Flag284 (Id)); W ("Is_Unsigned_Type", Flag144 (Id)); Index: einfo.ads =================================================================== --- einfo.ads (revision 244691) +++ einfo.ads (working copy) @@ -3236,6 +3236,11 @@ -- Defined in all entities. Set only in record types to which the -- pragma Unchecked_Union has been validly applied. +-- Is_Underlying_Full_View (Flag298) +-- Defined in all entities. Set for types which represent the true full +-- view of a private type completed by another private type. For further +-- details, see attribute Underlying_Full_View. + -- Is_Underlying_Record_View (Flag246) [base type only] -- Defined in all entities. Set only in record types that represent the -- underlying record view. This view is built for derivations of types @@ -7183,6 +7188,7 @@ function Is_Trivial_Subprogram (Id : E) return B; function Is_True_Constant (Id : E) return B; function Is_Unchecked_Union (Id : E) return B; + function Is_Underlying_Full_View (Id : E) return B; function Is_Underlying_Record_View (Id : E) return B; function Is_Unimplemented (Id : E) return B; function Is_Unsigned_Type (Id : E) return B; @@ -7868,6 +7874,7 @@ procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True); procedure Set_Is_True_Constant (Id : E; V : B := True); procedure Set_Is_Unchecked_Union (Id : E; V : B := True); + procedure Set_Is_Underlying_Full_View (Id : E; V : B := True); procedure Set_Is_Underlying_Record_View (Id : E; V : B := True); procedure Set_Is_Unimplemented (Id : E; V : B := True); procedure Set_Is_Unsigned_Type (Id : E; V : B := True); @@ -8705,6 +8712,7 @@ pragma Inline (Is_True_Constant); pragma Inline (Is_Type); pragma Inline (Is_Unchecked_Union); + pragma Inline (Is_Underlying_Full_View); pragma Inline (Is_Underlying_Record_View); pragma Inline (Is_Unimplemented); pragma Inline (Is_Unsigned_Type); @@ -9180,6 +9188,7 @@ pragma Inline (Set_Is_Trivial_Subprogram); pragma Inline (Set_Is_True_Constant); pragma Inline (Set_Is_Unchecked_Union); + pragma Inline (Set_Is_Underlying_Full_View); pragma Inline (Set_Is_Underlying_Record_View); pragma Inline (Set_Is_Unimplemented); pragma Inline (Set_Is_Unsigned_Type); Index: freeze.adb =================================================================== --- freeze.adb (revision 244691) +++ freeze.adb (working copy) @@ -2087,6 +2087,12 @@ -- Determine whether an arbitrary entity is subject to Boolean aspect -- Import and its value is specified as True. + procedure Inherit_Freeze_Node + (Fnod : Node_Id; + Typ : Entity_Id); + -- Set type Typ's freeze node to refer to Fnode. This routine ensures + -- that any attributes attached to Typ's original node are preserved. + procedure Wrap_Imported_Subprogram (E : Entity_Id); -- If E is an entity for an imported subprogram with pre/post-conditions -- then this procedure will create a wrapper to ensure that proper run- @@ -4726,6 +4732,60 @@ return False; end Has_Boolean_Aspect_Import; + ------------------------- + -- Inherit_Freeze_Node -- + ------------------------- + + procedure Inherit_Freeze_Node + (Fnod : Node_Id; + Typ : Entity_Id) + is + Typ_Fnod : constant Node_Id := Freeze_Node (Typ); + + begin + Set_Freeze_Node (Typ, Fnod); + Set_Entity (Fnod, Typ); + + -- The input type had an existing node. Propagate relevant attributes + -- from the old freeze node to the inherited freeze node. + + -- ??? if both freeze nodes have attributes, would they differ? + + if Present (Typ_Fnod) then + + -- Attribute Access_Types_To_Process + + if Present (Access_Types_To_Process (Typ_Fnod)) + and then No (Access_Types_To_Process (Fnod)) + then + Set_Access_Types_To_Process (Fnod, + Access_Types_To_Process (Typ_Fnod)); + end if; + + -- Attribute Actions + + if Present (Actions (Typ_Fnod)) and then No (Actions (Fnod)) then + Set_Actions (Fnod, Actions (Typ_Fnod)); + end if; + + -- Attribute First_Subtype_Link + + if Present (First_Subtype_Link (Typ_Fnod)) + and then No (First_Subtype_Link (Fnod)) + then + Set_First_Subtype_Link (Fnod, First_Subtype_Link (Typ_Fnod)); + end if; + + -- Attribute TSS_Elist + + if Present (TSS_Elist (Typ_Fnod)) + and then No (TSS_Elist (Fnod)) + then + Set_TSS_Elist (Fnod, TSS_Elist (Typ_Fnod)); + end if; + end if; + end Inherit_Freeze_Node; + ------------------------------ -- Wrap_Imported_Subprogram -- ------------------------------ @@ -5776,9 +5836,9 @@ F_Node := Freeze_Node (Full); if Present (F_Node) then - Set_Freeze_Node (Full_View (E), F_Node); - Set_Entity (F_Node, Full_View (E)); - + Inherit_Freeze_Node + (Fnod => F_Node, + Typ => Full_View (E)); else Set_Has_Delayed_Freeze (Full_View (E), False); Set_Freeze_Node (Full_View (E), Empty); @@ -5789,9 +5849,9 @@ F_Node := Freeze_Node (Full_View (E)); if Present (F_Node) then - Set_Freeze_Node (E, F_Node); - Set_Entity (F_Node, E); - + Inherit_Freeze_Node + (Fnod => F_Node, + Typ => E); else -- {Incomplete,Private}_Subtypes with Full_Views -- constrained by discriminants. @@ -5847,9 +5907,9 @@ F_Node := Freeze_Node (Underlying_Full_View (E)); if Present (F_Node) then - Set_Freeze_Node (E, F_Node); - Set_Entity (F_Node, E); - + Inherit_Freeze_Node + (Fnod => F_Node, + Typ => E); else Set_Has_Delayed_Freeze (E, False); Set_Freeze_Node (E, Empty);