Patchwork [Ada] Ada 2012: Derived types and partial views

login
register
mail settings
Submitter Arnaud Charlet
Date Dec. 2, 2011, 2:46 p.m.
Message ID <20111202144618.GA23298@adacore.com>
Download mbox | patch
Permalink /patch/128878/
State New
Headers show

Comments

Arnaud Charlet - Dec. 2, 2011, 2:46 p.m.
This patch incorporates the support for AI95-0041. For the purposes of the
rules for allowing allocated unconstrained objects, any ancestor that has
a constrained partial view causes the rules to apply.
        
In addition, in a generic body, 3.10.2(27.2/2) is checked assuming that any
untagged formal private or derived type has a constrained partial view.

The following test now compiles with an error:

procedure AI95_041  is
   subtype Index is Integer range 0 .. 255;
   Smaller_Index : constant Index := 10;
   Larger_Index  : constant Index := 20;

   generic
      type T1 (D : Index) is private;
   package G is
      type Ref is access all T1;
      Smaller : aliased T1 (Smaller_Index);
      Ptr_1   : Ref := Smaller'Access; -- Legal? (Yes.)
      Ptr     : Ref;
    end G;

    package body G is
    begin
       Ptr := Smaller'Access; -- Legal? (No.)
    end G;

begin
   null;
end;

Command: gcc -c -gnat05 ai95_041.adb
Output:
ai95_041.adb:17:15: object subtype must statically match designated subtype

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

2011-12-02  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Constrain_Access): Enable on Ada 2005 mode the
	static check of the rule of general access types whose designated
	type has discriminants.
	* sem_util.ads, sem_util.adb
	(Effectively_Has_Constrained_Partial_View): New subprogram.
	(In_Generic_Body): New subprogram.
	* einfo.ads (Has_Constrained_Partial_View): Adding documentation.
	* sem_prag.adb (Inside_Generic_Body): Removed. Replaced by new
	subprogram In_Generic_Body.
	* exp_attr.adb, checks.adb, sem_attr.adb, exp_ch4.adb,
	sem_ch4.adb: In addition, this patch replaces the occurrences of
	Has_Constrained_Partial_View by
	Effectively_Has_Constrained_Partial_View.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 181910)
+++ sem_ch3.adb	(working copy)
@@ -10674,8 +10674,7 @@ 
             return;
          end if;
 
-         if (Ekind (T) = E_General_Access_Type
-              or else Ada_Version >= Ada_2005)
+         if Ekind (T) = E_General_Access_Type
            and then Has_Private_Declaration (Desig_Type)
            and then In_Open_Scopes (Scope (Desig_Type))
            and then Has_Discriminants (Desig_Type)
@@ -10687,11 +10686,6 @@ 
             --  (Defect Report 8652/0008, Technical Corrigendum 1, checked
             --  by ACATS B371001).
 
-            --  Rule updated for Ada 2005: the private type is said to have
-            --  a constrained partial view, given that objects of the type
-            --  can be declared. Furthermore, the rule applies to all access
-            --  types, unlike the rule concerning default discriminants.
-
             declare
                Pack  : constant Node_Id :=
                          Unit_Declaration_Node (Scope (Desig_Type));
Index: exp_attr.adb
===================================================================
--- exp_attr.adb	(revision 181910)
+++ exp_attr.adb	(working copy)
@@ -1559,10 +1559,11 @@ 
                return Is_Aliased_View (Obj)
                         and then
                       (Is_Constrained (Etype (Obj))
-                         or else (Nkind (Obj) = N_Explicit_Dereference
-                                    and then
-                                      not Has_Constrained_Partial_View
-                                            (Base_Type (Etype (Obj)))));
+                         or else
+                           (Nkind (Obj) = N_Explicit_Dereference
+                              and then
+                                not Effectively_Has_Constrained_Partial_View
+                                      (Base_Type (Etype (Obj)))));
             end if;
          end Is_Constrained_Aliased_View;
 
@@ -1684,7 +1685,8 @@ 
                     or else
                      (Nkind (Pref) = N_Explicit_Dereference
                        and then
-                         not Has_Constrained_Partial_View (Base_Type (Ptyp)))
+                         not Effectively_Has_Constrained_Partial_View
+                               (Base_Type (Ptyp)))
                     or else Is_Constrained (Underlying_Type (Ptyp))
                     or else (Ada_Version >= Ada_2012
                               and then Is_Tagged_Type (Underlying_Type (Ptyp))
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 181910)
+++ einfo.ads	(working copy)
@@ -1420,6 +1420,8 @@ 
 --       type has no discriminants and the full view has discriminants with
 --       defaults. In Ada 2005 heap-allocated objects of such types are not
 --       constrained, and can change their discriminants with full assignment.
+--       Sem_Util.Effectively_Has_Constrained_Partial_View should be always
+--       used by callers, rather than reading this attribute directly.
 
 --    Has_Contiguous_Rep (Flag181)
 --       Present in enumeration types. True if the type as a representation
Index: checks.adb
===================================================================
--- checks.adb	(revision 181910)
+++ checks.adb	(working copy)
@@ -1240,7 +1240,7 @@ 
       --  partial view that is constrained.
 
       elsif Ada_Version >= Ada_2005
-        and then Has_Constrained_Partial_View (Base_Type (T_Typ))
+        and then Effectively_Has_Constrained_Partial_View (Base_Type (T_Typ))
       then
          return;
       end if;
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 181910)
+++ sem_prag.adb	(working copy)
@@ -1314,34 +1314,6 @@ 
                      Subtype_Indication (Component_Definition (Comp));
          Typ     : constant Entity_Id := Etype (Comp_Id);
 
-         function Inside_Generic_Body (Id : Entity_Id) return Boolean;
-         --  Determine whether entity Id appears inside a generic body.
-         --  Shouldn't this be in a more general place ???
-
-         -------------------------
-         -- Inside_Generic_Body --
-         -------------------------
-
-         function Inside_Generic_Body (Id : Entity_Id) return Boolean is
-            S : Entity_Id;
-
-         begin
-            S := Id;
-            while Present (S) and then S /= Standard_Standard loop
-               if Ekind (S) = E_Generic_Package
-                 and then In_Package_Body (S)
-               then
-                  return True;
-               end if;
-
-               S := Scope (S);
-            end loop;
-
-            return False;
-         end Inside_Generic_Body;
-
-      --  Start of processing for Check_Component
-
       begin
          --  Ada 2005 (AI-216): If a component subtype is subject to a per-
          --  object constraint, then the component type shall be an Unchecked_
@@ -1363,7 +1335,7 @@ 
          --  the formal part of the generic unit.
 
          elsif Ada_Version >= Ada_2012
-           and then Inside_Generic_Body (UU_Typ)
+           and then In_Generic_Body (UU_Typ)
            and then In_Variant_Part
            and then Is_Private_Type (Typ)
            and then Is_Generic_Type (Typ)
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 181910)
+++ sem_util.adb	(working copy)
@@ -3039,6 +3039,24 @@ 
       return Extra_Accessibility (Id);
    end Effective_Extra_Accessibility;
 
+   ----------------------------------------------
+   -- Effectively_Has_Constrained_Partial_View --
+   ----------------------------------------------
+
+   function Effectively_Has_Constrained_Partial_View
+     (Typ  : Entity_Id;
+      Scop : Entity_Id := Current_Scope) return Boolean is
+   begin
+      return Has_Constrained_Partial_View (Typ)
+        or else (In_Generic_Body (Scop)
+                   and then Is_Generic_Type (Base_Type (Typ))
+                   and then Is_Private_Type (Base_Type (Typ))
+                   and then not Is_Tagged_Type (Typ)
+                   and then not (Is_Array_Type (Typ)
+                                   and then not Is_Constrained (Typ))
+                   and then Has_Discriminants (Typ));
+   end Effectively_Has_Constrained_Partial_View;
+
    --------------------------
    -- Enclosing_CPP_Parent --
    --------------------------
@@ -6088,6 +6106,38 @@ 
       return False;
    end Implements_Interface;
 
+   ---------------------
+   -- In_Generic_Body --
+   ---------------------
+
+   function In_Generic_Body (Id : Entity_Id) return Boolean is
+      S : Entity_Id := Id;
+
+   begin
+      while Present (S) and then S /= Standard_Standard loop
+
+         --  Generic package body
+
+         if Ekind (S) = E_Generic_Package
+           and then In_Package_Body (S)
+         then
+            return True;
+
+         --  Generic subprogram body
+
+         elsif Is_Subprogram (S)
+           and then Nkind (Unit_Declaration_Node (S))
+                      = N_Generic_Subprogram_Declaration
+         then
+            return True;
+         end if;
+
+         S := Scope (S);
+      end loop;
+
+      return False;
+   end In_Generic_Body;
+
    -----------------
    -- In_Instance --
    -----------------
@@ -6945,7 +6995,7 @@ 
                   --  designated object is known to be constrained.
 
                   if Ekind (Prefix_Type) = E_Access_Type
-                    and then not Has_Constrained_Partial_View
+                    and then not Effectively_Has_Constrained_Partial_View
                                    (Designated_Type (Prefix_Type))
                   then
                      return False;
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 181910)
+++ sem_util.ads	(working copy)
@@ -368,6 +368,14 @@ 
    --  Same as Einfo.Extra_Accessibility except thtat object renames
    --  are looked through.
 
+   function Effectively_Has_Constrained_Partial_View
+     (Typ  : Entity_Id;
+      Scop : Entity_Id := Current_Scope) return Boolean;
+   --  Return True if Typ has attribute Has_Constrained_Partial_View set to
+   --  True; in addition, within a generic body, return True if a subtype is
+   --  a descendant of an untagged generic formal private or derived type, and
+   --  the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)).
+
    function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
    --  Returns the closest ancestor of Typ that is a CPP type.
 
@@ -717,6 +725,9 @@ 
       Exclude_Parents : Boolean := False) return Boolean;
    --  Returns true if the Typ_Ent implements interface Iface_Ent
 
+   function In_Generic_Body (Id : Entity_Id) return Boolean;
+   --  Determine whether entity Id appears inside a generic body
+
    function In_Instance return Boolean;
    --  Returns True if the current scope is within a generic instance
 
Index: sem_attr.adb
===================================================================
--- sem_attr.adb	(revision 181910)
+++ sem_attr.adb	(working copy)
@@ -8632,7 +8632,7 @@ 
                  and then
                    (Ada_Version < Ada_2005
                      or else
-                       not Has_Constrained_Partial_View
+                       not Effectively_Has_Constrained_Partial_View
                              (Designated_Type (Base_Type (Typ))))
                then
                   null;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 181910)
+++ exp_ch4.adb	(working copy)
@@ -3903,8 +3903,9 @@ 
                        and then Present (Discriminant_Default_Value
                                           (First_Discriminant (Typ)))
                        and then (Ada_Version < Ada_2005
-                                  or else
-                                    not Has_Constrained_Partial_View (Typ))
+                                  or else not
+                                    Effectively_Has_Constrained_Partial_View
+                                      (Typ))
                      then
                         Typ := Build_Default_Subtype (Typ, N);
                         Set_Expression (N, New_Reference_To (Typ, Loc));
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 181910)
+++ sem_ch4.adb	(working copy)
@@ -576,10 +576,10 @@ 
                --  and the allocated object is unconstrained.
 
                elsif Ada_Version >= Ada_2005
-                 and then Has_Constrained_Partial_View (Base_Typ)
+                 and then Effectively_Has_Constrained_Partial_View (Base_Typ)
                then
                   Error_Msg_N
-                    ("constraint no allowed when type " &
+                    ("constraint not allowed when type " &
                       "has a constrained partial view", Constraint (E));
                end if;