From: charlet Date: Fri, 18 Jul 2014 09:27:00 +0000 (+0000) Subject: 2014-07-18 Ed Schonberg X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=f4228f09aab2d8a3a5c9e9c8d07ed94cdd27c289;p=thirdparty%2Fgcc.git 2014-07-18 Ed Schonberg * sem_aggr.adb (Aggregate_Constraint_Checks): Moved to sem_util. * sem_util.ads, sem_util.adb (Aggregate_Constraint_Checks): Moved here, so it can be shared with the resolution of 'Update, whose argument shares some features with aggregates. * sem_attr.adb (Resolve_Attribute, case 'Update): Apply Aggregate_Constraint_Checks with the expression of each association, so that the Do_Range_Check flag is set when needed. 2014-07-18 Ed Schonberg * sem_ch4.adb (Try_Container_Indexing): If the container type is a derived type, the value of the inherited aspect is the Reference operation declared for the parent type. However, Reference is also a primitive operation of the new type, and the inherited operation has a different signature. We retrieve the right one from the list of primitive operations of the derived type. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@212786 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8641503d4933..cb343c818a52 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2014-07-18 Ed Schonberg + + * sem_aggr.adb (Aggregate_Constraint_Checks): Moved to sem_util. + * sem_util.ads, sem_util.adb (Aggregate_Constraint_Checks): + Moved here, so it can be shared with the resolution of 'Update, + whose argument shares some features with aggregates. + * sem_attr.adb (Resolve_Attribute, case 'Update): Apply + Aggregate_Constraint_Checks with the expression of each + association, so that the Do_Range_Check flag is set when needed. + +2014-07-18 Ed Schonberg + + * sem_ch4.adb (Try_Container_Indexing): If the container + type is a derived type, the value of the inherited aspect is + the Reference operation declared for the parent type. However, + Reference is also a primitive operation of the new type, and + the inherited operation has a different signature. We retrieve + the right one from the list of primitive operations of the + derived type. + 2014-07-18 Vincent Celier * debug.adb: Update comment. diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index df24ba272e30..0a272391d166 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -408,134 +408,11 @@ package body Sem_Aggr is -- The bounds of the aggregate itype are cooked up to look reasonable -- (in this particular case the bounds will be 1 .. 2). - procedure Aggregate_Constraint_Checks - (Exp : Node_Id; - Check_Typ : Entity_Id); - -- Checks expression Exp against subtype Check_Typ. If Exp is an - -- aggregate and Check_Typ a constrained record type with discriminants, - -- we generate the appropriate discriminant checks. If Exp is an array - -- aggregate then emit the appropriate length checks. If Exp is a scalar - -- type, or a string literal, Exp is changed into Check_Typ'(Exp) to - -- ensure that range checks are performed at run time. - procedure Make_String_Into_Aggregate (N : Node_Id); -- A string literal can appear in a context in which a one dimensional -- array of characters is expected. This procedure simply rewrites the -- string as an aggregate, prior to resolution. - --------------------------------- - -- Aggregate_Constraint_Checks -- - --------------------------------- - - procedure Aggregate_Constraint_Checks - (Exp : Node_Id; - Check_Typ : Entity_Id) - is - Exp_Typ : constant Entity_Id := Etype (Exp); - - begin - if Raises_Constraint_Error (Exp) then - return; - end if; - - -- Ada 2005 (AI-230): Generate a conversion to an anonymous access - -- component's type to force the appropriate accessibility checks. - - -- Ada 2005 (AI-231): Generate conversion to the null-excluding - -- type to force the corresponding run-time check - - if Is_Access_Type (Check_Typ) - and then ((Is_Local_Anonymous_Access (Check_Typ)) - or else (Can_Never_Be_Null (Check_Typ) - and then not Can_Never_Be_Null (Exp_Typ))) - then - Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); - Analyze_And_Resolve (Exp, Check_Typ); - Check_Unset_Reference (Exp); - end if; - - -- This is really expansion activity, so make sure that expansion is - -- on and is allowed. In GNATprove mode, we also want check flags to - -- be added in the tree, so that the formal verification can rely on - -- those to be present. In GNATprove mode for formal verification, some - -- treatment typically only done during expansion needs to be performed - -- on the tree, but it should not be applied inside generics. Otherwise, - -- this breaks the name resolution mechanism for generic instances. - - if not Expander_Active - and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) - then - return; - end if; - - -- First check if we have to insert discriminant checks - - if Has_Discriminants (Exp_Typ) then - Apply_Discriminant_Check (Exp, Check_Typ); - - -- Next emit length checks for array aggregates - - elsif Is_Array_Type (Exp_Typ) then - Apply_Length_Check (Exp, Check_Typ); - - -- Finally emit scalar and string checks. If we are dealing with a - -- scalar literal we need to check by hand because the Etype of - -- literals is not necessarily correct. - - elsif Is_Scalar_Type (Exp_Typ) - and then Compile_Time_Known_Value (Exp) - then - if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then - Apply_Compile_Time_Constraint_Error - (Exp, "value not in range of}??", CE_Range_Check_Failed, - Ent => Base_Type (Check_Typ), - Typ => Base_Type (Check_Typ)); - - elsif Is_Out_Of_Range (Exp, Check_Typ) then - Apply_Compile_Time_Constraint_Error - (Exp, "value not in range of}??", CE_Range_Check_Failed, - Ent => Check_Typ, - Typ => Check_Typ); - - elsif not Range_Checks_Suppressed (Check_Typ) then - Apply_Scalar_Range_Check (Exp, Check_Typ); - end if; - - -- Verify that target type is also scalar, to prevent view anomalies - -- in instantiations. - - elsif (Is_Scalar_Type (Exp_Typ) - or else Nkind (Exp) = N_String_Literal) - and then Is_Scalar_Type (Check_Typ) - and then Exp_Typ /= Check_Typ - then - if Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) = E_Constant - then - -- If expression is a constant, it is worthwhile checking whether - -- it is a bound of the type. - - if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) - and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) - or else (Is_Entity_Name (Type_High_Bound (Check_Typ)) - and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) - then - return; - - else - Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); - Analyze_And_Resolve (Exp, Check_Typ); - Check_Unset_Reference (Exp); - end if; - else - Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); - Analyze_And_Resolve (Exp, Check_Typ); - Check_Unset_Reference (Exp); - end if; - - end if; - end Aggregate_Constraint_Checks; - ------------------------ -- Array_Aggr_Subtype -- ------------------------ diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 8bd19df4ed5b..5326490da6c9 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -10802,6 +10802,7 @@ package body Sem_Attr is Typ : constant Entity_Id := Etype (Prefix (N)); Assoc : Node_Id; Comp : Node_Id; + Expr : Node_Id; begin -- Set the Etype of the aggregate to that of the prefix, even @@ -10814,12 +10815,14 @@ package body Sem_Attr is Resolve (Prefix (N), Typ); -- For an array type, resolve expressions with the component - -- type of the array. + -- type of the array, and apply constraint checks when needed. if Is_Array_Type (Typ) then Assoc := First (Component_Associations (Aggr)); while Present (Assoc) loop - Resolve (Expression (Assoc), Component_Type (Typ)); + Expr := Expression (Assoc); + Resolve (Expr, Component_Type (Typ)); + Aggregate_Constraint_Checks (Expr, Component_Type (Typ)); -- The choices in the association are static constants, -- or static aggregates each of whose components belongs diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e45d2196975d..6d0db7d63f7b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7020,6 +7020,16 @@ package body Sem_Ch4 is else return False; end if; + + -- If the container type is a derived type, the value of the inherited + -- aspect is the Reference operation declared for the parent type. + -- However, Reference is also a primitive operation of the type, and + -- the inherited operation has a different signature. We retrieve the + -- right one from the list of primitive operations of the derived type. + + elsif Is_Derived_Type (Etype (Prefix)) then + Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name)); + Func_Name := New_Occurrence_Of (Func, Loc); end if; Assoc := New_List (Relocate_Node (Prefix)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 727a994a5436..2c53b51b32d3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -52,6 +52,7 @@ with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; +with Sem_Warn; use Sem_Warn; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -474,6 +475,123 @@ package body Sem_Util is V = 64; end Addressable; + --------------------------------- + -- Aggregate_Constraint_Checks -- + --------------------------------- + + procedure Aggregate_Constraint_Checks + (Exp : Node_Id; + Check_Typ : Entity_Id) + is + Exp_Typ : constant Entity_Id := Etype (Exp); + + begin + if Raises_Constraint_Error (Exp) then + return; + end if; + + -- Ada 2005 (AI-230): Generate a conversion to an anonymous access + -- component's type to force the appropriate accessibility checks. + + -- Ada 2005 (AI-231): Generate conversion to the null-excluding + -- type to force the corresponding run-time check + + if Is_Access_Type (Check_Typ) + and then ((Is_Local_Anonymous_Access (Check_Typ)) + or else (Can_Never_Be_Null (Check_Typ) + and then not Can_Never_Be_Null (Exp_Typ))) + then + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); + end if; + + -- This is really expansion activity, so make sure that expansion is + -- on and is allowed. In GNATprove mode, we also want check flags to + -- be added in the tree, so that the formal verification can rely on + -- those to be present. In GNATprove mode for formal verification, some + -- treatment typically only done during expansion needs to be performed + -- on the tree, but it should not be applied inside generics. Otherwise, + -- this breaks the name resolution mechanism for generic instances. + + if not Expander_Active + and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) + then + return; + end if; + + -- First check if we have to insert discriminant checks + + if Has_Discriminants (Exp_Typ) then + Apply_Discriminant_Check (Exp, Check_Typ); + + -- Next emit length checks for array aggregates + + elsif Is_Array_Type (Exp_Typ) then + Apply_Length_Check (Exp, Check_Typ); + + -- Finally emit scalar and string checks. If we are dealing with a + -- scalar literal we need to check by hand because the Etype of + -- literals is not necessarily correct. + + elsif Is_Scalar_Type (Exp_Typ) + and then Compile_Time_Known_Value (Exp) + then + if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then + Apply_Compile_Time_Constraint_Error + (Exp, "value not in range of}??", CE_Range_Check_Failed, + Ent => Base_Type (Check_Typ), + Typ => Base_Type (Check_Typ)); + + elsif Is_Out_Of_Range (Exp, Check_Typ) then + Apply_Compile_Time_Constraint_Error + (Exp, "value not in range of}??", CE_Range_Check_Failed, + Ent => Check_Typ, + Typ => Check_Typ); + + elsif not Range_Checks_Suppressed (Check_Typ) then + Apply_Scalar_Range_Check (Exp, Check_Typ); + end if; + + -- Verify that target type is also scalar, to prevent view anomalies + -- in instantiations. + + elsif (Is_Scalar_Type (Exp_Typ) + or else Nkind (Exp) = N_String_Literal) + and then Is_Scalar_Type (Check_Typ) + and then Exp_Typ /= Check_Typ + then + if Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) = E_Constant + then + -- If expression is a constant, it is worthwhile checking whether + -- it is a bound of the type. + + if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) + and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) + or else + (Is_Entity_Name (Type_High_Bound (Check_Typ)) + and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) + then + return; + + else + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); + end if; + + -- Could use a comment on this case ??? + + else + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); + end if; + + end if; + end Aggregate_Constraint_Checks; + ----------------------- -- Alignment_In_Bits -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e90ad18e775a..0dbd73a221ad 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -91,6 +91,17 @@ package Sem_Util is -- Returns True if the value of V is the word size of an addressable -- factor of the word size (typically 8, 16, 32 or 64). + procedure Aggregate_Constraint_Checks + (Exp : Node_Id; + Check_Typ : Entity_Id); + -- Checks expression Exp against subtype Check_Typ. If Exp is an aggregate + -- and Check_Typ a constrained record type with discriminants, we generate + -- the appropriate discriminant checks. If Exp is an array aggregate then + -- emit the appropriate length checks. If Exp is a scalar type, or a string + -- literal, Exp is changed into Check_Typ'(Exp) to ensure that range checks + -- are performed at run time. Also used for expressions in the argument of + -- 'Update, which shares some of the features of an aggregate. + function Alignment_In_Bits (E : Entity_Id) return Uint; -- If the alignment of the type or object E is currently known to the -- compiler, then this function returns the alignment value in bits.