mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-08 09:50:38 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-10-20  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb, prj-proc.adb, sem_ch4.adb, prj-env.adb, lib.ads,
	sem_ch13.adb: Minor reformatting.

2014-10-20  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Expand_N_Object_Declaration): Expand the
	declaration of a class-wide limited object containing an
	initializing expression into a renaming declaration.  Required to
	avoid passing such declaration to the backend and also to avoid
	generating an extra copy.

From-SVN: r216475
This commit is contained in:
Arnaud Charlet 2014-10-20 16:22:09 +02:00
parent 1725676d08
commit adc876a840
8 changed files with 72 additions and 35 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 @@
2014-10-20 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, prj-proc.adb, sem_ch4.adb, prj-env.adb, lib.ads,
sem_ch13.adb: Minor reformatting.
2014-10-20 Javier Miranda <miranda@adacore.com>
* exp_ch3.adb (Expand_N_Object_Declaration): Expand the
declaration of a class-wide limited object containing an
initializing expression into a renaming declaration. Required to
avoid passing such declaration to the backend and also to avoid
generating an extra copy.
2014-10-20 Eric Botcazou <ebotcazou@adacore.com>
* inline.adb (List_Inlining_Info): Minor tweaks.

23
gcc/ada/exp_ch3.adb
View File

@ -5875,6 +5875,29 @@ package body Exp_Ch3 is
Set_Expression (N, Empty);
return;
-- Handle initialization of limited tagged types
elsif Is_Tagged_Type (Typ)
and then Is_Class_Wide_Type (Typ)
and then Is_Limited_Record (Typ)
then
-- Given that the type is limited we cannot perform a copy. If
-- Expr_Q is the reference to a variable we mark the variable
-- as OK_To_Rename to expand this declaration into a renaming
-- declaration (see bellow).
if Is_Entity_Name (Expr_Q) then
Set_OK_To_Rename (Entity (Expr_Q));
-- If we cannot convert the expression into a renaming we must
-- consider it an internal error because the backend does not
-- have support to handle it.
else
pragma Assert (False);
raise Program_Error;
end if;
-- For discrete types, set the Is_Known_Valid flag if the
-- initializing value is known to be valid. Only do this for
-- source assignments, since otherwise we can end up turning

2
gcc/ada/lib.ads
View File

@ -750,6 +750,8 @@ private
pragma Inline (Unit_File_Name);
pragma Inline (Unit_Name);
-- The Units Table
type Unit_Record is record
Unit_File_Name : File_Name_Type;
Unit_Name : Unit_Name_Type;

6
gcc/ada/prj-env.adb
View File

@ -1425,10 +1425,8 @@ package body Prj.Env is
(Self : Project_Search_Path;
Name : String) return String_Access
is
function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
(Check_Filename => Is_Directory);
function Find_Rts_In_Path is
new Prj.Env.Find_Name_In_Path (Check_Filename => Is_Directory);
begin
return Find_Rts_In_Path (Self, Name);
end Get_Runtime_Path;

1
gcc/ada/prj-proc.adb
View File

@ -909,6 +909,7 @@ package body Prj.Proc is
elsif The_Variable.Default then
case The_Variable.Kind is
when Undefined =>
null;

4
gcc/ada/sem_ch13.adb
View File

@ -1677,7 +1677,7 @@ package body Sem_Ch13 is
then
Error_Msg_N
("indexing aspect can only apply to a tagged type",
Aspect);
Aspect);
goto Continue;
end if;
@ -2711,7 +2711,7 @@ package body Sem_Ch13 is
when Aspect_Default_Component_Value =>
if not (Is_Array_Type (E)
and then Is_Scalar_Type (Component_Type (E)))
and then Is_Scalar_Type (Component_Type (E)))
then
Error_Msg_N ("aspect Default_Component_Value can only "
& "apply to an array of scalar components", N);

50
gcc/ada/sem_ch3.adb
View File

@ -2237,8 +2237,7 @@ package body Sem_Ch3 is
Set_Null_Present (Spec, False);
Insert_Before_And_Analyze (Body_Decl,
Make_Subprogram_Declaration (Loc,
Specification => Spec));
Make_Subprogram_Declaration (Loc, Specification => Spec));
end Handle_Late_Controlled_Primitive;
--------------------------------
@ -3003,7 +3002,8 @@ package body Sem_Ch3 is
T := It.Typ;
elsif It.Typ = Universal_Real
or else It.Typ = Universal_Integer
or else
It.Typ = Universal_Integer
then
-- Choose universal interpretation over any other
@ -4883,8 +4883,8 @@ package body Sem_Ch3 is
and then
(Nkind (Parent (Generic_Parent_Type (N))) /=
N_Formal_Type_Declaration
or else Nkind
(Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) /=
or else Nkind (Formal_Type_Definition
(Parent (Generic_Parent_Type (N)))) /=
N_Formal_Private_Type_Definition)
then
if Is_Tagged_Type (Id) then
@ -5329,10 +5329,9 @@ package body Sem_Ch3 is
Set_Component_Size (Implicit_Base, Uint_0);
Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
Set_Has_Controlled_Component
(Implicit_Base, Has_Controlled_Component
(Element_Type)
or else Is_Controlled
(Element_Type));
(Implicit_Base,
Has_Controlled_Component (Element_Type)
or else Is_Controlled (Element_Type));
Set_Finalize_Storage_Only
(Implicit_Base, Finalize_Storage_Only
(Element_Type));
@ -6490,9 +6489,7 @@ package body Sem_Ch3 is
-- If we did not have a range constraint, then set the range from the
-- parent type. Otherwise, the Process_Subtype call has set the bounds.
if No_Constraint
or else not Has_Range_Constraint (Indic)
then
if No_Constraint or else not Has_Range_Constraint (Indic) then
Set_Scalar_Range (Derived_Type,
Make_Range (Loc,
Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)),
@ -7695,7 +7692,7 @@ package body Sem_Ch3 is
if not Has_Discriminants (Parent_Base)
or else
(Has_Unknown_Discriminants (Parent_Base)
and then Is_Private_Type (Parent_Base))
and then Is_Private_Type (Parent_Base))
then
Error_Msg_N
("invalid constraint: type has no discriminant",
@ -8636,8 +8633,7 @@ package body Sem_Ch3 is
-- Set SSO default for record or array type
if (Is_Array_Type (Derived_Type)
or else Is_Record_Type (Derived_Type))
if (Is_Array_Type (Derived_Type) or else Is_Record_Type (Derived_Type))
and then Is_Base_Type (Derived_Type)
then
Set_Default_SSO (Derived_Type);
@ -8818,7 +8814,8 @@ package body Sem_Ch3 is
-- and in family bounds.
if Is_Concurrent_Type (Current_Scope)
or else Is_Limited_Type (Current_Scope)
or else
Is_Limited_Type (Current_Scope)
then
CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
@ -11878,14 +11875,17 @@ package body Sem_Ch3 is
Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
For_Access => True);
elsif (Is_Task_Type (Desig_Type) or else Is_Protected_Type (Desig_Type))
elsif Is_Concurrent_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
then
Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
else
Error_Msg_N ("invalid constraint on access type", S);
Desig_Subtype := Desig_Type; -- Ignore invalid constraint
-- We simply ignore an invalid constraint
Desig_Subtype := Desig_Type;
Constraint_OK := False;
end if;
@ -15517,7 +15517,8 @@ package body Sem_Ch3 is
if Present (Discriminant_Specifications (N)) then
if (Is_Elementary_Type (Parent_Type)
or else Is_Array_Type (Parent_Type))
or else
Is_Array_Type (Parent_Type))
and then not Error_Posted (N)
then
Error_Msg_N
@ -20048,12 +20049,11 @@ package body Sem_Ch3 is
if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
and then
not (Ada_Version >= Ada_2005
and then
(Nkind (Parent (T)) = N_Subtype_Declaration
or else
(Nkind (Parent (T)) = N_Subtype_Indication
and then Nkind (Parent (Parent (T))) =
N_Subtype_Declaration)))
and then
(Nkind (Parent (T)) = N_Subtype_Declaration
or else (Nkind (Parent (T)) = N_Subtype_Indication
and then Nkind (Parent (Parent (T))) =
N_Subtype_Declaration)))
then
Error_Msg_N ("invalid use of type before its full declaration", T);
end if;

8
gcc/ada/sem_ch4.adb
View File

@ -2198,10 +2198,10 @@ package body Sem_Ch4 is
and then Is_Discrete_Type (Entity (Actual))
then
Replace (N,
Make_Slice (Loc,
Prefix => P,
Discrete_Range =>
New_Occurrence_Of (Entity (Actual), Loc)));
Make_Slice (Loc,
Prefix => P,
Discrete_Range =>
New_Occurrence_Of (Entity (Actual), Loc)));
Analyze (N);
return;