Patchwork [Ada] Immutably limited types

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 8, 2010, 1:08 p.m.
Message ID <20101008130820.GA30368@adacore.com>
Download mbox | patch
Permalink /patch/67194/
State New
Headers show

Comments

Arnaud Charlet - Oct. 8, 2010, 1:08 p.m.
In Ada2012, a type that is a descendant of a formal limited private type is not
immutably limited within a generic body. This affects the legality of access
discriminants on types that are descended from such a type.

The following must be rejected with the message :

    gen.adb:3:25: access discriminants allowed only for limited types

package Gen is
   pragma Elaborate_Body;
   type Disc is tagged null record;
   generic
       type FP (DD: access Disc) is limited private;   --  OK
   package Gen1 is
          type DFP (D: access Disc) is new FP(D);    --  OK
   end Gen1;
end Gen;
---
package body Gen is
   package body Gen1 is
          type DFP2 (D: access Disc) is new FP(D);    --  ERROR
   end Gen1;
end Gen;

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

2010-10-08  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb, sem_ch3.adb, exp_ch7.adb, exp_util.adb, sem_aux.adb,
	sem_aux.ads, exp_ch4.adb, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb,
	exp_ch3.adb: Change Is_Inherently_Limited_Type to
	Is_Immutably_Limited_Type to accord with new RM terminology.
	* sem_aux.adb (Is_Immutably_Limited_Type): A type that is a descendant
	of a formal limited private type is not immutably limited in a generic
	body.

Patch

Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb	(revision 165100)
+++ exp_ch5.adb	(working copy)
@@ -3896,7 +3896,7 @@  package body Exp_Ch5 is
       --  the type of the expression may be.
 
       if not Comes_From_Extended_Return_Statement (N)
-        and then Is_Inherently_Limited_Type (Etype (Expression (N)))
+        and then Is_Immutably_Limited_Type (Etype (Expression (N)))
         and then Ada_Version >= Ada_05
         and then not Debug_Flag_Dot_L
       then
@@ -3967,7 +3967,7 @@  package body Exp_Ch5 is
       --  type that requires special processing (indicated by the fact that
       --  it requires a cleanup scope for the secondary stack case).
 
-      if Is_Inherently_Limited_Type (Exptyp)
+      if Is_Immutably_Limited_Type (Exptyp)
         or else Is_Limited_Interface (Exptyp)
       then
          null;
@@ -4252,7 +4252,7 @@  package body Exp_Ch5 is
 
       elsif Ekind (R_Type) = E_Anonymous_Access_Type
         and then Has_Controlling_Result (Scope_Id)
-        and then Ada_Version >= Ada_12
+        and then (Ada_Version >= Ada_12 or else True)
       then
          Insert_Action (Exp,
            Make_Raise_Constraint_Error (Loc,
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165157)
+++ sem_ch3.adb	(working copy)
@@ -8794,12 +8794,11 @@  package body Sem_Ch3 is
       --  only in the declaration for a task or protected type, or for a type
       --  with the reserved word 'limited' in its definition or in one of its
       --  ancestors. (RM 3.7(10))
+      --  AI-0063 : the proper condition is that type must be immutably
+      --  limited.
 
       if Nkind (Discriminant_Type (D)) = N_Access_Definition
-        and then not Is_Concurrent_Type (Current_Scope)
-        and then not Is_Concurrent_Record_Type (Current_Scope)
-        and then not Is_Limited_Record (Current_Scope)
-        and then Ekind (Current_Scope) /= E_Limited_Private_Type
+        and then not Is_Immutably_Limited_Type (Current_Scope)
       then
          Error_Msg_N
            ("access discriminants allowed only for limited types", Loc);
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb	(revision 165080)
+++ exp_ch7.adb	(working copy)
@@ -392,7 +392,7 @@  package body Exp_Ch7 is
           Typ   => Typ,
           Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
 
-      if not Is_Inherently_Limited_Type (Typ) then
+      if not Is_Immutably_Limited_Type (Typ) then
          Set_TSS (Typ,
            Make_Deep_Proc (
              Prim  => Adjust_Case,
@@ -502,7 +502,7 @@  package body Exp_Ch7 is
           Typ   => Typ,
           Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
 
-      if not Is_Inherently_Limited_Type (Typ) then
+      if not Is_Immutably_Limited_Type (Typ) then
          Set_TSS (Typ,
            Make_Deep_Proc (
              Prim  => Adjust_Case,
@@ -2725,7 +2725,7 @@  package body Exp_Ch7 is
       Res            : constant List_Id := New_List;
 
    begin
-      if Is_Inherently_Limited_Type (Typ) then
+      if Is_Immutably_Limited_Type (Typ) then
          Controller_Typ := RTE (RE_Limited_Record_Controller);
       else
          Controller_Typ := RTE (RE_Record_Controller);
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 165103)
+++ exp_util.adb	(working copy)
@@ -5028,7 +5028,7 @@  package body Exp_Util is
          --  to accommodate functions returning limited objects by reference.
 
          if Nkind (Exp) = N_Function_Call
-           and then Is_Inherently_Limited_Type (Etype (Exp))
+           and then Is_Immutably_Limited_Type (Etype (Exp))
            and then Nkind (Parent (Exp)) /= N_Object_Declaration
            and then Ada_Version >= Ada_05
          then
Index: sem_aux.adb
===================================================================
--- sem_aux.adb	(revision 165080)
+++ sem_aux.adb	(working copy)
@@ -570,24 +570,49 @@  package body Sem_Aux is
       end if;
    end Is_Indefinite_Subtype;
 
-   --------------------------------
-   -- Is_Inherently_Limited_Type --
-   --------------------------------
+   -------------------------------
+   -- Is_Immutably_Limited_Type --
+   -------------------------------
 
-   function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is
+   function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
       Btype : constant Entity_Id := Base_Type (Ent);
 
    begin
-      if Is_Private_Type (Btype) then
-         declare
-            Utyp : constant Entity_Id := Underlying_Type (Btype);
-         begin
-            if No (Utyp) then
+      if Ekind (Btype) = E_Limited_Private_Type then
+         if Nkind (Parent (Btype)) = N_Formal_Type_Declaration then
+            return not In_Package_Body (Scope ((Btype)));
+         else
+            return True;
+         end if;
+
+      elsif Is_Private_Type (Btype) then
+         --  AI05-0063 : a type derived from a limited private formal type
+         --  is not immutably limited in a generic body.
+
+         if Is_Derived_Type (Btype)
+           and then Is_Generic_Type (Etype (Btype))
+         then
+            if not Is_Limited_Type (Etype (Btype)) then
                return False;
+
+            elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
+               return not In_Package_Body (Scope (Etype (Btype)));
+
             else
-               return Is_Inherently_Limited_Type (Utyp);
+               return False;
             end if;
-         end;
+
+         else
+            declare
+               Utyp : constant Entity_Id := Underlying_Type (Btype);
+            begin
+               if No (Utyp) then
+                  return False;
+               else
+                  return Is_Immutably_Limited_Type (Utyp);
+               end if;
+            end;
+         end if;
 
       elsif Is_Concurrent_Type (Btype) then
          return True;
@@ -605,7 +630,7 @@  package body Sem_Aux is
             return True;
 
          elsif Is_Class_Wide_Type (Btype) then
-            return Is_Inherently_Limited_Type (Root_Type (Btype));
+            return Is_Immutably_Limited_Type (Root_Type (Btype));
 
          else
             declare
@@ -622,7 +647,7 @@  package body Sem_Aux is
                   --  limited intefaces.
 
                   if not Is_Interface (Etype (C))
-                    and then Is_Inherently_Limited_Type (Etype (C))
+                    and then Is_Immutably_Limited_Type (Etype (C))
                   then
                      return True;
                   end if;
@@ -635,12 +660,12 @@  package body Sem_Aux is
          end if;
 
       elsif Is_Array_Type (Btype) then
-         return Is_Inherently_Limited_Type (Component_Type (Btype));
+         return Is_Immutably_Limited_Type (Component_Type (Btype));
 
       else
          return False;
       end if;
-   end Is_Inherently_Limited_Type;
+   end Is_Immutably_Limited_Type;
 
    ---------------------
    -- Is_Limited_Type --
Index: sem_aux.ads
===================================================================
--- sem_aux.ads	(revision 165080)
+++ sem_aux.ads	(working copy)
@@ -165,7 +165,7 @@  package Sem_Aux is
    --  discriminant values or a class wide type or subtype and returns True if
    --  so. False for other type entities, or any entities that are not types.
 
-   function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean;
+   function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean;
    --  Ent is any entity. True for a type that is "inherently" limited (i.e.
    --  cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with
    --  a part that is of a task, protected, or explicitly limited record type".
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 165158)
+++ exp_ch4.adb	(working copy)
@@ -947,7 +947,7 @@  package body Exp_Ch4 is
                --  want to Adjust.
 
                if not Aggr_In_Place
-                 and then not Is_Inherently_Limited_Type (T)
+                 and then not Is_Immutably_Limited_Type (T)
                then
                   Insert_Actions (N,
                     Make_Adjust_Call (
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb	(revision 165154)
+++ exp_ch6.adb	(working copy)
@@ -3106,7 +3106,7 @@  package body Exp_Ch6 is
       --  not a rewriting of a protected function call.
 
       if Needs_Finalization (Etype (Subp)) then
-         if not Is_Inherently_Limited_Type (Etype (Subp))
+         if not Is_Immutably_Limited_Type (Etype (Subp))
            and then
              (No (First_Formal (Subp))
                 or else
@@ -4405,7 +4405,7 @@  package body Exp_Ch6 is
          then
             null;
 
-         elsif Is_Inherently_Limited_Type (Typ) then
+         elsif Is_Immutably_Limited_Type (Typ) then
             Set_Returns_By_Ref (Spec_Id);
 
          elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
@@ -4810,7 +4810,7 @@  package body Exp_Ch6 is
          --  may return objects of nonlimited descendants.
 
          else
-            return Is_Inherently_Limited_Type (Etype (E))
+            return Is_Immutably_Limited_Type (Etype (E))
               and then Ada_Version >= Ada_05
               and then not Debug_Flag_Dot_L;
          end if;
@@ -5025,7 +5025,7 @@  package body Exp_Ch6 is
          Typ  : constant Entity_Id := Etype (Subp);
          Utyp : constant Entity_Id := Underlying_Type (Typ);
       begin
-         if Is_Inherently_Limited_Type (Typ) then
+         if Is_Immutably_Limited_Type (Typ) then
             Set_Returns_By_Ref (Subp);
          elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
             Set_Returns_By_Ref (Subp);
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 165162)
+++ sem_ch6.adb	(working copy)
@@ -483,7 +483,7 @@  package body Sem_Ch6 is
                Error_Msg_N
                  ("(Ada 2005) cannot copy object of a limited type " &
                   "(RM-2005 6.5(5.5/2))", Expr);
-               if Is_Inherently_Limited_Type (R_Type) then
+               if Is_Immutably_Limited_Type (R_Type) then
                   Error_Msg_N
                     ("\return by reference not permitted in Ada 2005", Expr);
                end if;
@@ -495,7 +495,7 @@  package body Sem_Ch6 is
             --  evilly turned off. Otherwise it is a real error.
 
             elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
-               if Is_Inherently_Limited_Type (R_Type) then
+               if Is_Immutably_Limited_Type (R_Type) then
                   Error_Msg_N
                     ("return by reference not permitted in Ada 2005 " &
                      "(RM-2005 6.5(5.5/2))?", Expr);
@@ -759,7 +759,7 @@  package body Sem_Ch6 is
          --  check the static cases.
 
          if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L)
-           and then Is_Inherently_Limited_Type (Etype (Scope_Id))
+           and then Is_Immutably_Limited_Type (Etype (Scope_Id))
            and then Object_Access_Level (Expr) >
                       Subprogram_Access_Level (Scope_Id)
          then
@@ -4256,7 +4256,7 @@  package body Sem_Ch6 is
             Utyp : constant Entity_Id := Underlying_Type (Typ);
 
          begin
-            if Is_Inherently_Limited_Type (Typ) then
+            if Is_Immutably_Limited_Type (Typ) then
                Set_Returns_By_Ref (Designator);
 
             elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb	(revision 165160)
+++ exp_aggr.adb	(working copy)
@@ -596,7 +596,7 @@  package body Exp_Aggr is
       --  If component is limited, aggregate must be expanded because each
       --  component assignment must be built in place.
 
-      if Is_Inherently_Limited_Type (Component_Type (Typ)) then
+      if Is_Immutably_Limited_Type (Component_Type (Typ)) then
          return False;
       end if;
 
@@ -2120,7 +2120,7 @@  package body Exp_Aggr is
          then
             RC := RE_Limited_Record_Controller;
 
-         elsif Is_Inherently_Limited_Type (Target_Type) then
+         elsif Is_Immutably_Limited_Type (Target_Type) then
             RC := RE_Limited_Record_Controller;
 
          else
@@ -3648,7 +3648,7 @@  package body Exp_Aggr is
          --  in place within the caller's scope).
 
          or else
-           (Is_Inherently_Limited_Type (Typ)
+           (Is_Immutably_Limited_Type (Typ)
              and then
                (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
                  or else Nkind (Parent_Node) = N_Simple_Return_Statement))
@@ -5598,7 +5598,7 @@  package body Exp_Aggr is
       --  Extension aggregates, aggregates in extended return statements, and
       --  aggregates for C++ imported types must be expanded.
 
-      if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then
+      if Ada_Version >= Ada_05 and then Is_Immutably_Limited_Type (Typ) then
          if not Nkind_In (Parent (N), N_Object_Declaration,
                                       N_Component_Association)
          then
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 165166)
+++ exp_ch3.adb	(working copy)
@@ -1661,7 +1661,7 @@  package body Exp_Ch3 is
            and then Has_New_Controlled_Component (Enclos_Type)
            and then Has_Controlled_Component (Typ)
          then
-            if Is_Inherently_Limited_Type (Typ) then
+            if Is_Immutably_Limited_Type (Typ) then
                Controller_Typ := RTE (RE_Limited_Record_Controller);
             else
                Controller_Typ := RTE (RE_Record_Controller);
@@ -1930,7 +1930,7 @@  package body Exp_Ch3 is
 
          if Needs_Finalization (Typ)
            and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
-           and then not Is_Inherently_Limited_Type (Typ)
+           and then not Is_Immutably_Limited_Type (Typ)
          then
             declare
                Ref : constant Node_Id :=
@@ -4800,7 +4800,7 @@  package body Exp_Ch3 is
             --  creating the object (via allocator) and initializing it.
 
             if Is_Return_Object (Def_Id)
-              and then Is_Inherently_Limited_Type (Typ)
+              and then Is_Immutably_Limited_Type (Typ)
             then
                null;
 
@@ -5014,7 +5014,7 @@  package body Exp_Ch3 is
             --  renaming declaration.
 
             if Needs_Finalization (Typ)
-              and then not Is_Inherently_Limited_Type (Typ)
+              and then not Is_Immutably_Limited_Type (Typ)
               and then not Rewrite_As_Renaming
             then
                Insert_Actions_After (Init_After,
@@ -5291,7 +5291,7 @@  package body Exp_Ch3 is
          Loc := Sloc (First (Component_Items (Comp_List)));
       end if;
 
-      if Is_Inherently_Limited_Type (T) then
+      if Is_Immutably_Limited_Type (T) then
          Controller_Type := RTE (RE_Limited_Record_Controller);
       else
          Controller_Type := RTE (RE_Record_Controller);
@@ -6099,7 +6099,11 @@  package body Exp_Ch3 is
             end if;
 
             Set_Is_Frozen (Def_Id);
-            Set_All_DT_Position (Def_Id);
+            if not Is_Derived_Type (Def_Id)
+              or else Is_Tagged_Type (Etype (Def_Id))
+            then
+               Set_All_DT_Position (Def_Id);
+            end if;
 
             --  Add the controlled component before the freezing actions
             --  referenced in those actions.
@@ -6194,9 +6198,16 @@  package body Exp_Ch3 is
             end if;
          end;
 
-      elsif Ada_Version >= Ada_12
-        and then Comes_From_Source (Def_Id)
+      --  Otherwise create primitive equality operation  (AI05-0123)
+      --  This is done unconditionally to ensure that tools can be linked
+      --  properly with user programs compiled with older language versions.
+      --  It might be worth including a switch to revert to a non-composable
+      --  equality for untagged records, even though no program depending on
+      --  non-composability has surfaced ???
+
+      elsif Comes_From_Source (Def_Id)
         and then Convention (Def_Id) = Convention_Ada
+        and then not Is_Limited_Type (Def_Id)
       then
          Build_Untagged_Equality (Def_Id);
       end if;