When restriction No_Implicit_Heap_Allocation is active, the compiler rejects
a protected type that includes private components of dynamic size, This patch
extends the corresponding warning to the declaration of discriminated objects.
Given the following gnat.adc file:
pragma profile (Ravenscar);
compiling p.adb must yield:
p.adb:13:04: warning: in instantiation at a-cbhama.ads:448
p.adb:13:04: warning: component "TC" of non-static size will violate
restriction No_Implicit_Heap_Allocation
p.adb:19:04: violation of restriction "no_implicit_heap_allocations"
p.adb:19:04: from profile "ravenscar" at gnat.adc:14
---
with Ada.Containers.Bounded_Hashed_Maps;
with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Hash;
-- package body Flight_Data.Hash with
-- SPARK_Mode
-- is
package body P is
subtype GUFI is String (1 .. 36); --key
subtype Flight_ID is Integer range 1 ..5000; --element
function eq (Left, Right : Flight_ID) return Boolean is (Left = Right);
package Flight_Maps is new Ada.Containers.Bounded_Hashed_Maps
(Key_Type => GUFI,
Element_Type => Flight_Id,
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=");
use Flight_Maps;
The_Hash_Table : Map (Capacity => 2000,
Modulus => Flight_Maps.Default_Modulus (2000));
procedure Go is
Cur : Cursor;
My_Gufi : GUFI := GUFI'(others => 'a');
begin
Include(The_Hash_Table, My_GUFI, 12);
Cur := Find(The_Hash_Table, My_GUFI);
Ada.Text_IO.Put_Line (Flight_ID'Image(Element(Cur)));
end Go;
end P;
---
with Ada.Containers.Formal_Hashed_Maps;
with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Hash;
package P is
procedure Go;
end P;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-05-02 Ed Schonberg <[email protected]>
* exp_ch9.adb (Discriminated_Size): Moved to sem_util.
* sem_util.ads, sem_util.adb (Discriminated_Size): Predicate moved
here from exp_ch9, to recognize objects whose creation requires
dynamic allocation, so that the proper warning can be emitted
when restriction No_Implicit_Heap_Allocation is in effect.
* sem_ch3.adb (Analyze_Object_Declaration): Use Discriminated_Size
to emit proper warning when an object that requires dynamic
allocation is declared.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 247468)
+++ sem_ch3.adb (working copy)
@@ -3133,6 +3133,9 @@
when N_Derived_Type_Definition =>
Derived_Type_Declaration (T, N, T /= Def_Id);
+ if Ekind (T) /= E_Void and then Has_Predicates (T) then -- ????
+ Set_Has_Predicates (Def_Id);
+ end if;
when N_Enumeration_Type_Definition =>
Enumeration_Type_Declaration (T, Def);
@@ -3588,6 +3591,11 @@
Prev_Entity : Entity_Id := Empty;
+ procedure Check_Dynamic_Object (Typ : Entity_Id);
+ -- A library-level object with non-static discriminant constraints may
+ -- require dynamic allocation. The declaration is illegal if the
+ -- profile includes the restriction No_Implicit_Heap_Allocations.
+
procedure Check_For_Null_Excluding_Components
(Obj_Typ : Entity_Id;
Obj_Decl : Node_Id);
@@ -3614,6 +3622,45 @@
-- Any other relevant delayed aspects on object declarations ???
+ procedure Check_Dynamic_Object (Typ : Entity_Id) is
+ Comp : Entity_Id;
+ Obj_Type : Entity_Id;
+
+ begin
+ Obj_Type := Typ;
+ if Is_Private_Type (Obj_Type)
+ and then Present (Full_View (Obj_Type))
+ then
+ Obj_Type := Full_View (Obj_Type);
+ end if;
+
+ if Known_Static_Esize (Obj_Type) then
+ return;
+ end if;
+
+ if Restriction_Active (No_Implicit_Heap_Allocations)
+ and then Expander_Active
+ and then Has_Discriminants (Obj_Type)
+ then
+ Comp := First_Component (Obj_Type);
+ while Present (Comp) loop
+ if Known_Static_Esize (Etype (Comp)) then
+ null;
+
+ elsif not Discriminated_Size (Comp)
+ and then Comes_From_Source (Comp)
+ then
+ Error_Msg_NE ("component& of non-static size will violate "
+ & "restriction No_Implicit_Heap_Allocation?", N, Comp);
+
+ elsif Is_Record_Type (Etype (Comp)) then
+ Check_Dynamic_Object (Etype (Comp));
+ end if;
+ Next_Component (Comp);
+ end loop;
+ end if;
+ end Check_Dynamic_Object;
+
-----------------------------------------
-- Check_For_Null_Excluding_Components --
-----------------------------------------
@@ -4068,6 +4115,10 @@
Object_Definition (N));
end if;
+ if Is_Library_Level_Entity (Id) then
+ Check_Dynamic_Object (T);
+ end if;
+
-- There are no aliased objects in SPARK
if Aliased_Present (N) then
@@ -15458,6 +15509,10 @@
and then Has_Non_Trivial_Precondition (Parent_Subp)
and then Present (Interfaces (Derived_Type))
then
+
+ -- Add useful attributes of subprogram before the freeze point,
+ -- in case freezing is delayed or there are previous errors.
+
Set_Is_Dispatching_Operation (New_Subp);
declare
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 247461)
+++ exp_ch9.adb (working copy)
@@ -8725,12 +8725,6 @@
-- to the internal body, for possible inlining later on. The source
-- operation is invisible to the back-end and is never actually called.
- function Discriminated_Size (Comp : Entity_Id) return Boolean;
- -- If a component size is not static then a warning will be emitted
- -- in Ravenscar or other restricted contexts. When a component is non-
- -- static because of a discriminant constraint we can specialize the
- -- warning by mentioning discriminants explicitly.
-
procedure Expand_Entry_Declaration (Decl : Node_Id);
-- Create the entry barrier and the procedure body for entry declaration
-- Decl. All generated subprograms are added to Entry_Bodies_Array.
@@ -8758,63 +8752,6 @@
end if;
end Check_Inlining;
- ------------------------
- -- Discriminated_Size --
- ------------------------
-
- function Discriminated_Size (Comp : Entity_Id) return Boolean is
- Typ : constant Entity_Id := Etype (Comp);
- Index : Node_Id;
-
- function Non_Static_Bound (Bound : Node_Id) return Boolean;
- -- Check whether the bound of an index is non-static and does denote
- -- a discriminant, in which case any protected object of the type
- -- will have a non-static size.
-
- ----------------------
- -- Non_Static_Bound --
- ----------------------
-
- function Non_Static_Bound (Bound : Node_Id) return Boolean is
- begin
- if Is_OK_Static_Expression (Bound) then
- return False;
-
- elsif Is_Entity_Name (Bound)
- and then Present (Discriminal_Link (Entity (Bound)))
- then
- return False;
-
- else
- return True;
- end if;
- end Non_Static_Bound;
-
- -- Start of processing for Discriminated_Size
-
- begin
- if not Is_Array_Type (Typ) then
- return False;
- end if;
-
- if Ekind (Typ) = E_Array_Subtype then
- Index := First_Index (Typ);
- while Present (Index) loop
- if Non_Static_Bound (Low_Bound (Index))
- or else Non_Static_Bound (High_Bound (Index))
- then
- return False;
- end if;
-
- Next_Index (Index);
- end loop;
-
- return True;
- end if;
-
- return False;
- end Discriminated_Size;
-
---------------------------
-- Static_Component_Size --
---------------------------
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 247461)
+++ sem_util.adb (working copy)
@@ -6312,6 +6312,70 @@
return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
end Dynamic_Accessibility_Level;
+ ------------------------
+ -- Discriminated_Size --
+ ------------------------
+
+ function Discriminated_Size (Comp : Entity_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (Comp);
+ Index : Node_Id;
+
+ function Non_Static_Bound (Bound : Node_Id) return Boolean;
+ -- Check whether the bound of an index is non-static and does denote
+ -- a discriminant, in which case any object of the type (protected
+ -- or otherwise) will have a non-static size.
+
+ ----------------------
+ -- Non_Static_Bound --
+ ----------------------
+
+ function Non_Static_Bound (Bound : Node_Id) return Boolean is
+ begin
+ if Is_OK_Static_Expression (Bound) then
+ return False;
+
+ -- If the bound is given by a discriminant it is non-static
+ -- (A static constraint replaces the reference with the value).
+ -- In an protected object the discriminant has been replaced by
+ -- the corresponding discriminal within the protected operation.
+
+ elsif Is_Entity_Name (Bound)
+ and then
+ (Ekind (Entity (Bound)) = E_Discriminant
+ or else Present (Discriminal_Link (Entity (Bound))))
+ then
+ return False;
+
+ else
+ return True;
+ end if;
+ end Non_Static_Bound;
+
+ -- Start of processing for Discriminated_Size
+
+ begin
+ if not Is_Array_Type (Typ) then
+ return False;
+ end if;
+
+ if Ekind (Typ) = E_Array_Subtype then
+ Index := First_Index (Typ);
+ while Present (Index) loop
+ if Non_Static_Bound (Low_Bound (Index))
+ or else Non_Static_Bound (High_Bound (Index))
+ then
+ return False;
+ end if;
+
+ Next_Index (Index);
+ end loop;
+
+ return True;
+ end if;
+
+ return False;
+ end Discriminated_Size;
+
-----------------------------------
-- Effective_Extra_Accessibility --
-----------------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 247461)
+++ sem_util.ads (working copy)
@@ -601,6 +601,14 @@
-- accessibility levels are tracked at runtime (access parameters and Ada
-- 2012 stand-alone objects).
+ function Discriminated_Size (Comp : Entity_Id) return Boolean;
+ -- If a component size is not static then a warning will be emitted
+ -- in Ravenscar or other restricted contexts. When a component is non-
+ -- static because of a discriminant constraint we can specialize the
+ -- warning by mentioning discriminants explicitly. This was created for
+ -- private components of protected objects, but is generally useful when
+ -- retriction (No_Implicit_Heap_Allocation) is active.
+
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
-- Same as Einfo.Extra_Accessibility except thtat object renames
-- are looked through.
