===================================================================
@@ -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;
===================================================================
@@ -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;
===================================================================
@@ -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"));
This set of changes implements the AI05-0214, which allows limited tagged types to have defaulted discriminants. The Constrained attribute is still defined to return True for all objects of tagged types, even if the object is unconstrained due to defaulted discriminants. This means that the extra constrained formal is suppressed for parameters of such limited tagged types, which ensures a consistent calling sequence on dispatching operations (because some types might have defaulted discriminants while others do not). Also, we have to go to the underlying type to determine the value of Constrained, to cover cases of objects of untagged limited partial views, again ensuring consistency of calling sequences (such as for calls through values of access-to-subprogram types). The following test must compile and execute quietly when compiled with -gnat12. procedure AI05_214_Test is type Ltd_Tagged (B : Boolean := True) is tagged limited record null; end record; Local_LT : Ltd_Tagged; type Rec is limited record Comp_LT : Ltd_Tagged; end record; R : Rec; procedure Proc (Formal_LT : in out Ltd_Tagged) is begin if not Formal_LT'Constrained then raise Program_Error; end if; end Proc; package Pkg is type Ltd_Priv (B : Boolean := True) is limited private; type Pkg_Acc_Ltd_Priv is access procedure (L : in out Ltd_Priv); procedure Proc (L : in out Ltd_Priv); private type Ltd_Priv (B : Boolean := True) is tagged limited null record; end Pkg; package body Pkg is procedure Proc (L : in out Ltd_Priv) is begin if not L'Constrained then raise Program_Error; end if; end Proc; end Pkg; use Pkg; procedure Outside_Proc (L : in out Ltd_Priv) is begin if not L'Constrained then raise Program_Error; end if; end Outside_Proc; LP_Obj : Ltd_Priv; type Outside_Acc_Ltd_Priv is access procedure (L : in out Ltd_Priv); Acc_PALP : Pkg_Acc_Ltd_Priv; Acc_OALP : Outside_Acc_Ltd_Priv; begin if not Local_LT'Constrained then raise Program_Error; end if; if not R.Comp_LT'Constrained then raise Program_Error; end if; Proc (Local_LT); Proc (R.Comp_LT); if not LP_Obj'Constrained then raise Program_Error; end if; Proc (LP_Obj); Outside_Proc (LP_Obj); Acc_PALP := Proc'Access; Acc_PALP.all (LP_Obj); Acc_PALP := Outside_Proc'Access; Acc_PALP.all (LP_Obj); Acc_OALP := Proc'Access; Acc_OALP.all (LP_Obj); Acc_OALP := Outside_Proc'Access; Acc_OALP.all (LP_Obj); end AI05_214_Test; Tested on x86_64-pc-linux-gnu, committed on trunk 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.