This patch implements a new restriction No_Dynamic_Sized_Objects, which is
intended to prevent the creation of composite objects of non-static size.
The following test should get an error.
gcc -c dynamic_string.adb -gnatws
dynamic_string.adb:4:18: violation of restriction "No_Dynamic_Sized_Objects"
at line 1
pragma Restrictions (No_Dynamic_Sized_Objects);
procedure Dynamic_String is
Dynamic : Integer := 123;
X : String (1 .. Dynamic); -- ERROR:
begin
null;
end Dynamic_String;
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-10-26 Bob Duff <d...@adacore.com>
* s-rident.ads (No_Dynamic_Sized_Objects): New restriction name.
* sem_util.ads, sem_util.adb (All_Composite_Constraints_Static):
New function to check that all relevant constraints are static.
* sem_aggr.adb (Resolve_Array_Aggregate): Call
All_Composite_Constraints_Static on the bounds of named array
aggregates.
* sem_ch3.adb (Analyze_Subtype_Declaration): Call
All_Composite_Constraints_Static if the type is composite and
the subtype is constrained.
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 229331)
+++ sem_aggr.adb (working copy)
@@ -42,6 +42,7 @@
with Nlists; use Nlists;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
@@ -1967,6 +1968,14 @@
return Failure;
end if;
+ if not (All_Composite_Constraints_Static (Low)
+ and then All_Composite_Constraints_Static (High)
+ and then All_Composite_Constraints_Static (S_Low)
+ and then All_Composite_Constraints_Static (S_High))
+ then
+ Check_Restriction (No_Dynamic_Sized_Objects, Choice);
+ end if;
+
Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
Table (Nb_Discrete_Choices).Lo := Low;
Table (Nb_Discrete_Choices).Hi := High;
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 229333)
+++ sem_ch3.adb (working copy)
@@ -5227,6 +5227,31 @@
end if;
Analyze_Dimension (N);
+
+ -- Check No_Dynamic_Sized_Objects restriction, which disallows subtype
+ -- indications on composite types where the constraints are dynamic.
+ -- Note that object declarations and aggregates generate implicit
+ -- subtype declarations, which this covers. One special case is that the
+ -- implicitly generated "=" for discriminated types includes an
+ -- offending subtype declaration, which is harmless, so we ignore it
+ -- here.
+
+ if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
+ declare
+ Cstr : constant Node_Id := Constraint (Subtype_Indication (N));
+ begin
+ if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint
+ and then not (Is_Internal (Defining_Identifier (N))
+ and then Is_TSS (Scope (Defining_Identifier (N)),
+ TSS_Composite_Equality))
+ and then not Within_Init_Proc
+ then
+ if not All_Composite_Constraints_Static (Cstr) then
+ Check_Restriction (No_Dynamic_Sized_Objects, Cstr);
+ end if;
+ end if;
+ end;
+ end if;
end Analyze_Subtype_Declaration;
--------------------------------
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 229343)
+++ sem_util.adb (working copy)
@@ -434,6 +434,77 @@
return Alignment (E) * System_Storage_Unit;
end Alignment_In_Bits;
+ --------------------------------------
+ -- All_Composite_Constraints_Static --
+ --------------------------------------
+
+ function All_Composite_Constraints_Static
+ (Constr : Node_Id) return Boolean
+ is
+ begin
+ if No (Constr) or else Error_Posted (Constr) then
+ return True;
+ end if;
+
+ case Nkind (Constr) is
+ when N_Subexpr =>
+ if Nkind (Constr) in N_Has_Entity
+ and then Present (Entity (Constr))
+ then
+ if Is_Type (Entity (Constr)) then
+ return not Is_Discrete_Type (Entity (Constr))
+ or else Is_OK_Static_Subtype (Entity (Constr));
+ end if;
+
+ elsif Nkind (Constr) = N_Range then
+ return Is_OK_Static_Expression (Low_Bound (Constr))
+ and then Is_OK_Static_Expression (High_Bound (Constr));
+
+ elsif Nkind (Constr) = N_Attribute_Reference
+ and then Attribute_Name (Constr) = Name_Range
+ then
+ return Is_OK_Static_Expression
+ (Type_Low_Bound (Etype (Prefix (Constr))))
+ and then Is_OK_Static_Expression
+ (Type_High_Bound (Etype (Prefix (Constr))));
+ end if;
+
+ return not Present (Etype (Constr)) -- previous error
+ or else not Is_Discrete_Type (Etype (Constr))
+ or else Is_OK_Static_Expression (Constr);
+
+ when N_Discriminant_Association =>
+ return All_Composite_Constraints_Static (Expression (Constr));
+
+ when N_Range_Constraint =>
+ return All_Composite_Constraints_Static
+ (Range_Expression (Constr));
+
+ when N_Index_Or_Discriminant_Constraint =>
+ declare
+ One_Cstr : Entity_Id;
+ begin
+ One_Cstr := First (Constraints (Constr));
+ while Present (One_Cstr) loop
+ if not All_Composite_Constraints_Static (One_Cstr) then
+ return False;
+ end if;
+
+ Next (One_Cstr);
+ end loop;
+ end;
+
+ return True;
+
+ when N_Subtype_Indication =>
+ return All_Composite_Constraints_Static (Subtype_Mark (Constr))
+ and then All_Composite_Constraints_Static (Constraint (Constr));
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end All_Composite_Constraints_Static;
+
---------------------------------
-- Append_Inherited_Subprogram --
---------------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 229345)
+++ sem_util.ads (working copy)
@@ -85,6 +85,19 @@
-- Otherwise Uint_0 is returned, indicating that the alignment of the
-- entity is not yet known to the compiler.
+ function All_Composite_Constraints_Static (Constr : Node_Id) return Boolean;
+ -- Used to implement pragma Restrictions (No_Dynamic_Sized_Objects).
+ -- Given a constraint or subtree of a constraint on a composite
+ -- subtype/object, returns True if there are no nonstatic constraints,
+ -- which might cause objects to be created with dynamic size.
+ -- Called for subtype declarations (including implicit ones created for
+ -- subtype indications in object declarations, as well as discriminated
+ -- record aggregate cases). For record aggregates, only records containing
+ -- discriminant-dependent arrays matter, because the discriminants must be
+ -- static when governing a variant part. Access discriminants are
+ -- irrelevant. Also called for array aggregates, but only named notation,
+ -- because those are the only dynamic cases.
+
procedure Append_Inherited_Subprogram (S : Entity_Id);
-- If the parent of the operation is declared in the visible part of
-- the current scope, the inherited operation is visible even though the
Index: s-rident.ads
===================================================================
--- s-rident.ads (revision 229313)
+++ s-rident.ads (working copy)
@@ -171,6 +171,7 @@
-- units, it applies to all units in this extended main source.
Immediate_Reclamation, -- (RM H.4(10))
+ No_Dynamic_Sized_Objects, -- GNAT
No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241
No_Implementation_Attributes, -- Ada 2005 AI-257
No_Implementation_Identifiers, -- Ada 2012 AI-246
