===================================================================
@@ -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,
===================================================================
@@ -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);
===================================================================
@@ -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);
===================================================================
@@ -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
===================================================================
@@ -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 --
===================================================================
@@ -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".
===================================================================
@@ -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 (
===================================================================
@@ -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);
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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;
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.