diff options
author | Ed Schonberg <schonberg@adacore.com> | 2014-08-01 08:22:22 +0000 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-08-01 10:22:22 +0200 |
commit | a62828520413d90d5dd11c43068b31a46d4fbd75 (patch) | |
tree | efca47fc8a07665edf55f42f6a080abec3a50aff | |
parent | fd29c0247aa4af7492782e6c933c713c6732b4b0 (diff) | |
download | gcc-a62828520413d90d5dd11c43068b31a46d4fbd75.zip gcc-a62828520413d90d5dd11c43068b31a46d4fbd75.tar.gz gcc-a62828520413d90d5dd11c43068b31a46d4fbd75.tar.bz2 |
2014-08-01 Ed Schonberg <schonberg@adacore.com>
* einfo.ads, einfo.adb New flags No_Predicate_On_Actual and
No_Dynamic_Predicate_On_Actual, to enforce the generic contract
on generic units that contain constructs that forbid subtypes
with predicates.
* sem_ch3.adb (Analyze_Subtype_Declaration, Process_Subtype):
Inherit flags indicating the presence of predicates in subtype
declarations with and without constraints.
(Inherit_Predicate_Flags): Utility for the above.
* sem_util.adb (Bad_Predicated_Subtype_Use): In a generic context,
indicate that the actual cannot have predicates, and preserve
warning. In an instance, report error if actual has predicates
and the construct appears in a package declaration.
* sem_ch12.adb (Diagnose_Predicated_Actual): Report error
for an actual with predicates, if the corresponding formal
carries No_Predicate_On_Actual or (in the case of a loop)
No_Dynamic_Predicate_On_Actual.
* sem_ch13.adb (Build_Predicate_Functions); Do not build a
Static_Predicate function if the type is non-static (in the
presence of previous errors),
* sem_ch5.adb (Analyze_Loop_Parameter_Specification): Set flag
No_Dynamic_Predicate_On_Actual in a generic context, to enforce
generic contract on actuals that cannot have predicates.
From-SVN: r213418
-rw-r--r-- | gcc/ada/ChangeLog | 25 | ||||
-rw-r--r-- | gcc/ada/einfo.adb | 33 | ||||
-rw-r--r-- | gcc/ada/einfo.ads | 22 | ||||
-rw-r--r-- | gcc/ada/sem_ch12.adb | 36 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 11 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 23 | ||||
-rw-r--r-- | gcc/ada/sem_ch5.adb | 3 | ||||
-rw-r--r-- | gcc/ada/sem_util.adb | 51 |
8 files changed, 189 insertions, 15 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 844cdd9..1c81d98 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2014-08-01 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads, einfo.adb New flags No_Predicate_On_Actual and + No_Dynamic_Predicate_On_Actual, to enforce the generic contract + on generic units that contain constructs that forbid subtypes + with predicates. + * sem_ch3.adb (Analyze_Subtype_Declaration, Process_Subtype): + Inherit flags indicating the presence of predicates in subtype + declarations with and without constraints. + (Inherit_Predicate_Flags): Utility for the above. + * sem_util.adb (Bad_Predicated_Subtype_Use): In a generic context, + indicate that the actual cannot have predicates, and preserve + warning. In an instance, report error if actual has predicates + and the construct appears in a package declaration. + * sem_ch12.adb (Diagnose_Predicated_Actual): Report error + for an actual with predicates, if the corresponding formal + carries No_Predicate_On_Actual or (in the case of a loop) + No_Dynamic_Predicate_On_Actual. + * sem_ch13.adb (Build_Predicate_Functions); Do not build a + Static_Predicate function if the type is non-static (in the + presence of previous errors), + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Set flag + No_Dynamic_Predicate_On_Actual in a generic context, to enforce + generic contract on actuals that cannot have predicates. + 2014-08-01 Pascal Obry <obry@adacore.com> * a-direct.adb (C_Size): Returns an int64. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 92fdff6..0c229a7 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -567,15 +567,12 @@ package body Einfo is -- (SSO_Set_Low_By_Default) Flag273 -- Is_Generic_Actual_Subprogram Flag274 + -- No_Predicate_On_Actual Flag275 + -- No_Dynamic_Predicate_On_Actual Flag276 -- (unused) Flag2 -- (unused) Flag3 - -- (unused) Flag132 - -- (unused) Flag133 - - -- (unused) Flag275 - -- (unused) Flag276 -- (unused) Flag277 -- (unused) Flag278 -- (unused) Flag279 @@ -2557,12 +2554,24 @@ package body Einfo is return Node12 (Id); end Next_Inlined_Subprogram; + function No_Dynamic_Predicate_On_Actual (Id : E) return Boolean is + begin + pragma Assert (Is_Discrete_Type (Id)); + return Flag276 (Id); + end No_Dynamic_Predicate_On_Actual; + function No_Pool_Assigned (Id : E) return B is begin pragma Assert (Is_Access_Type (Id)); return Flag131 (Root_Type (Id)); end No_Pool_Assigned; + function No_Predicate_On_Actual (Id : E) return Boolean is + begin + pragma Assert (Is_Discrete_Type (Id)); + return Flag275 (Id); + end No_Predicate_On_Actual; + function No_Return (Id : E) return B is begin return Flag113 (Id); @@ -5344,12 +5353,24 @@ package body Einfo is Set_Node12 (Id, V); end Set_Next_Inlined_Subprogram; + procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True) is + begin + pragma Assert (Is_Discrete_Type (Id)); + Set_Flag276 (Id, V); + end Set_No_Dynamic_Predicate_On_Actual; + procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; + procedure Set_No_Predicate_On_Actual (Id : E; V : B := True) is + begin + pragma Assert (Is_Discrete_Type (Id)); + Set_Flag275 (Id, V); + end Set_No_Predicate_On_Actual; + procedure Set_No_Return (Id : E; V : B := True) is begin pragma Assert @@ -8435,7 +8456,9 @@ package body Einfo is W ("Needs_Debug_Info", Flag147 (Id)); W ("Needs_No_Actuals", Flag22 (Id)); W ("Never_Set_In_Source", Flag115 (Id)); + W ("No_Dynamic_Predicate_On_actual", Flag276 (Id)); W ("No_Pool_Assigned", Flag131 (Id)); + W ("No_Predicate_On_actual", Flag275 (Id)); W ("No_Return", Flag113 (Id)); W ("No_Strict_Aliasing", Flag136 (Id)); W ("Non_Binary_Modulus", Flag58 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7bb4d9c..c8dd25b 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3347,6 +3347,10 @@ package Einfo is -- interpreted as true. Currently this is set for derived Boolean -- types which have a convention of C, C++ or Fortran. +-- No_Dynamic_Predicate_On_Actual (Flag276) +-- Defined on generic formal types that are used in loops and quantified +-- expressions. The corresponing actual cannot have dynamic predicates. + -- No_Pool_Assigned (Flag131) [root type only] -- Defined in access types. Set if a storage size clause applies to the -- variable with a static expression value of zero. This flag is used to @@ -3354,6 +3358,10 @@ package Einfo is -- of such an access type. This is set only in the root type, since -- derived types must have the same pool. +-- No_Predicate_On_Actual (Flag275) +-- Defined on generic formal types that are used in the spec of a generic +-- package, in constructs that forbid discrete types with predicates. + -- No_Return (Flag113) -- Defined in all entities. Always false except in the case of procedures -- and generic procedures for which a pragma No_Return is given. @@ -5566,6 +5574,8 @@ package Einfo is -- Has_Enumeration_Rep_Clause (Flag66) -- Has_Pragma_Ordered (Flag198) (base type only) -- Nonzero_Is_True (Flag162) (base type only) + -- No_Predicate_On_Actual (Flag275) + -- No_Dynamic_Predicate_On_Actual (Flag276) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -5780,6 +5790,8 @@ package Einfo is -- Non_Binary_Modulus (Flag58) (base type only) -- Has_Biased_Representation (Flag139) -- Has_Shift_Operator (Flag267) (base type only) + -- No_Predicate_On_Actual (Flag275) + -- No_Dynamic_Predicate_On_Actual (Flag276) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -6082,6 +6094,8 @@ package Einfo is -- Static_Discrete_Predicate (List25) -- Has_Biased_Representation (Flag139) -- Has_Shift_Operator (Flag267) (base type only) + -- No_Predicate_On_Actual (Flag275) + -- No_Dynamic_Predicate_On_Actual (Flag276) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -6751,7 +6765,9 @@ package Einfo is function Needs_No_Actuals (Id : E) return B; function Never_Set_In_Source (Id : E) return B; function Next_Inlined_Subprogram (Id : E) return E; + function No_Dynamic_Predicate_On_Actual (Id : E) return B; function No_Pool_Assigned (Id : E) return B; + function No_Predicate_On_Actual (Id : E) return B; function No_Return (Id : E) return B; function No_Strict_Aliasing (Id : E) return B; function Non_Binary_Modulus (Id : E) return B; @@ -7389,7 +7405,9 @@ package Einfo is procedure Set_Needs_No_Actuals (Id : E; V : B := True); procedure Set_Never_Set_In_Source (Id : E; V : B := True); procedure Set_Next_Inlined_Subprogram (Id : E; V : E); + procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True); procedure Set_No_Pool_Assigned (Id : E; V : B := True); + procedure Set_No_Predicate_On_Actual (Id : E; V : B := True); procedure Set_No_Return (Id : E; V : B := True); procedure Set_No_Strict_Aliasing (Id : E; V : B := True); procedure Set_Non_Binary_Modulus (Id : E; V : B := True); @@ -8175,7 +8193,9 @@ package Einfo is pragma Inline (Next_Index); pragma Inline (Next_Inlined_Subprogram); pragma Inline (Next_Literal); + pragma Inline (No_Dynamic_Predicate_On_Actual); pragma Inline (No_Pool_Assigned); + pragma Inline (No_Predicate_On_Actual); pragma Inline (No_Return); pragma Inline (No_Strict_Aliasing); pragma Inline (Non_Binary_Modulus); @@ -8612,7 +8632,9 @@ package Einfo is pragma Inline (Set_Needs_No_Actuals); pragma Inline (Set_Never_Set_In_Source); pragma Inline (Set_Next_Inlined_Subprogram); + pragma Inline (Set_No_Dynamic_Predicate_On_Actual); pragma Inline (Set_No_Pool_Assigned); + pragma Inline (Set_No_Predicate_On_Actual); pragma Inline (Set_No_Return); pragma Inline (Set_No_Strict_Aliasing); pragma Inline (Set_Non_Binary_Modulus); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 679518c..db449d8 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -10810,6 +10810,13 @@ package body Sem_Ch12 is Loc : Source_Ptr; Subt : Entity_Id; + procedure Diagnose_Predicated_Actual; + -- There are a number of constructs in which a discrete type with + -- predicates is illegal, e.g. as an index in an array type declaration. + -- If a generic type is used is such a construct in a generic package + -- declaration, it carries the flag No_Predicate_On_Actual. it is part + -- of the generic contract that the actual cannot have predicates. + procedure Validate_Array_Type_Instance; procedure Validate_Access_Subprogram_Instance; procedure Validate_Access_Type_Instance; @@ -10827,6 +10834,29 @@ package body Sem_Ch12 is -- Check that base types are the same and that the subtypes match -- statically. Used in several of the above. + --------------------------------- + -- Diagnose_Predicated_Actual -- + --------------------------------- + + procedure Diagnose_Predicated_Actual is + begin + if No_Predicate_On_Actual (A_Gen_T) + and then Has_Predicates (Act_T) + then + Error_Msg_NE + ("actual for& cannot be a type with predicate", + Instantiation_Node, A_Gen_T); + + elsif No_Dynamic_Predicate_On_Actual (A_Gen_T) + and then Has_Predicates (Act_T) + and then not Has_Static_Predicate_Aspect (Act_T) + then + Error_Msg_NE + ("actual for& cannot be a type with a dynamic predicate", + Instantiation_Node, A_Gen_T); + end if; + end Diagnose_Predicated_Actual; + -------------------- -- Subtypes_Match -- -------------------- @@ -11995,6 +12025,8 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; + Diagnose_Predicated_Actual; + when N_Formal_Signed_Integer_Type_Definition => if not Is_Signed_Integer_Type (Act_T) then Error_Msg_NE @@ -12003,6 +12035,8 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; + Diagnose_Predicated_Actual; + when N_Formal_Modular_Type_Definition => if not Is_Modular_Integer_Type (Act_T) then Error_Msg_NE @@ -12011,6 +12045,8 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; + Diagnose_Predicated_Actual; + when N_Formal_Floating_Point_Definition => if not Is_Floating_Point_Type (Act_T) then Error_Msg_NE diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index bf720be..cc03f92 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8255,6 +8255,15 @@ package body Sem_Ch13 is -- For discrete subtype, build the static predicate list if Is_Discrete_Type (Typ) then + if not Is_Static_Subtype (Typ) then + + -- This can only happen in the presence of previous + -- semantic errors. + + pragma Assert (Serious_Errors_Detected > 0); + return; + end if; + Build_Discrete_Static_Predicate (Typ, Expr, Object_Name); -- If we don't get a static predicate list, it means that we @@ -10123,7 +10132,7 @@ package body Sem_Ch13 is end if; -- For a record type, deal with variant parts. This has to be delayed - -- to this point, because of the issue of statically precicated + -- to this point, because of the issue of statically predicated -- subtypes, which we have to ensure are frozen before checking -- choices, since we need to have the static choice list set. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a2634ac..9e8969f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -586,6 +586,10 @@ package body Sem_Ch3 is -- copying the record declaration for the derived base. In the tagged case -- the value returned is irrelevant. + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id); + -- Propagate static and dynamic predicate flags from a parent to the + -- subtype in a subtype declaration with and without constraints. + function Is_Valid_Constraint_Kind (T_Kind : Type_Kind; Constraint_Kind : Node_Kind) return Boolean; @@ -4514,14 +4518,13 @@ package body Sem_Ch3 is when Enumeration_Kind => Set_Ekind (Id, E_Enumeration_Subtype); - Set_Has_Dynamic_Predicate_Aspect - (Id, Has_Dynamic_Predicate_Aspect (T)); Set_First_Literal (Id, First_Literal (Base_Type (T))); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Is_Character_Type (Id, Is_Character_Type (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); + Inherit_Predicate_Flags (Id, T); when Ordinary_Fixed_Point_Kind => Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); @@ -4544,6 +4547,7 @@ package body Sem_Ch3 is Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); + Inherit_Predicate_Flags (Id, T); when Modular_Integer_Kind => Set_Ekind (Id, E_Modular_Integer_Subtype); @@ -4551,6 +4555,7 @@ package body Sem_Ch3 is Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); + Inherit_Predicate_Flags (Id, T); when Class_Wide_Kind => Set_Ekind (Id, E_Class_Wide_Subtype); @@ -16793,6 +16798,18 @@ package body Sem_Ch3 is return Assoc_List; end Inherit_Components; + ----------------------------- + -- Inherit_Predicate_Flags -- + ----------------------------- + + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is + begin + Set_Has_Static_Predicate_Aspect (Subt, + Has_Static_Predicate_Aspect (Par)); + Set_Has_Dynamic_Predicate_Aspect (Subt, + Has_Dynamic_Predicate_Aspect (Par)); + end Inherit_Predicate_Flags; + ----------------------- -- Is_Null_Extension -- ----------------------- @@ -19653,6 +19670,7 @@ package body Sem_Ch3 is when Enumeration_Kind => Constrain_Enumeration (Def_Id, S); + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); when Ordinary_Fixed_Point_Kind => Constrain_Ordinary_Fixed (Def_Id, S); @@ -19662,6 +19680,7 @@ package body Sem_Ch3 is when Integer_Kind => Constrain_Integer (Def_Id, S); + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); when E_Record_Type | E_Record_Subtype | diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 9106aa2..56db2bc 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2509,6 +2509,9 @@ package body Sem_Ch5 is Bad_Predicated_Subtype_Use ("cannot use subtype& with non-static predicate for loop " & "iteration", DS, Entity (DS), Suggest_Static => True); + + elsif Inside_A_Generic and then Is_Generic_Formal (Entity (DS)) then + Set_No_Dynamic_Predicate_On_Actual (Entity (DS)); end if; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 204ae5f..237cc86 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -781,15 +781,52 @@ package body Sem_Util is Typ : Entity_Id; Suggest_Static : Boolean := False) is + Gen : Entity_Id; begin - if Has_Predicates (Typ) then + if Inside_A_Generic then + Gen := Current_Scope; + while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop + Gen := Scope (Gen); + end loop; + + if No (Gen) then + return; + end if; + + if Is_Generic_Formal (Typ) then + Set_No_Predicate_On_Actual (Typ); + end if; + + elsif Has_Predicates (Typ) then if Is_Generic_Actual_Type (Typ) then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_FE (Msg & "<<", N, Typ); - Error_Msg_F ("\Program_Error [<<", N); - Insert_Action (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Bad_Predicated_Generic_Type)); + + -- The restriction on loop parameters is only that the type + -- should have no dynamic predicates. + + if Nkind (Parent (N)) = N_Loop_Parameter_Specification + and then not Has_Dynamic_Predicate_Aspect (Typ) + and then Is_Static_Subtype (Typ) + then + return; + end if; + + Gen := Current_Scope; + while not Is_Generic_Instance (Gen) loop + Gen := Scope (Gen); + end loop; + + pragma Assert (Present (Gen)); + + if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_FE (Msg & "<<", N, Typ); + Error_Msg_F ("\Program_Error [<<", N); + Insert_Action (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Bad_Predicated_Generic_Type)); + else + Error_Msg_FE (Msg & "<<", N, Typ); + end if; else Error_Msg_FE (Msg, N, Typ); |