Skip to content

R
riscv-gcc-1
Commit 5e5db3b4 by Gary Dismukes Committed by Arnaud Charlet
Options

sem_ch3.adb (Check_Or_Process_Discriminants): In Ada 2012, allow limited tagged… 

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
parent a043e735
Showing with 87 additions and 17 deletions
gcc/ada/ChangeLog
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
......
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;
......
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;
......
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"));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment