diff mbox

[Ada] Restriction No_Dynamic_Sized_Objects

Message ID 20151026120604.GA25102@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 26, 2015, 12:06 p.m. UTC
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  <duff@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.
diff mbox

Patch

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