+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.
-- (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
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);
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
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));
-- 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
-- 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.
-- 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)
-- 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)
-- 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)
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;
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);
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);
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);
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;
-- 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 --
--------------------
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
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
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
-- 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
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.
-- 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;
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);
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);
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);
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 --
-----------------------
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);
when Integer_Kind =>
Constrain_Integer (Def_Id, S);
+ Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
when E_Record_Type |
E_Record_Subtype |
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;
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);
projects / thirdparty / gcc.git / commitdiff
