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

[multiple changes] 

2010-10-08  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Check_Duplicate_Pragma): Check for entity match
	* gcc-interface/Make-lang.in: Update dependencies.
	* einfo.ads: Minor reformatting.

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.

From-SVN: r165175
This commit is contained in:
Arnaud Charlet 2010-10-08 15:08:03 +02:00
parent af31bffbb0
commit 40f07b4b41
15 changed files with 136 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/ada/ChangeLog
View File

@ -1,3 +1,19 @@
2010-10-08 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (Check_Duplicate_Pragma): Check for entity match
* gcc-interface/Make-lang.in: Update dependencies.
* einfo.ads: Minor reformatting.
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.
2010-10-08 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (Check_Duplicate_Pragma): New procedure

4
gcc/ada/einfo.ads
View File

@ -2436,7 +2436,7 @@ package Einfo is
-- 4. Setting Component_Size of an array to a bit-packable value
-- 3. Indexing an array with a non-standard enumeration type.
--
-- For records, Is_Packed is always set if Has_Pack_Pragma is set,
-- For records, Is_Packed is always set if Has_Pragma_Pack is set,
-- and can also be set on its own in a derived type which inherited
-- its packed status.
--
@ -2455,7 +2455,7 @@ package Einfo is
-- the bit packed case once the array type is frozen.
--
-- Before an array type is frozen, Is_Packed will always be set if
-- Has_Pack_Pragma is set. Before the freeze point, it is not possible
-- Has_Pragma_Pack is set. Before the freeze point, it is not possible
-- to know the component size, since the component type is not frozen
-- until the array type is frozen. Thus Is_Packed for an array type
-- before it is frozen means that packed is required. Then if it turns

8
gcc/ada/exp_aggr.adb
View File

@ -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

27
gcc/ada/exp_ch3.adb
View File

@ -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;

2
gcc/ada/exp_ch4.adb
View File

@ -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 (

6
gcc/ada/exp_ch5.adb
View File

@ -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,

8
gcc/ada/exp_ch6.adb
View File

@ -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);

6
gcc/ada/exp_ch7.adb
View File

@ -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);

2
gcc/ada/exp_util.adb
View File

@ -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

27
gcc/ada/gcc-interface/Make-lang.in
View File

@ -1913,19 +1913,20 @@ ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \
ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \
ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \
ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \
ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch6.adb \
ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads \
ada/exp_dist.ads ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads \
ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads \
ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \
ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \
ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \
ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
ada/exp_aggr.ads ada/exp_atag.ads ada/exp_cg.ads ada/exp_ch11.ads \
ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads \
ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads \
ada/exp_disp.ads ada/exp_disp.adb ada/exp_dist.ads ada/exp_intr.ads \
ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \
ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \
ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \
ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \
ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \
ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \
ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch12.ads \
ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \
ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \

55
gcc/ada/sem_aux.adb
View File

@ -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 --

2
gcc/ada/sem_aux.ads
View File

@ -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".

7
gcc/ada/sem_ch3.adb
View File

@ -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);

8
gcc/ada/sem_ch6.adb
View File

@ -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

26
gcc/ada/sem_prag.adb
View File

@ -1199,14 +1199,30 @@ package body Sem_Prag is
end if;
end Check_Component;
----------------------------
-- Check_Duplicate_Pragma --
----------------------------
procedure Check_Duplicate_Pragma (E : Entity_Id) is
P : constant Node_Id := Get_Rep_Pragma (E, Pragma_Name (N));
P : constant Node_Id := Get_Rep_Pragma (E, Pragma_Name (N));
Arg : Node_Id;
begin
if Present (P) then
Error_Msg_Name_1 := Pname;
Error_Msg_Sloc := Sloc (P);
Error_Msg_NE ("pragma% for & duplicates one#", N, E);
raise Pragma_Exit;
-- Make sure pragma is for this entity, and not for some parent
-- entity in the case of a derived type.
Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (P)));
if Nkind (Arg) = N_Identifier
and then Entity (Arg) = E
then
Error_Msg_Name_1 := Pname;
Error_Msg_Sloc := Sloc (P);
Error_Msg_NE ("pragma% for & duplicates one#", N, E);
raise Pragma_Exit;
end if;
end if;
end Check_Duplicate_Pragma;