Patchwork [Ada] Detect array types which belong to ALFA subset

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 3, 2011, 10:45 a.m.
Message ID <20110803104537.GA13349@adacore.com>
Download mbox | patch
Permalink /patch/108107/
State New
Headers show

Comments

Arnaud Charlet - Aug. 3, 2011, 10:45 a.m.
Follow-up of previous changes to detect ALFA subset. Deals here with array
types, which should have static bounds and have index/component types in ALFA.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-03  Yannick Moy  <moy@adacore.com>

	* cstand.adb (Create_Standard): select Universal_Integer as an ALFA type
	* sem_ch3.adb (Array_Type_Declaration): detect array types in ALFA
	* sem_util.adb, sem_util.ads (Has_Static_Array_Bounds): new function to
	detect that an array has static bounds.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 177252)
+++ sem_ch3.adb	(working copy)
@@ -4639,6 +4639,7 @@ 
       Nb_Index      : Nat;
       P             : constant Node_Id := Parent (Def);
       Priv          : Entity_Id;
+      T_In_ALFA     : Boolean := True;
 
    begin
       if Nkind (Def) = N_Constrained_Array_Definition then
@@ -4665,6 +4666,12 @@ 
             Check_SPARK_Restriction ("subtype mark required", Index);
          end if;
 
+         if Present (Etype (Index))
+           and then not Is_In_ALFA (Etype (Index))
+         then
+            T_In_ALFA := False;
+         end if;
+
          --  Add a subtype declaration for each index of private array type
          --  declaration whose etype is also private. For example:
 
@@ -4740,10 +4747,18 @@ 
             Check_SPARK_Restriction ("subtype mark required", Component_Typ);
          end if;
 
+         if Present (Element_Type)
+           and then not Is_In_ALFA (Element_Type)
+         then
+            T_In_ALFA := False;
+         end if;
+
       --  Ada 2005 (AI-230): Access Definition case
 
       else pragma Assert (Present (Access_Definition (Component_Def)));
 
+         T_In_ALFA := False;
+
          --  Indicate that the anonymous access type is created by the
          --  array type declaration.
 
@@ -4820,6 +4835,12 @@ 
                                (Implicit_Base, Finalize_Storage_Only
                                                         (Element_Type));
 
+         --  Final check for static bounds on array
+
+         if not Has_Static_Array_Bounds (T) then
+            T_In_ALFA := False;
+         end if;
+
       --  Unconstrained array case
 
       else
@@ -4844,6 +4865,7 @@ 
 
       Set_Component_Type (Base_Type (T), Element_Type);
       Set_Packed_Array_Type (T, Empty);
+      Set_Is_In_ALFA (T, T_In_ALFA);
 
       if Aliased_Present (Component_Definition (Def)) then
          Check_SPARK_Restriction
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 177190)
+++ sem_util.adb	(working copy)
@@ -5550,6 +5550,69 @@ 
       end if;
    end Has_Private_Component;
 
+   -----------------------------
+   -- Has_Static_Array_Bounds --
+   -----------------------------
+
+   function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
+      Ndims : constant Nat := Number_Dimensions (Typ);
+
+      Index : Node_Id;
+      Low   : Node_Id;
+      High  : Node_Id;
+
+   begin
+      --  Unconstrained types do not have static bounds
+
+      if not Is_Constrained (Typ) then
+         return False;
+      end if;
+
+      --  First treat specially string literals, as the lower bound and length
+      --  of string literals are not stored like those of arrays.
+
+      --  A string literal always has static bounds
+
+      if Ekind (Typ) = E_String_Literal_Subtype then
+         return True;
+      end if;
+
+      --  Treat all dimensions in turn
+
+      Index := First_Index (Typ);
+      for Indx in 1 .. Ndims loop
+
+         --  In case of an erroneous index which is not a discrete type, return
+         --  that the type is not static.
+
+         if not Is_Discrete_Type (Etype (Index))
+           or else Etype (Index) = Any_Type
+         then
+            return False;
+         end if;
+
+         Get_Index_Bounds (Index, Low, High);
+
+         if Error_Posted (Low) or else Error_Posted (High) then
+            return False;
+         end if;
+
+         if         Is_OK_Static_Expression (Low)
+           and then Is_OK_Static_Expression (High)
+         then
+            null;
+         else
+            return False;
+         end if;
+
+         Next (Index);
+      end loop;
+
+      --  If we fall through the loop, all indexes matched
+
+      return True;
+   end Has_Static_Array_Bounds;
+
    ----------------
    -- Has_Stream --
    ----------------
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 177234)
+++ sem_util.ads	(working copy)
@@ -624,6 +624,9 @@ 
    --  Check if a type has a (sub)component of a private type that has not
    --  yet received a full declaration.
 
+   function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean;
+   --  Return whether an array type has static bounds
+
    function Has_Stream (T : Entity_Id) return Boolean;
    --  Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the
    --  case of a composite type, has a component for which this predicate is
Index: cstand.adb
===================================================================
--- cstand.adb	(revision 177174)
+++ cstand.adb	(working copy)
@@ -1334,6 +1334,7 @@ 
       Set_Scope (Universal_Integer, Standard_Standard);
       Build_Signed_Integer_Type
         (Universal_Integer, Standard_Long_Long_Integer_Size);
+      Set_Is_In_ALFA (Universal_Integer);
 
       Universal_Real := New_Standard_Entity;
       Decl := New_Node (N_Full_Type_Declaration, Stloc);