From 28fa5430b89d86f6735a4d505b5dcc891ca27ef6 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 6 Jan 2015 11:08:52 +0100 Subject: [PATCH] [multiple changes] 2015-01-06 Eric Botcazou * einfo.ads (Has_Independent_Components): Document extended usage. * einfo.adb (Has_Independent_Components): Remove obsolete assertion. (Set_Has_Independent_Components): Adjust assertion. * sem_prag.adb (Analyze_Pragma): Also set Has_Independent_Components for pragma Atomic_Components. Set Has_Independent_Components on the object instead of the type for an object declaration with pragma Independent_Components. 2015-01-06 Olivier Hainque * set_targ.adb (Read_Target_Dependent_Values): Set Long_Double_Index when "long double" is read. (elaboration code): Register_Back_End_Types only when not reading from config files. Doing otherwise is pointless and error prone. 2015-01-06 Robert Dewar * s-valrea.adb (Value_Real): Check for Str'Last = Positive'Last 2015-01-06 Robert Dewar * a-wtgeau.adb, a-ztgeau.adb, a-tigeau.adb (String_Skip): Raise PE if Str'Last = Positive'Last. 2015-01-06 Ed Schonberg * sem_ch6.adb (Matches_Limited_View): Handle properly the case where the non-limited type is a generic actual and appears as a subtype of the non-limited view of the other. * freeze.adb (Build_Renamed_Body): If the return type of the declaration that is being completed is a limited view and the non-limited view is available, use it in the specification of the generated body. 2015-01-06 Javier Miranda * exp_disp.adb: Reapplying reversed patch. 2015-01-06 Ed Schonberg * sem_ch3.adb (Find_Type_Name): If there is a previous tagged incomplete view, the type of the classwide type common to both views is the type being declared. From-SVN: r219247 --- gcc/ada/ChangeLog | 47 ++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/a-tigeau.adb | 15 +++++++++++++- gcc/ada/a-wtgeau.adb | 15 +++++++++++++- gcc/ada/a-ztgeau.adb | 15 +++++++++++++- gcc/ada/einfo.adb | 6 ++---- gcc/ada/einfo.ads | 17 +++++++++++----- gcc/ada/exp_disp.adb | 19 ++++++++++++++++++ gcc/ada/freeze.adb | 20 +++++++++++++++++++ gcc/ada/s-valrea.adb | 28 +++++++++++++++++++++----- gcc/ada/sem_ch3.adb | 12 +++++------ gcc/ada/sem_ch6.adb | 19 +++++++++++++----- gcc/ada/sem_prag.adb | 13 ++++++++---- gcc/ada/set_targ.adb | 19 +++++++++--------- 13 files changed, 203 insertions(+), 42 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3ee3eae270e..d8fb6f0e294 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2015-01-06 Eric Botcazou + + * einfo.ads (Has_Independent_Components): Document extended + usage. + * einfo.adb (Has_Independent_Components): Remove obsolete assertion. + (Set_Has_Independent_Components): Adjust assertion. + * sem_prag.adb (Analyze_Pragma): Also set Has_Independent_Components + for pragma Atomic_Components. Set Has_Independent_Components + on the object instead of the type for an object declaration with + pragma Independent_Components. + +2015-01-06 Olivier Hainque + + * set_targ.adb (Read_Target_Dependent_Values): Set + Long_Double_Index when "long double" is read. + (elaboration code): Register_Back_End_Types only when not reading from + config files. Doing otherwise is pointless and error prone. + +2015-01-06 Robert Dewar + + * s-valrea.adb (Value_Real): Check for Str'Last = Positive'Last + +2015-01-06 Robert Dewar + + * a-wtgeau.adb, a-ztgeau.adb, a-tigeau.adb (String_Skip): Raise PE if + Str'Last = Positive'Last. + +2015-01-06 Ed Schonberg + + * sem_ch6.adb (Matches_Limited_View): Handle properly the case + where the non-limited type is a generic actual and appears as + a subtype of the non-limited view of the other. + * freeze.adb (Build_Renamed_Body): If the return type of the + declaration that is being completed is a limited view and the + non-limited view is available, use it in the specification of + the generated body. + +2015-01-06 Javier Miranda + + * exp_disp.adb: Reapplying reversed patch. + +2015-01-06 Ed Schonberg + + * sem_ch3.adb (Find_Type_Name): If there is a previous tagged + incomplete view, the type of the classwide type common to both + views is the type being declared. + 2015-01-06 Eric Botcazou * einfo.ads (Is_Independent): Further document extended usage. diff --git a/gcc/ada/a-tigeau.adb b/gcc/ada/a-tigeau.adb index 24d753b040e..218aec87b8a 100644 --- a/gcc/ada/a-tigeau.adb +++ b/gcc/ada/a-tigeau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -443,6 +443,19 @@ package body Ada.Text_IO.Generic_Aux is procedure String_Skip (Str : String; Ptr : out Integer) is begin + -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. + -- It's too much trouble to make this silly case work, so we just raise + -- Program_Error with an appropriate message. We raise Program_Error + -- rather than Constraint_Error because we don't want this case to be + -- converted to Data_Error. + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + -- Normal case where Str'Last < Positive'Last + Ptr := Str'First; loop diff --git a/gcc/ada/a-wtgeau.adb b/gcc/ada/a-wtgeau.adb index f8c02755e18..7e2777313f0 100644 --- a/gcc/ada/a-wtgeau.adb +++ b/gcc/ada/a-wtgeau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -484,6 +484,19 @@ package body Ada.Wide_Text_IO.Generic_Aux is procedure String_Skip (Str : String; Ptr : out Integer) is begin + -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. + -- It's too much trouble to make this silly case work, so we just raise + -- Program_Error with an appropriate message. We raise Program_Error + -- rather than Constraint_Error because we don't want this case to be + -- converted to Data_Error. + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + -- Normal case where Str'Last < Positive'Last + Ptr := Str'First; loop diff --git a/gcc/ada/a-ztgeau.adb b/gcc/ada/a-ztgeau.adb index 27de665b18f..7f182a13fe8 100644 --- a/gcc/ada/a-ztgeau.adb +++ b/gcc/ada/a-ztgeau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -484,6 +484,19 @@ package body Ada.Wide_Wide_Text_IO.Generic_Aux is procedure String_Skip (Str : String; Ptr : out Integer) is begin + -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. + -- It's too much trouble to make this silly case work, so we just raise + -- Program_Error with an appropriate message. We raise Program_Error + -- rather than Constraint_Error because we don't want this case to be + -- converted to Data_Error. + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + -- Normal case where Str'Last < Positive'Last + Ptr := Str'First; loop diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index c5ff28ef216..7407d48f0ea 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -1468,8 +1468,7 @@ package body Einfo is function Has_Independent_Components (Id : E) return B is begin - pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id)); - return Flag34 (Base_Type (Id)); + return Flag34 (Implementation_Base_Type (Id)); end Has_Independent_Components; function Has_Inheritable_Invariants (Id : E) return B is @@ -4262,8 +4261,7 @@ package body Einfo is procedure Set_Has_Independent_Components (Id : E; V : B := True) is begin - pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id)) - and then Is_Base_Type (Id)); + pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id)); Set_Flag34 (Id, V); end Set_Has_Independent_Components; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 736ab308adb..91d7c56ddf6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1605,11 +1605,16 @@ package Einfo is -- Implicit_Dereference. Set also on the discriminant named in the aspect -- clause, to simplify type resolution. --- Has_Independent_Components (Flag34) [base type only] --- Defined in types. Set if the aspect Independent_Components applies --- (in the base type only), if corresponding pragma or aspect applies. --- In the case of an object of anonymous array type, the flag is set on --- the created array type. +-- Has_Independent_Components (Flag34) [implementation base type only] +-- Defined in all types and objects. Set only for a record type or an +-- array type or array object if a valid pragma Independent_Components +-- applies to the type or object. Note that in the case of an object, +-- this flag is only set on the object if there was an explicit pragma +-- for the object. In other words, the proper test for whether an object +-- has independent components is to see if either the object or its base +-- type has this flag set. Note that in the case of a type, the pragma +-- will be chained to the rep item chain of the first subtype in the +-- usual manner. -- Has_Inheritable_Invariants (Flag248) -- Defined in all type entities. Set in private types from which one @@ -5525,6 +5530,7 @@ package Einfo is -- Has_Atomic_Components (Flag86) -- Has_Biased_Representation (Flag139) -- Has_Completion (Flag26) (constants only) + -- Has_Independent_Components (Flag34) -- Has_Thunks (Flag228) (constants only) -- Has_Size_Clause (Flag29) -- Has_Up_Level_Access (Flag215) @@ -6236,6 +6242,7 @@ package Einfo is -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) -- Has_Biased_Representation (Flag139) + -- Has_Independent_Components (Flag34) -- Has_Initial_Value (Flag219) -- Has_Size_Clause (Flag29) -- Has_Up_Level_Access (Flag215) diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 99105e0ea4f..905311b6eb9 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1138,6 +1138,25 @@ package body Exp_Disp is Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); end if; + -- No displacement of the pointer to the object needed when the type of + -- the operand is not an interface type and the interface is one of + -- its parent types (since they share the primary dispatch table). + + declare + Opnd : Entity_Id := Operand_Typ; + + begin + if Is_Access_Type (Opnd) then + Opnd := Designated_Type (Opnd); + end if; + + if not Is_Interface (Opnd) + and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True) + then + return; + end if; + end; + -- Evaluate if we can statically displace the pointer to the object declare diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index cc5553e09ab..e87b1f4944c 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -412,6 +412,26 @@ package body Freeze is Set_Body_To_Inline (Decl, Old_S); end if; + -- Check whether the return type is a limited view. If the subprogram + -- is already frozen the generated body may have a non-limited view + -- of the type, that must be used, because it is the one in the spec + -- of the renaming declaration. + + if Ekind (Old_S) = E_Function + and then Is_Entity_Name (Result_Definition (Spec)) + then + declare + Ret_Type : constant Entity_Id := Etype (Result_Definition (Spec)); + begin + if Ekind (Ret_Type) = E_Incomplete_Type + and then Present (Non_Limited_View (Ret_Type)) + then + Set_Result_Definition (Spec, + New_Occurrence_Of (Non_Limited_View (Ret_Type), Loc)); + end if; + end; + end if; + -- The body generated for this renaming is an internal artifact, and -- does not constitute a freeze point for the called entity. diff --git a/gcc/ada/s-valrea.adb b/gcc/ada/s-valrea.adb index 5d6960df1d5..b7be0ca0435 100644 --- a/gcc/ada/s-valrea.adb +++ b/gcc/ada/s-valrea.adb @@ -377,12 +377,30 @@ package body System.Val_Real is ---------------- function Value_Real (Str : String) return Long_Long_Float is - V : Long_Long_Float; - P : aliased Integer := Str'First; begin - V := Scan_Real (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Real (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Long_Long_Float; + P : aliased Integer := Str'First; + begin + V := Scan_Real (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; end Value_Real; end System.Val_Real; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9adcb8208ac..c067539eb1c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16354,14 +16354,12 @@ package body Sem_Ch3 is Set_Ekind (Id, Ekind (Prev)); -- will be reset later Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); - -- If the incomplete type is completed by a private declaration - -- the class-wide type remains associated with the incomplete - -- type, to prevent order-of-elaboration issues in gigi, else - -- we associate the class-wide type with the known full view. + -- The type of the classwide type is the current Id. Previously + -- this was not done for private declarations because of order- + -- of elaboration issues in the back-end, but gigi now handles + -- this properly. - if Nkind (N) /= N_Private_Type_Declaration then - Set_Etype (Class_Wide_Type (Id), Id); - end if; + Set_Etype (Class_Wide_Type (Id), Id); end if; -- Case of full declaration of private type diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5794209e9d5..fcca80b3878 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6600,13 +6600,22 @@ package body Sem_Ch6 is begin -- In some cases a type imported through a limited_with clause, and -- its nonlimited view are both visible, for example in an anonymous - -- access-to-class-wide type in a formal. Both entities designate the - -- same type. - - if From_Limited_With (T1) and then T2 = Available_View (T1) then + -- access-to-class-wide type in a formal, or when building the body + -- for a subprogram renaming after the subprogram has been frozen. + -- In these cases Both entities designate the same type. In addition, + -- if one of them is an actual in an instance, it may be a subtype of + -- the non-limited view of the other. + + if From_Limited_With (T1) + and then (T2 = Available_View (T1) + or else Is_Subtype_Of (T2, Available_View (T1))) + then return True; - elsif From_Limited_With (T2) and then T1 = Available_View (T2) then + elsif From_Limited_With (T2) + and then (T1 = Available_View (T2) + or else Is_Subtype_Of (T1, Available_View (T2))) + then return True; elsif From_Limited_With (T1) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d5c1599498d..74607e57655 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -11491,12 +11491,15 @@ package body Sem_Prag is E := Base_Type (E); end if; - Set_Has_Volatile_Components (E); + -- Atomic implies both Independent and Volatile if Prag_Id = Pragma_Atomic_Components then Set_Has_Atomic_Components (E); + Set_Has_Independent_Components (E); end if; + Set_Has_Volatile_Components (E); + else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; @@ -14977,11 +14980,13 @@ package body Sem_Prag is D := Declaration_Node (E); K := Nkind (D); + -- The flag is set on the base type, or on the object + if K = N_Full_Type_Declaration and then (Is_Array_Type (E) or else Is_Record_Type (E)) then - Independence_Checks.Append ((N, Base_Type (E))); Set_Has_Independent_Components (Base_Type (E)); + Independence_Checks.Append ((N, Base_Type (E))); -- For record type, set all components independent @@ -14998,8 +15003,8 @@ package body Sem_Prag is and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition then - Independence_Checks.Append ((N, Base_Type (Etype (E)))); - Set_Has_Independent_Components (Base_Type (Etype (E))); + Set_Has_Independent_Components (E); + Independence_Checks.Append ((N, E)); else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb index 0f063e52bb8..4dbd735e97f 100755 --- a/gcc/ada/set_targ.adb +++ b/gcc/ada/set_targ.adb @@ -165,7 +165,7 @@ package body Set_Targ is -- type can be found if it gets registered at all. Long_Double_Index : Integer := -1; - -- Once all the back-end types have been registered, the index in + -- Once all the floating point types have been registered, the index in -- FPT_Mode_Table at which "long double" can be found, if anywhere. A -- negative value means that no "long double" has been registered. This -- is useful to know whether we have a "long double" available at all and @@ -769,6 +769,10 @@ package body Set_Targ is begin E.NAME := new String'(Nam_Buf (1 .. Nam_Len)); + if Long_Double_Index < 0 and then E.NAME.all = "long double" then + Long_Double_Index := Num_FPT_Modes; + end if; + E.DIGS := Get_Nat; Check_Spaces; @@ -887,13 +891,6 @@ begin end loop; end; - -- Register floating-point types from the back end. We do this - -- unconditionally so C_Type_For may be called regardless of -gnateT, for - -- which cstand has a use, and early so we can use FPT_Mode_Table below to - -- compute some FP attributes. - - Register_Back_End_Types (Register_Float_Type'Access); - -- Case of reading the target dependent values from file -- This is bit more complex than might be expected, because it has to be @@ -939,7 +936,11 @@ begin Wchar_T_Size := Get_Wchar_T_Size; Words_BE := Get_Words_BE; - -- Compute the sizes of floating point types + -- Let the back-end register its floating point types and compute + -- the sizes of our standard types from there: + + Num_FPT_Modes := 0; + Register_Back_End_Types (Register_Float_Type'Access); declare T : FPT_Mode_Entry renames -- 2.30.2