OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_aux.ads, [...] (Is_Immutably_Limited_Type): Make predicate compatible with Ada 2012 definition

Browse Source 
2013-10-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_aux.ads, sem_aux.adb (Is_Immutably_Limited_Type): Make
	predicate compatible with Ada 2012 definition
	(Is_Limited_View): New name for previous version of
	Is_Immutably_Limited_Type.  Predicate is true for an untagged
	record type with a limited component.
	* exp_ch7.adb, exp_ch6.adb, exp_ch4.adb, exp_ch3.adb, exp_aggr.adb,
	sem_util.adb, sem_res.adb, sem_prag.adb, sem_attr.adb, sem_ch8.adb,
	sem_ch6.adb, sem_ch3.adb, exp_util.adb: Use Is_Limited_View
	* freeze.adb Use Is_Immutably_Limited_Type to check the legality
	of references to the current instance, Is_Limited_View otherwise.

From-SVN: r203762
This commit is contained in:
Ed Schonberg 2013-10-17 13:54:29 +00:00 committed by Arnaud Charlet
parent 9072f0698d
commit 51245e2db0
17 changed files with 151 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/ada/ChangeLog
View File

@ -1,3 +1,16 @@
2013-10-17 Ed Schonberg <schonberg@adacore.com>
* sem_aux.ads, sem_aux.adb (Is_Immutably_Limited_Type): Make
predicate compatible with Ada 2012 definition
(Is_Limited_View): New name for previous version of
Is_Immutably_Limited_Type. Predicate is true for an untagged
record type with a limited component.
* exp_ch7.adb, exp_ch6.adb, exp_ch4.adb, exp_ch3.adb, exp_aggr.adb,
sem_util.adb, sem_res.adb, sem_prag.adb, sem_attr.adb, sem_ch8.adb,
sem_ch6.adb, sem_ch3.adb, exp_util.adb: Use Is_Limited_View
* freeze.adb Use Is_Immutably_Limited_Type to check the legality
of references to the current instance, Is_Limited_View otherwise.
2013-10-17 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Flag aspect

6
gcc/ada/exp_aggr.adb
View File

@ -628,7 +628,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_Immutably_Limited_Type (Component_Type (Typ)) then
if Is_Limited_View (Component_Type (Typ)) then
return False;
end if;
@ -3347,7 +3347,7 @@ package body Exp_Aggr is
-- in place within the caller's scope).
or else
(Is_Immutably_Limited_Type (Typ)
(Is_Limited_View (Typ)
and then
(Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
or else Nkind (Parent_Node) = N_Simple_Return_Statement))
@ -5668,7 +5668,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_2005 and then Is_Immutably_Limited_Type (Typ) then
if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
if not Nkind_In (Parent (N), N_Object_Declaration,
N_Component_Association)
then

6
gcc/ada/exp_ch3.adb
View File

@ -1893,7 +1893,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_Immutably_Limited_Type (Typ)
and then not Is_Limited_View (Typ)
then
Append_To (Res,
Make_Adjust_Call
@ -5310,7 +5310,7 @@ package body Exp_Ch3 is
-- creating the object (via allocator) and initializing it.
if Is_Return_Object (Def_Id)
and then Is_Immutably_Limited_Type (Typ)
and then Is_Limited_View (Typ)
then
null;
@ -5578,7 +5578,7 @@ package body Exp_Ch3 is
-- renaming declaration.
if Needs_Finalization (Typ)
and then not Is_Immutably_Limited_Type (Typ)
and then not Is_Limited_View (Typ)
and then not Rewrite_As_Renaming
then
Insert_Action_After (Init_After,

2
gcc/ada/exp_ch4.adb
View File

@ -1244,7 +1244,7 @@ package body Exp_Ch4 is
-- want to Adjust.
if not Aggr_In_Place
and then not Is_Immutably_Limited_Type (T)
and then not Is_Limited_View (T)
then
Insert_Action (N,

12
gcc/ada/exp_ch6.adb
View File

@ -3947,7 +3947,7 @@ package body Exp_Ch6 is
-- result from the secondary stack.
if Needs_Finalization (Etype (Subp)) then
if not Is_Immutably_Limited_Type (Etype (Subp))
if not Is_Limited_View (Etype (Subp))
and then
(No (First_Formal (Subp))
or else
@ -7100,7 +7100,7 @@ package body Exp_Ch6 is
then
null;
elsif Is_Immutably_Limited_Type (Typ) then
elsif Is_Limited_View (Typ) then
Set_Returns_By_Ref (Spec_Id);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
@ -7702,7 +7702,7 @@ package body Exp_Ch6 is
-- the type of the expression may be.
if not Comes_From_Extended_Return_Statement (N)
and then Is_Immutably_Limited_Type (Etype (Expression (N)))
and then Is_Limited_View (Etype (Expression (N)))
and then Ada_Version >= Ada_2005
and then not Debug_Flag_Dot_L
@ -7781,7 +7781,7 @@ package body Exp_Ch6 is
-- type that requires special processing (indicated by the fact that
-- it requires a cleanup scope for the secondary stack case).
if Is_Immutably_Limited_Type (Exptyp)
if Is_Limited_View (Exptyp)
or else Is_Limited_Interface (Exptyp)
then
null;
@ -9572,7 +9572,7 @@ package body Exp_Ch6 is
-- may return objects of nonlimited descendants.
else
return Is_Immutably_Limited_Type (Etype (E))
return Is_Limited_View (Etype (E))
and then Ada_Version >= Ada_2005
and then not Debug_Flag_Dot_L;
end if;
@ -9813,7 +9813,7 @@ package body Exp_Ch6 is
Typ : constant Entity_Id := Etype (Subp);
Utyp : constant Entity_Id := Underlying_Type (Typ);
begin
if Is_Immutably_Limited_Type (Typ) then
if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Subp);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Subp);

4
gcc/ada/exp_ch7.adb
View File

@ -432,7 +432,7 @@ package body Exp_Ch7 is
Typ => Typ,
Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
if not Is_Immutably_Limited_Type (Typ) then
if not Is_Limited_View (Typ) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Adjust_Case,
@ -3227,7 +3227,7 @@ package body Exp_Ch7 is
Typ => Typ,
Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
if not Is_Immutably_Limited_Type (Typ) then
if not Is_Limited_View (Typ) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Adjust_Case,

4
gcc/ada/exp_util.adb
View File

@ -2227,7 +2227,7 @@ package body Exp_Util is
-- function being called is build-in-place. This will have to be revised
-- when build-in-place functions are generalized to other types.
elsif Is_Immutably_Limited_Type (Exp_Typ)
elsif Is_Limited_View (Exp_Typ)
and then
(Is_Class_Wide_Type (Exp_Typ)
or else Is_Interface (Exp_Typ)
@ -7081,7 +7081,7 @@ package body Exp_Util is
if Ada_Version >= Ada_2005
and then Nkind (Exp) = N_Function_Call
and then Is_Immutably_Limited_Type (Etype (Exp))
and then Is_Limited_View (Etype (Exp))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
then
declare

2
gcc/ada/freeze.adb
View File

@ -4786,7 +4786,7 @@ package body Freeze is
if Has_Private_Declaration (E) then
if (not Is_Record_Type (E)
or else not Is_Immutably_Limited_Type (E))
or else not Is_Limited_View (E))
and then not Is_Private_Type (E)
then
Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type;

4
gcc/ada/sem_attr.adb
View File

@ -3893,7 +3893,7 @@ package body Sem_Attr is
-- Loop_Entry must create a constant initialized by the evaluated
-- prefix.
if Is_Immutably_Limited_Type (Etype (P)) then
if Is_Limited_View (Etype (P)) then
Error_Attr_P ("prefix of attribute % cannot be limited");
end if;
@ -5994,7 +5994,7 @@ package body Sem_Attr is
then
Error_Attr_P ("prefix of attribute % must be a record or array");
elsif Is_Immutably_Limited_Type (P_Type) then
elsif Is_Limited_View (P_Type) then
Error_Attr ("prefix of attribute % cannot be limited", N);
elsif Nkind (E1) /= N_Aggregate then

141
gcc/ada/sem_aux.adb
View File

@ -813,6 +813,105 @@ package body Sem_Aux is
end if;
end Is_Generic_Formal;
---------------------
-- Is_Limited_View --
---------------------
function Is_Limited_View (Ent : Entity_Id) return Boolean is
Btype : constant Entity_Id := Available_View (Base_Type (Ent));
begin
if Is_Limited_Record (Btype) then
return True;
elsif Ekind (Btype) = E_Limited_Private_Type
and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
then
return not In_Package_Body (Scope ((Btype)));
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;
-- A descendant of a limited formal type is not immutably limited
-- in the generic body, or in the body of a generic child.
elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
return not In_Package_Body (Scope (Btype));
else
return False;
end if;
else
declare
Utyp : constant Entity_Id := Underlying_Type (Btype);
begin
if No (Utyp) then
return False;
else
return Is_Limited_View (Utyp);
end if;
end;
end if;
elsif Is_Concurrent_Type (Btype) then
return True;
elsif Is_Record_Type (Btype) then
-- Note that we return True for all limited interfaces, even though
-- (unsynchronized) limited interfaces can have descendants that are
-- nonlimited, because this is a predicate on the type itself, and
-- things like functions with limited interface results need to be
-- handled as build in place even though they might return objects
-- of a type that is not inherently limited.
if Is_Class_Wide_Type (Btype) then
return Is_Limited_View (Root_Type (Btype));
else
declare
C : Entity_Id;
begin
C := First_Component (Btype);
while Present (C) loop
-- Don't consider components with interface types (which can
-- only occur in the case of a _parent component anyway).
-- They don't have any components, plus it would cause this
-- function to return true for nonlimited types derived from
-- limited interfaces.
if not Is_Interface (Etype (C))
and then Is_Limited_View (Etype (C))
then
return True;
end if;
C := Next_Component (C);
end loop;
end;
return False;
end if;
elsif Is_Array_Type (Btype) then
return Is_Limited_View (Component_Type (Btype));
else
return False;
end if;
end Is_Limited_View;
-------------------------------
-- Is_Immutably_Limited_Type --
-------------------------------
@ -865,48 +964,6 @@ package body Sem_Aux is
elsif Is_Concurrent_Type (Btype) then
return True;
elsif Is_Record_Type (Btype) then
-- Note that we return True for all limited interfaces, even though
-- (unsynchronized) limited interfaces can have descendants that are
-- nonlimited, because this is a predicate on the type itself, and
-- things like functions with limited interface results need to be
-- handled as build in place even though they might return objects
-- of a type that is not inherently limited.
if Is_Class_Wide_Type (Btype) then
return Is_Immutably_Limited_Type (Root_Type (Btype));
else
declare
C : Entity_Id;
begin
C := First_Component (Btype);
while Present (C) loop
-- Don't consider components with interface types (which can
-- only occur in the case of a _parent component anyway).
-- They don't have any components, plus it would cause this
-- function to return true for nonlimited types derived from
-- limited interfaces.
if not Is_Interface (Etype (C))
and then Is_Immutably_Limited_Type (Etype (C))
then
return True;
end if;
C := Next_Component (C);
end loop;
end;
return False;
end if;
elsif Is_Array_Type (Btype) then
return Is_Immutably_Limited_Type (Component_Type (Btype));
else
return False;
end if;

9
gcc/ada/sem_aux.ads
View File

@ -281,6 +281,12 @@ package Sem_Aux is
-- so. False for other type entities, or any entities that are not types.
function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean;
-- Implements definition in Ada 2012 RM-7.5 (8.1/3). This differs from the
-- following predicate in that an untagged record with immutably limited
-- components is NOT by itself immutably limited. This matters, eg. when
-- checking the legality of an access to the current instance.
function Is_Limited_View (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".
@ -294,7 +300,8 @@ package Sem_Aux is
-- Ent is any entity. Returns true if Ent is a limited type (limited
-- private type, limited interface type, task type, protected type,
-- composite containing a limited component, or a subtype of any of
-- these types).
-- these types). This older routine overlaps with the previous one, this
-- should be cleaned up?
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
-- Given a subtype Typ, this function finds out the nearest ancestor from

2
gcc/ada/sem_ch3.adb
View File

@ -9556,7 +9556,7 @@ package body Sem_Ch3 is
-- or else be a partial view.
if Nkind (Discriminant_Type (D)) = N_Access_Definition then
if Is_Immutably_Limited_Type (Current_Scope)
if Is_Limited_View (Current_Scope)
or else
(Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration
and then Limited_Present (Parent (Current_Scope)))

10
gcc/ada/sem_ch6.adb
View File

@ -586,7 +586,7 @@ package body Sem_Ch6 is
("(Ada 2005) cannot copy object of a limited type " &
"(RM-2005 6.5(5.5/2))", Expr);
if Is_Immutably_Limited_Type (R_Type) then
if Is_Limited_View (R_Type) then
Error_Msg_N
("\return by reference not permitted in Ada 2005", Expr);
end if;
@ -606,7 +606,7 @@ package body Sem_Ch6 is
("return of limited object not permitted in Ada 2005 "
& "(RM-2005 6.5(5.5/2))?y?", Expr);
elsif Is_Immutably_Limited_Type (R_Type) then
elsif Is_Limited_View (R_Type) then
Error_Msg_N
("return by reference not permitted in Ada 2005 "
& "(RM-2005 6.5(5.5/2))?y?", Expr);
@ -880,7 +880,7 @@ package body Sem_Ch6 is
("aliased only allowed for limited"
& " return objects in Ada 2012?", N);
elsif not Is_Immutably_Limited_Type (R_Type) then
elsif not Is_Limited_View (R_Type) then
Error_Msg_N ("aliased only allowed for limited"
& " return objects", N);
end if;
@ -963,7 +963,7 @@ package body Sem_Ch6 is
-- check the static cases.
if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
and then Is_Immutably_Limited_Type (Etype (Scope_Id))
and then Is_Limited_View (Etype (Scope_Id))
and then Object_Access_Level (Expr) >
Subprogram_Access_Level (Scope_Id)
then
@ -6593,7 +6593,7 @@ package body Sem_Ch6 is
Typ : constant Entity_Id := Etype (Designator);
Utyp : constant Entity_Id := Underlying_Type (Typ);
begin
if Is_Immutably_Limited_Type (Typ) then
if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Designator);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Designator);

2
gcc/ada/sem_ch8.adb
View File

@ -883,7 +883,7 @@ package body Sem_Ch8 is
-- there is no copy involved and no performance hit.
if Nkind (Nam) = N_Function_Call
and then Is_Immutably_Limited_Type (Etype (Nam))
and then Is_Limited_View (Etype (Nam))
and then not Is_Constrained (Etype (Nam))
and then Comes_From_Source (N)
then

2
gcc/ada/sem_prag.adb
View File

@ -17678,7 +17678,7 @@ package body Sem_Prag is
-- in Freeze_Entity).
if Is_Record_Type (Typ)
and then not Is_Immutably_Limited_Type (Typ)
and then not Is_Limited_View (Typ)
then
Error_Pragma
("pragma% can only apply to explicitly limited record type");

4
gcc/ada/sem_res.adb
View File

@ -4356,7 +4356,7 @@ package body Sem_Res is
-- of the current b-i-p implementation to unify the handling for
-- multiple kinds of storage pools). ???
if Is_Immutably_Limited_Type (Desig_T)
if Is_Limited_View (Desig_T)
and then Nkind (Expression (E)) = N_Function_Call
then
declare
@ -4595,7 +4595,7 @@ package body Sem_Res is
if Ada_Version >= Ada_2012
and then Is_Limited_Type (Desig_T)
and then not Is_Immutably_Limited_Type (Scope (Discr))
and then not Is_Limited_View (Scope (Discr))
then
Error_Msg_N
("only immutably limited types can have anonymous "

2
gcc/ada/sem_util.adb
View File

@ -8145,7 +8145,7 @@ package body Sem_Util is
-- statement is aliased if its type is immutably limited.
or else (Is_Return_Object (E)
and then Is_Immutably_Limited_Type (Etype (E)));
and then Is_Limited_View (Etype (E)));
elsif Nkind (Obj) = N_Selected_Component then
return Is_Aliased (Entity (Selector_Name (Obj)));