sem_ch3.adb (Check_Or_Process_Discriminants): In Ada 2012, allow limited tagged types to have defaulted discriminants.

2010-10-22  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch3.adb (Check_Or_Process_Discriminants): In Ada 2012, allow
	limited tagged types to have defaulted discriminants. Customize the
	error message for the Ada 2012 case.
	(Process_Discriminants): In Ada 2012, allow limited tagged types to have
	defaulted discriminants. Customize the error message for the Ada 2012
	case.
	* sem_ch6.adb (Create_Extra_Formals): Suppress creation of the extra
	formal for out formals of discriminated types in the case where the
	underlying type is a limited tagged type.
	* exp_attr.adb (Expand_N_Attribute_Reference, case
	Attribute_Constrained): Return True for 'Constrained when the
	underlying type of the prefix is a limited tagged type.

From-SVN: r165819

4 files changed, 87 insertions, 17 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index ca316fd..8028ecb 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2010-10-22  Gary Dismukes  <dismukes@adacore.com>
+
+	* sem_ch3.adb (Check_Or_Process_Discriminants): In Ada 2012, allow
+	limited tagged types to have defaulted discriminants. Customize the
+	error message for the Ada 2012 case.
+	(Process_Discriminants): In Ada 2012, allow limited tagged types to have
+	defaulted discriminants. Customize the error message for the Ada 2012
+	case.
+	* sem_ch6.adb (Create_Extra_Formals): Suppress creation of the extra
+	formal for out formals of discriminated types in the case where the
+	underlying type is a limited tagged type.
+	* exp_attr.adb (Expand_N_Attribute_Reference, case
+	Attribute_Constrained): Return True for 'Constrained when the
+	underlying type of the prefix is a limited tagged type.
+
 2010-10-22  Thomas Quinot  <quinot@adacore.com>
 
 	* sem_ch3.adb (Complete_Private_Subtype): The full view of the subtype
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 9b0d3b7..3f47a30 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -1644,17 +1644,30 @@ package body Exp_Attr is
                --  internally for passing to the Extra_Constrained parameter.
 
                else
-                  Res := Is_Constrained (Underlying_Type (Etype (Ent)));
+                  --  In Ada 2012, test for case of a limited tagged type, in
+                  --  which case the attribute is always required to return
+                  --  True. The underlying type is tested, to make sure we also
+                  --  return True for cases where there is an unconstrained
+                  --  object with an untagged limited partial view which has
+                  --  defaulted discriminants (such objects always produce a
+                  --  False in earlier versions of Ada). (Ada 2012: AI05-0214)
+
+                  Res := Is_Constrained (Underlying_Type (Etype (Ent)))
+                           or else
+                             (Ada_Version >= Ada_2012
+                               and then Is_Tagged_Type (Underlying_Type (Ptyp))
+                               and then Is_Limited_Type (Ptyp));
                end if;
 
-               Rewrite (N,
-                 New_Reference_To (Boolean_Literals (Res), Loc));
+               Rewrite (N, New_Reference_To (Boolean_Literals (Res), Loc));
             end;
 
          --  Prefix is not an entity name. These are also cases where we can
          --  always tell at compile time by looking at the form and type of the
          --  prefix. If an explicit dereference of an object with constrained
-         --  partial view, this is unconstrained (Ada 2005 AI-363).
+         --  partial view, this is unconstrained (Ada 2005: AI95-0363). If the
+         --  underlying type is a limited tagged type, then Constrained is
+         --  required to always return True (Ada 2012: AI05-0214).
 
          else
             Rewrite (N,
@@ -1663,9 +1676,12 @@ package body Exp_Attr is
                   not Is_Variable (Pref)
                     or else
                      (Nkind (Pref) = N_Explicit_Dereference
-                        and then
-                          not Has_Constrained_Partial_View (Base_Type (Ptyp)))
-                    or else Is_Constrained (Underlying_Type (Ptyp))),
+                       and then
+                         not 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))
+                              and then Is_Limited_Type (Ptyp))),
                 Loc));
          end if;
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 0c82011..5322387 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9639,16 +9639,28 @@ package body Sem_Ch3 is
 
                --  Handle the case where there is an untagged partial view and
                --  the full view is tagged: must disallow discriminants with
-               --  defaults. However suppress the error here if it was already
-               --  reported on the default expression of the partial view.
+               --  defaults, unless compiling for Ada 2012, which allows a
+               --  limited tagged type to have defaulted discriminants (see
+               --  AI05-0214). However, suppress the error here if it was
+               --  already reported on the default expression of the partial
+               --  view.
 
                if Is_Tagged_Type (T)
                     and then Present (Expression (Parent (D)))
+                    and then (not Is_Limited_Type (Current_Scope)
+                               or else Ada_Version < Ada_2012)
                     and then not Error_Posted (Expression (Parent (D)))
                then
-                  Error_Msg_N
-                    ("discriminants of tagged type cannot have defaults",
-                     Expression (New_D));
+                  if Ada_Version >= Ada_2012 then
+                     Error_Msg_N
+                       ("discriminants of nonlimited tagged type cannot have"
+                          & " defaults",
+                        Expression (New_D));
+                  else
+                     Error_Msg_N
+                       ("discriminants of tagged type cannot have defaults",
+                        Expression (New_D));
+                  end if;
                end if;
 
                --  Ada 2005 (AI-230): Access discriminant allowed in
@@ -16442,20 +16454,33 @@ package body Sem_Ch3 is
                  ("discriminant defaults not allowed for formal type",
                   Expression (Discr));
 
+            --  Flag an error for a tagged type with defaulted discriminants,
+            --  excluding limited tagged types when compiling for Ada 2012
+            --  (see AI05-0214).
+
             elsif Is_Tagged_Type (Current_Scope)
+              and then (not Is_Limited_Type (Current_Scope)
+                         or else Ada_Version < Ada_2012)
               and then Comes_From_Source (N)
             then
                --  Note: see similar test in Check_Or_Process_Discriminants, to
                --  handle the (illegal) case of the completion of an untagged
                --  view with discriminants with defaults by a tagged full view.
-               --  We skip the check if Discr does not come from source to
+               --  We skip the check if Discr does not come from source, to
                --  account for the case of an untagged derived type providing
-               --  defaults for a renamed discriminant from a private nontagged
+               --  defaults for a renamed discriminant from a private untagged
                --  ancestor with a tagged full view (ACATS B460006).
 
-               Error_Msg_N
-                 ("discriminants of tagged type cannot have defaults",
-                  Expression (Discr));
+               if Ada_Version >= Ada_2012 then
+                  Error_Msg_N
+                    ("discriminants of nonlimited tagged type cannot have"
+                       & " defaults",
+                     Expression (Discr));
+               else
+                  Error_Msg_N
+                    ("discriminants of tagged type cannot have defaults",
+                     Expression (Discr));
+               end if;
 
             else
                Default_Present := True;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 98cb237..a4d65d8 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -5697,9 +5697,23 @@ package body Sem_Ch6 is
                Formal_Type := Underlying_Type (Formal_Type);
             end if;
 
+            --  Suppress the extra formal if formal's subtype is constrained or
+            --  indefinite, or we're compiling for Ada 2012 and the underlying
+            --  type is tagged and limited. In Ada 2012, a limited tagged type
+            --  can have defaulted discriminants, but 'Constrained is required
+            --  to return True, so the formal is never needed (see AI05-0214).
+            --  Note that this ensures consistency of calling sequences for
+            --  dispatching operations when some types in a class have defaults
+            --  on discriminants and others do not (and requiring the extra
+            --  formal would introduce distributed overhead).
+
             if Has_Discriminants (Formal_Type)
               and then not Is_Constrained (Formal_Type)
               and then not Is_Indefinite_Subtype (Formal_Type)
+              and then (Ada_Version < Ada_2012
+                         or else
+                           not (Is_Tagged_Type (Underlying_Type (Formal_Type))
+                                 and then Is_Limited_Type (Formal_Type)))
             then
                Set_Extra_Constrained
                  (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O"));