From de4993fc63be366b2f0e42382243491662c4a2eb Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 7 Mar 2012 17:07:55 +0000 Subject: [PATCH] 2012-03-07 Bob Duff * rtsfind.ads: Add support for finding Super_String types. * sem_util.ads, sem_util.adb (Is_Bounded_String): New function to determine whether a given type is a bounded string type. (Is_Fully_Initialized_Type): Return True for bounded string types, to suppress bogus warnings. * exp_ch4.adb (Expand_Composite_Equality): Special case for bounded strings: equality composes. This allows us to remove default values in super strings. * a-strsup.ads, a-stwisu.ads, a-stzsup.ads: Update comments. * exp_ch3.adb (Expand_Freeze_Record_Type): Comment. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@185066 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 13 +++++++++++++ gcc/ada/a-strsup.ads | 5 +++-- gcc/ada/a-stwisu.ads | 5 +++-- gcc/ada/a-stzsup.ads | 5 +++-- gcc/ada/exp_ch3.adb | 6 +++--- gcc/ada/exp_ch4.adb | 19 +++++++++++++------ gcc/ada/rtsfind.ads | 17 ++++++++++++++++- gcc/ada/sem_util.adb | 27 +++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 4 ++++ 9 files changed, 85 insertions(+), 16 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 74cd5cc..8e1f638 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2012-03-07 Bob Duff + + * rtsfind.ads: Add support for finding Super_String types. + * sem_util.ads, sem_util.adb (Is_Bounded_String): New function + to determine whether a given type is a bounded string type. + (Is_Fully_Initialized_Type): Return True for bounded + string types, to suppress bogus warnings. + * exp_ch4.adb (Expand_Composite_Equality): Special case for bounded + strings: equality composes. This allows us to remove default values in + super strings. + * a-strsup.ads, a-stwisu.ads, a-stzsup.ads: Update comments. + * exp_ch3.adb (Expand_Freeze_Record_Type): Comment. + 2012-03-07 Robert Dewar * sem_util.adb, exp_ch4.adb, exp_ch6.adb, sem_ch6.adb: Minor diff --git a/gcc/ada/a-strsup.ads b/gcc/ada/a-strsup.ads index 39f3364..185f888 100644 --- a/gcc/ada/a-strsup.ads +++ b/gcc/ada/a-strsup.ads @@ -45,8 +45,9 @@ package Ada.Strings.Superbounded is Current_Length : Natural := 0; Data : String (1 .. Max_Length); -- A previous version had a default initial value for Data, which is no - -- longer necessary, because "=" now composes properly for untagged - -- records. Leaving it out is more efficient. + -- longer necessary, because we now special-case this type in the + -- compiler, so "=" composes properly for descendants of this + -- type. Leaving it out is more efficient. end record; -- Type Bounded_String in Ada.Strings.Bounded.Generic_Bounded_Length is -- derived from this type, with the constraint of the maximum length. diff --git a/gcc/ada/a-stwisu.ads b/gcc/ada/a-stwisu.ads index bc0c5c1..6b8d3a4 100644 --- a/gcc/ada/a-stwisu.ads +++ b/gcc/ada/a-stwisu.ads @@ -48,8 +48,9 @@ package Ada.Strings.Wide_Superbounded is Current_Length : Natural := 0; Data : Wide_String (1 .. Max_Length); -- A previous version had a default initial value for Data, which is no - -- longer necessary, because "=" now composes properly for untagged - -- records. Leaving it out is more efficient. + -- longer necessary, because we now special-case this type in the + -- compiler, so "=" composes properly for descendants of this + -- type. Leaving it out is more efficient. end record; -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length.Wide_Bounded_String is -- derived from this type, with the constraint of the maximum length. diff --git a/gcc/ada/a-stzsup.ads b/gcc/ada/a-stzsup.ads index 3028aaa..cb0d173 100644 --- a/gcc/ada/a-stzsup.ads +++ b/gcc/ada/a-stzsup.ads @@ -49,8 +49,9 @@ package Ada.Strings.Wide_Wide_Superbounded is Current_Length : Natural := 0; Data : Wide_Wide_String (1 .. Max_Length); -- A previous version had a default initial value for Data, which is no - -- longer necessary, because "=" now composes properly for untagged - -- records. Leaving it out is more efficient. + -- longer necessary, because we now special-case this type in the + -- compiler, so "=" composes properly for descendants of this + -- type. Leaving it out is more efficient. end record; -- Wide_Wide_Bounded.Generic_Bounded_Length.Wide_Wide_Bounded_String is -- derived from this type, with the constraint of the maximum length. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d186503..4cc9cae 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6115,9 +6115,9 @@ package body Exp_Ch3 is -- This is done unconditionally to ensure that tools can be linked -- properly with user programs compiled with older language versions. - -- It might be worth including a switch to revert to a non-composable - -- equality for untagged records, even though no program depending on - -- non-composability has surfaced ??? + -- In addition, this is needed because "=" composes for bounded strings + -- in all language versions (see also + -- Exp_Ch4.Expand_Composite_Equality). elsif Comes_From_Source (Def_Id) and then Convention (Def_Id) = Convention_Ada diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 001b9ed..f9c1f3c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -149,10 +149,10 @@ package body Exp_Ch4 is -- Local recursive function used to expand equality for nested composite -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which -- to attach bodies of local functions that are created in the process. - -- This is the responsibility of the caller to insert those bodies at the + -- It is the responsibility of the caller to insert those bodies at the -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs -- are the left and right sides for the comparison, and Typ is the type of - -- the arrays to compare. + -- the objects to compare. procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); -- Routine to expand concatenation of a sequence of two or more operands @@ -2488,17 +2488,24 @@ package body Exp_Ch4 is end if; end if; - elsif Ada_Version >= Ada_2012 then + -- Equality composes in Ada 2012 for untagged record types. It also + -- composes for bounded strings, because they are part of the + -- predefined environment. We could make it compose for bounded + -- strings by making them tagged, or by making sure all subcomponents + -- are set to the same value, even when not used. Instead, we have + -- this special case in the compiler, because it's more efficient. + + elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then -- if no TSS has been created for the type, check whether there is -- a primitive equality declared for it. declare - Ada_2012_Op : constant Node_Id := Find_Primitive_Eq; + Op : constant Node_Id := Find_Primitive_Eq; begin - if Present (Ada_2012_Op) then - return Ada_2012_Op; + if Present (Op) then + return Op; else -- Use predefined equality if no user-defined primitive exists diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 7720d5e..88e61dc 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -160,6 +160,9 @@ package Rtsfind is -- Children of Ada.Strings + Ada_Strings_Superbounded, + Ada_Strings_Wide_Superbounded, + Ada_Strings_Wide_Wide_Superbounded, Ada_Strings_Unbounded, -- Children of Ada.Text_IO (for Text_IO_Kludge) @@ -438,7 +441,7 @@ package Rtsfind is -- Range of values for children of Ada.Streams subtype Ada_Strings_Child is Ada_Child - range Ada_Strings_Unbounded .. Ada_Strings_Unbounded; + range Ada_Strings_Superbounded .. Ada_Strings_Unbounded; -- Range of values for children of Ada.Strings subtype Ada_Text_IO_Child is Ada_Child @@ -588,6 +591,12 @@ package Rtsfind is RE_Stream_Access, -- Ada.Streams.Stream_IO + RO_SU_Super_String, -- Ada.Strings.Superbounded + + RO_WI_Super_String, -- Ada.Strings.Wide_Superbounded + + RO_WW_Super_String, -- Ada.Strings.Wide_Wide_Superbounded + RE_Unbounded_String, -- Ada.Strings.Unbounded RE_Access_Level, -- Ada.Tags @@ -1790,6 +1799,12 @@ package Rtsfind is RE_Stream_Access => Ada_Streams_Stream_IO, + RO_SU_Super_String => Ada_Strings_Superbounded, + + RO_WI_Super_String => Ada_Strings_Wide_Superbounded, + + RO_WW_Super_String => Ada_Strings_Wide_Wide_Superbounded, + RE_Unbounded_String => Ada_Strings_Unbounded, RE_Access_Level => Ada_Tags, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 87a9334..665e399 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6746,6 +6746,25 @@ package body Sem_Util is end if; end Is_Atomic_Object; + ----------------------- + -- Is_Bounded_String -- + ----------------------- + + function Is_Bounded_String (T : Entity_Id) return Boolean is + -- Check whether T is ultimately derived from Ada.Strings.- + -- Superbounded.Super_String, or one of the [Wide_]Wide_ + -- versions. This will be True for all the Bounded_String types in + -- instances of the Generic_Bounded_Length generics, and for types + -- derived from those. + + Under : constant Entity_Id := Underlying_Type (Root_Type (T)); + begin + return Present (Under) and then + (Is_RTE (Root_Type (Under), RO_SU_Super_String) + or else Is_RTE (Root_Type (Under), RO_WI_Super_String) + or else Is_RTE (Root_Type (Under), RO_WW_Super_String)); + end Is_Bounded_String; + ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- @@ -7215,6 +7234,14 @@ package body Sem_Util is return True; end if; + -- We consider bounded string types to be fully initialized, because + -- otherwise we get false alarms when the Data component is not + -- default-initialized. + + if Is_Bounded_String (Typ) then + return True; + end if; + -- Controlled records are considered to be fully initialized if -- there is a user defined Initialize routine. This may not be -- entirely correct, but as the spec notes, we are guessing here diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 8d31386..0df5450 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -793,6 +793,10 @@ package Sem_Util is -- Determines if the given node denotes an atomic object in the sense of -- the legality checks described in RM C.6(12). + function Is_Bounded_String (T : Entity_Id) return Boolean; + -- True if T is a bounded string type. Used to make sure "=" composes + -- properly for bounded string types. + function Is_Controlling_Limited_Procedure (Proc_Nam : Entity_Id) return Boolean; -- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure -- 2.7.4