From d29f68cf55fd41c19f10d789af9f92469f00f2da Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 Oct 2015 13:49:17 +0200 Subject: [multiple changes] 2015-10-20 Hristian Kirtchev * exp_ch7.adb (Process_Declarations): A loop parameter does not require finalization actions. 2015-10-20 Eric Botcazou * exp_ch6.adb (Expand_Simple_Function_Return): Do not create an actual subtype for a mutable record return type if the expression is itself a function call. 2015-10-20 Dmitriy Anisimkov * s-atocou.adb, s-atocou-builtin.adb: Fix implementation description related to new type support. 2015-10-20 Ed Schonberg * sem_res.adb (Resolve_Explicit_Dererence): Call Analyze_Dimension to propagate dimension information from prefix. * sem_dim.adb (Analyze_Dimension): Handle Explicit_Dereference. * inline.ads: minor whitespace fix in comment * sem_ch6.adb: minor gramar fix in comment 2015-10-20 Hristian Kirtchev * sem_ch3.adb (Analyze_Object_Contract): A protected type or a protected object is allowed to have a discriminated part. 2015-10-20 Bob Duff * sem_util.adb (Requires_Transient_Scope): Return true for mutable records if the maximum size is very large. 2015-10-20 Eric Botcazou * a-except-2005.adb (To_Stderr): Import Put_Char_Stderr with the same signature as in System.IO.Put. From-SVN: r229052 --- gcc/ada/ChangeLog | 40 ++++++++++++++++++ gcc/ada/a-except-2005.adb | 7 ++-- gcc/ada/exp_ch6.adb | 14 ++++--- gcc/ada/exp_ch7.adb | 9 +++++ gcc/ada/inline.ads | 2 +- gcc/ada/s-atocou-builtin.adb | 5 ++- gcc/ada/s-atocou.adb | 9 ++--- gcc/ada/sem_ch3.adb | 6 ++- gcc/ada/sem_ch6.adb | 20 +++++++-- gcc/ada/sem_dim.adb | 5 ++- gcc/ada/sem_res.adb | 1 + gcc/ada/sem_util.adb | 96 +++++++++++++++++++++++++++++++++++++++++++- 12 files changed, 186 insertions(+), 28 deletions(-) (limited to 'gcc') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fd2f4f6..0599e32 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2015-10-20 Hristian Kirtchev + + * exp_ch7.adb (Process_Declarations): A loop + parameter does not require finalization actions. + +2015-10-20 Eric Botcazou + + * exp_ch6.adb (Expand_Simple_Function_Return): Do not create an + actual subtype for a mutable record return type if the expression + is itself a function call. + +2015-10-20 Dmitriy Anisimkov + + * s-atocou.adb, s-atocou-builtin.adb: Fix implementation description + related to new type support. + +2015-10-20 Ed Schonberg + + * sem_res.adb (Resolve_Explicit_Dererence): Call Analyze_Dimension + to propagate dimension information from prefix. + * sem_dim.adb (Analyze_Dimension): Handle Explicit_Dereference. + * inline.ads: minor whitespace fix in comment + * sem_ch6.adb: minor gramar fix in comment + +2015-10-20 Hristian Kirtchev + + * sem_ch3.adb (Analyze_Object_Contract): + A protected type or a protected object is allowed to have a + discriminated part. + +2015-10-20 Bob Duff + + * sem_util.adb (Requires_Transient_Scope): + Return true for mutable records if the maximum size is very large. + +2015-10-20 Eric Botcazou + + * a-except-2005.adb (To_Stderr): Import Put_Char_Stderr with + the same signature as in System.IO.Put. + 2015-10-20 Bob Duff * a-cobove.adb (Set_Length): Restore previous logic, but with "Checks diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index e792917..43a556d4 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -1631,11 +1631,10 @@ package body Ada.Exceptions is --------------- procedure To_Stderr (C : Character) is - type int is new Integer; - procedure put_char_stderr (C : int); - pragma Import (C, put_char_stderr, "put_char_stderr"); + procedure Put_Char_Stderr (C : Character); + pragma Import (C, Put_Char_Stderr, "put_char_stderr"); begin - put_char_stderr (Character'Pos (C)); + Put_Char_Stderr (C); end To_Stderr; procedure To_Stderr (S : String) is diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 0a30953..e7d1dce 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5942,17 +5942,21 @@ package body Exp_Ch6 is elsif not Requires_Transient_Scope (R_Type) then - -- Mutable records with no variable length components are not - -- returned on the sec-stack, so we need to make sure that the - -- backend will only copy back the size of the actual value, and not - -- the maximum size. We create an actual subtype for this purpose. + -- Mutable records with variable-length components are not returned + -- on the sec-stack, so we need to make sure that the back end will + -- only copy back the size of the actual value, and not the maximum + -- size. We create an actual subtype for this purpose. However we + -- need not do it if the expression is a function call since this + -- will be done in the called function and doing it here too would + -- cause a temporary with maximum size to be created. declare Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); Decl : Node_Id; Ent : Entity_Id; begin - if Has_Discriminants (Ubt) + if Nkind (Exp) /= N_Function_Call + and then Has_Discriminants (Ubt) and then not Is_Constrained (Ubt) and then not Has_Unchecked_Union (Ubt) then diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 3836e85..5a241b2 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1837,6 +1837,15 @@ package body Exp_Ch7 is elsif Is_Ignored_Ghost_Entity (Obj_Id) then null; + -- The expansion of iterator loops generates an object + -- declaration where the Ekind is explicitly set to loop + -- parameter. This is to ensure that the loop parameter behaves + -- as a constant from user code point of view. Such object are + -- never controlled and do not require finalization. + + elsif Ekind (Obj_Id) = E_Loop_Parameter then + null; + -- The object is of the form: -- Obj : Typ [:= Expr]; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 5d1c5bb..223c3dc 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -165,7 +165,7 @@ package Inline is -- subsequently used for inline expansions at call sites. If subprogram can -- be inlined (depending on size and nature of local declarations) the -- template body is created. Otherwise subprogram body is treated normally - -- and calls are not inlined in the frontend. If proper warnings are + -- and calls are not inlined in the frontend. If proper warnings are -- enabled and the subprogram contains a construct that cannot be inlined, -- the problematic construct is flagged accordingly. diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb index 1df1c07..36a939f 100644 --- a/gcc/ada/s-atocou-builtin.adb +++ b/gcc/ada/s-atocou-builtin.adb @@ -29,8 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package implements Atomic_Counter operatiobns for platforms where --- GCC supports __sync_add_and_fetch_4 and __sync_sub_and_fetch_4 builtins. +-- This package implements Atomic_Counter and Atomic_Unsigned operations +-- for platforms where GCC supports __sync_add_and_fetch_4 and +-- __sync_sub_and_fetch_4 builtins. package body System.Atomic_Counters is diff --git a/gcc/ada/s-atocou.adb b/gcc/ada/s-atocou.adb index 87e7818..2897c6c 100644 --- a/gcc/ada/s-atocou.adb +++ b/gcc/ada/s-atocou.adb @@ -29,12 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This is dummy version of the package, for use on platforms where this --- capability is not supported. Any use of any of the routines in this --- package will raise Program_Error. - --- Why don't we use pragma Unimplemented_Unit in a dummy spec, this would --- seem much more useful than raising an exception at run time ??? +-- This is version of the package, for use on platforms where this capability +-- is not supported. All Atomic_Counter operations raises Program_Error, +-- Atomic_Unsigned operations processed in non-atomic manner. package body System.Atomic_Counters is diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 555c361..d91f831 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3347,9 +3347,11 @@ package body Sem_Ch3 is Obj_Id); -- An object of a discriminated type cannot be effectively - -- volatile (SPARK RM C.6(4)). + -- volatile except for protected objects (SPARK RM 7.1.3(5)). - elsif Has_Discriminants (Obj_Typ) then + elsif Has_Discriminants (Obj_Typ) + and then not Is_Protected_Type (Obj_Typ) + then Error_Msg_N ("discriminated object & cannot be volatile", Obj_Id); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5e1ddf5..0243700e 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -265,15 +265,16 @@ package body Sem_Ch6 is LocX : constant Source_Ptr := Sloc (Expr); Spec : constant Node_Id := Specification (N); - Def_Id : Entity_Id; + Def_Id : Entity_Id; - Prev : Entity_Id; + Prev : Entity_Id; -- If the expression is a completion, Prev is the entity whose -- declaration is completed. Def_Id is needed to analyze the spec. New_Body : Node_Id; New_Spec : Node_Id; Ret : Node_Id; + Asp : Node_Id; begin -- This is one of the occasions on which we transform the tree during @@ -449,6 +450,17 @@ package body Sem_Ch6 is Analyze (N); + -- If aspect SPARK_Mode was specified on the body, it needs to be + -- repeated both on the generated spec and the body. + + Asp := Find_Aspect (Defining_Unit_Name (Spec), Aspect_SPARK_Mode); + + if Present (Asp) then + Asp := New_Copy_Tree (Asp); + Set_Analyzed (Asp, False); + Set_Aspect_Specifications (New_Body, New_List (Asp)); + end if; + -- Within a generic pre-analyze the original expression for name -- capture. The body is also generated but plays no role in -- this because it is not part of the original source. @@ -3632,8 +3644,8 @@ package body Sem_Ch6 is -- declaration for now, as inlining of subprogram bodies acting as -- declarations, or subprogram stubs, are not supported by frontend -- inlining. This inlining should occur after analysis of the body, so - -- that it is known whether the value of SPARK_Mode applicable to the - -- body, which can be defined by a pragma inside the body. + -- that it is known whether the value of SPARK_Mode, which can be + -- defined by a pragma inside the body, is applicable to the body. elsif GNATprove_Mode and then Full_Analysis diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index ebacba9..e9bafa4 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -194,6 +194,7 @@ package body Sem_Dim is OK_For_Dimension : constant array (Node_Kind) of Boolean := (N_Attribute_Reference => True, N_Expanded_Name => True, + N_Explicit_Dereference => True, N_Defining_Identifier => True, N_Function_Call => True, N_Identifier => True, @@ -1135,6 +1136,7 @@ package body Sem_Dim is when N_Attribute_Reference | N_Expanded_Name | + N_Explicit_Dereference | N_Function_Call | N_Identifier | N_Indexed_Component | @@ -2093,7 +2095,6 @@ package body Sem_Dim is procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is Expr : constant Node_Id := Expression (N); - Dims_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr); Return_Ent : constant Entity_Id := Return_Statement_Entity (N); Return_Etyp : constant Entity_Id := Etype (Return_Applies_To (Return_Ent)); @@ -2126,7 +2127,7 @@ package body Sem_Dim is -- Start of processing for Analyze_Dimension_Simple_Return_Statement begin - if Dims_Of_Return_Etyp /= Dims_Of_Expr then + if Dims_Of_Return_Etyp /= Dimensions_Of (Expr) then Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr); Remove_Dimensions (Expr); end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5b62aed..9d7e6da 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8067,6 +8067,7 @@ package body Sem_Res is Set_Etype (N, Get_Actual_Subtype (N)); end if; + Analyze_Dimension (N); -- Note: No Eval processing is required for an explicit dereference, -- because such a name can never be static. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6875f3a..0c6e2b00 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17215,6 +17215,11 @@ package body Sem_Util is -- could be nested inside some other record that is constrained by -- nondiscriminants). That is, the recursive calls are too conservative. + function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; + -- Returns True if Typ is a nonlimited record with defaulted + -- discriminants whose max size makes it unsuitable for allocating on + -- the primary stack. + ------------------------------ -- Caller_Known_Size_Record -- ------------------------------ @@ -17267,6 +17272,85 @@ package body Sem_Util is return True; end Caller_Known_Size_Record; + ------------------------------ + -- Large_Max_Size_Mutable -- + ------------------------------ + + function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is + pragma Assert (Typ = Underlying_Type (Typ)); + + function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; + -- Returns true if the discrete type T has a large range + + ---------------------------- + -- Is_Large_Discrete_Type -- + ---------------------------- + + function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is + Threshold : constant Int := 16; + -- Arbitrary threshold above which we consider it "large". We want + -- a fairly large threshold, because these large types really + -- shouldn't have default discriminants in the first place, in + -- most cases. + + begin + return UI_To_Int (RM_Size (T)) > Threshold; + end Is_Large_Discrete_Type; + + begin + if Is_Record_Type (Typ) + and then not Is_Limited_View (Typ) + and then Has_Defaulted_Discriminants (Typ) + then + -- Loop through the components, looking for an array whose upper + -- bound(s) depends on discriminants, where both the subtype of + -- the discriminant and the index subtype are too large. + + declare + Comp : Entity_Id; + + begin + Comp := First_Entity (Typ); + while Present (Comp) loop + if Ekind (Comp) = E_Component then + declare + Comp_Type : constant Entity_Id := + Underlying_Type (Etype (Comp)); + Indx : Node_Id; + Ityp : Entity_Id; + Hi : Node_Id; + + begin + if Is_Array_Type (Comp_Type) then + Indx := First_Index (Comp_Type); + + while Present (Indx) loop + Ityp := Etype (Indx); + Hi := Type_High_Bound (Ityp); + + if Nkind (Hi) = N_Identifier + and then Ekind (Entity (Hi)) = E_Discriminant + and then Is_Large_Discrete_Type (Ityp) + and then Is_Large_Discrete_Type + (Etype (Entity (Hi))) + then + return True; + end if; + + Next_Index (Indx); + end loop; + end if; + end; + end if; + + Next_Entity (Comp); + end loop; + end; + end if; + + return False; + end Large_Max_Size_Mutable; + -- Local declarations Typ : constant Entity_Id := Underlying_Type (Id); @@ -17313,10 +17397,18 @@ package body Sem_Util is -- Untagged definite subtypes are known size. This includes all -- elementary [sub]types. Tasks are known size even if they have - -- discriminants. + -- discriminants. So we return False here, with one exception: + -- For a type like: + -- type T (Last : Natural := 0) is + -- X : String (1 .. Last); + -- end record; + -- we return True. That's because for "P(F(...));", where F returns T, + -- we don't know the size of the result at the call site, so if we + -- allocated it on the primary stack, we would have to allocate the + -- maximum size, which is way too big. elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then - return False; + return Large_Max_Size_Mutable (Typ); -- Indefinite (discriminated) untagged record or protected type -- cgit v1.1