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

[multiple changes] 

2016-05-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb, exp_ch9.adb, einfo.adb, sem_ch4.adb, sem_ch6.adb: Minor
	reformatting.

2016-05-02  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb (Expand_N_Allocator): If the designated type
	is a private derived type with no discriminants, examine its
	underlying_full_view to determine whether the full view has
	defaulted discriminants, so their defaults can be used in the
	call to the initialization procedure for the designated object.

From-SVN: r235740
This commit is contained in:
Arnaud Charlet 2016-05-02 12:27:18 +02:00
parent 42f11e4c26
commit bac5ba153d
7 changed files with 123 additions and 90 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 @@
2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb, exp_ch9.adb, einfo.adb, sem_ch4.adb, sem_ch6.adb: Minor
reformatting.
2016-05-02 Ed Schonberg <schonberg@adacore.com>
* exp_ch4.adb (Expand_N_Allocator): If the designated type
is a private derived type with no discriminants, examine its
underlying_full_view to determine whether the full view has
defaulted discriminants, so their defaults can be used in the
call to the initialization procedure for the designated object.
2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_prag.adb, comperr.adb: Minor reformatting.

2
gcc/ada/einfo.adb
View File

@ -5908,7 +5908,7 @@ package body Einfo is
procedure Set_Original_Protected_Subprogram (Id : E; V : N) is
begin
pragma Assert (Ekind_In (Id, E_Procedure, E_Function));
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Node41 (Id, V);
end Set_Original_Protected_Subprogram;

25
gcc/ada/exp_ch4.adb
View File

@ -4503,12 +4503,25 @@ package body Exp_Ch4 is
Dis := True;
Typ := T;
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Dis := True;
Typ := Full_View (T);
-- Type may be a private type with no visible discriminants
-- in which case check full view if in scope, or the
-- underlying_full_view if dealing with a type whose full
-- view may be derived from a private type whose own full
-- view has discriminants.
elsif Is_Private_Type (T) then
if Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Dis := True;
Typ := Full_View (T);
elsif Present (Underlying_Full_View (T))
and then Has_Discriminants (Underlying_Full_View (T))
then
Dis := True;
Typ := Underlying_Full_View (T);
end if;
end if;
if Dis then

57
gcc/ada/exp_ch9.adb
View File

@ -2558,9 +2558,9 @@ package body Exp_Ch9 is
end if;
return
Type_Conformant_Parameters (
Parameter_Specifications (Iface_Op_Spec),
Parameter_Specifications (Wrapper_Spec));
Type_Conformant_Parameters
(Parameter_Specifications (Iface_Op_Spec),
Parameter_Specifications (Wrapper_Spec));
end Overriding_Possible;
-----------------------
@ -2609,14 +2609,13 @@ package body Exp_Ch9 is
Append_To (New_Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Chars
(Defining_Identifier (Formal))),
In_Present => In_Present (Formal),
Out_Present => Out_Present (Formal),
Null_Exclusion_Present => Null_Exclusion_Present (Formal),
Parameter_Type => Param_Type));
Chars => Chars (Defining_Identifier (Formal))),
In_Present => In_Present (Formal),
Out_Present => Out_Present (Formal),
Null_Exclusion_Present => Null_Exclusion_Present (Formal),
Parameter_Type => Param_Type));
Next (Formal);
end loop;
@ -2776,13 +2775,16 @@ package body Exp_Ch9 is
else
pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
Obj_Param :=
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
In_Present => In_Present (Parent (First_Entity (Subp_Id))),
Out_Present => Ekind (Subp_Id) /= E_Function,
Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
In_Present =>
In_Present (Parent (First_Entity (Subp_Id))),
Out_Present => Ekind (Subp_Id) /= E_Function,
Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
Prepend_To (New_Formals, Obj_Param);
end if;
@ -4195,8 +4197,7 @@ package body Exp_Ch9 is
Unprotected_Mode => 'N');
begin
if Ekind (Defining_Unit_Name (Specification (N))) =
E_Subprogram_Body
if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
then
Decl := Unit_Declaration_Node (Corresponding_Spec (N));
else
@ -4238,7 +4239,7 @@ package body Exp_Ch9 is
if Nkind (Specification (Decl)) = N_Procedure_Specification then
New_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => New_Id,
Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist);
-- Create a new specification for the anonymous subprogram type
@ -4246,9 +4247,9 @@ package body Exp_Ch9 is
else
New_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => New_Id,
Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist,
Result_Definition =>
Result_Definition =>
Copy_Result_Type (Result_Definition (Specification (Decl))));
Set_Return_Present (Defining_Unit_Name (New_Spec));
@ -9654,22 +9655,22 @@ package body Exp_Ch9 is
Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
then
declare
Found : Boolean := False;
Prim_Elmt : Elmt_Id;
Prim_Op : Node_Id;
Found : Boolean := False;
begin
Prim_Elmt :=
First_Elmt
(Primitive_Operations
(Corresponding_Record_Type (Prot_Typ)));
(Corresponding_Record_Type (Prot_Typ)));
while Present (Prim_Elmt) loop
Prim_Op := Node (Prim_Elmt);
if Is_Primitive_Wrapper (Prim_Op)
and then (Wrapped_Entity (Prim_Op))
= Defining_Entity (Specification (Comp))
and then Wrapped_Entity (Prim_Op) =
Defining_Entity (Specification (Comp))
then
Found := True;
exit;
@ -9684,6 +9685,7 @@ package body Exp_Ch9 is
Specification =>
Build_Protected_Sub_Specification
(Comp, Prot_Typ, Dispatching_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
@ -9740,19 +9742,19 @@ package body Exp_Ch9 is
Body_Arr :=
Make_Object_Declaration (Loc,
Defining_Identifier => Body_Id,
Aliased_Present => True,
Object_Definition =>
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(RTE (RE_Protected_Entry_Body_Array), Loc),
Constraint =>
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Make_Integer_Literal (Loc, 1),
Make_Integer_Literal (Loc, E_Count))))),
Expression => Entries_Aggr);
Expression => Entries_Aggr);
when System_Tasking_Protected_Objects_Single_Entry =>
Body_Arr :=
@ -9761,7 +9763,8 @@ package body Exp_Ch9 is
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Entry_Body), Loc),
Expression => Remove_Head (Expressions (Entries_Aggr)));
Expression =>
Remove_Head (Expressions (Entries_Aggr)));
when others =>
raise Program_Error;

4
gcc/ada/sem_ch3.adb
View File

@ -19828,8 +19828,8 @@ package body Sem_Ch3 is
(Subp_Id => Prim,
Obj_Typ => Conc_Typ,
Formals =>
Parameter_Specifications (
Parent (Prim))));
Parameter_Specifications
(Parent (Prim))));
Insert_After (Curr_Nod, Wrap_Spec);
Curr_Nod := Wrap_Spec;

7
gcc/ada/sem_ch4.adb
View File

@ -9022,9 +9022,10 @@ package body Sem_Ch4 is
-- Exp_Ch9.Build_Selected_Name).
elsif Is_Protected_Type (Obj_Type) then
return Present (Original_Protected_Subprogram (Prim_Op))
and then Chars (Original_Protected_Subprogram (Prim_Op))
= Chars (Subprog);
return
Present (Original_Protected_Subprogram (Prim_Op))
and then Chars (Original_Protected_Subprogram (Prim_Op)) =
Chars (Subprog);
end if;
return False;

105
gcc/ada/sem_ch6.adb
View File

@ -6491,13 +6491,6 @@ package body Sem_Ch6 is
(Prim_Params : List_Id;
Iface_Params : List_Id) return Boolean
is
Iface_Id : Entity_Id;
Iface_Param : Node_Id;
Iface_Typ : Entity_Id;
Prim_Id : Entity_Id;
Prim_Param : Node_Id;
Prim_Typ : Entity_Id;
function Is_Implemented
(Ifaces_List : Elist_Id;
Iface : Entity_Id) return Boolean;
@ -6527,6 +6520,15 @@ package body Sem_Ch6 is
return False;
end Is_Implemented;
-- Local variables
Iface_Id : Entity_Id;
Iface_Param : Node_Id;
Iface_Typ : Entity_Id;
Prim_Id : Entity_Id;
Prim_Param : Node_Id;
Prim_Typ : Entity_Id;
-- Start of processing for Matches_Prefixed_View_Profile
begin
@ -6539,8 +6541,8 @@ package body Sem_Ch6 is
Prim_Param := First (Prim_Params);
-- The first parameter of the potentially overridden subprogram
-- must be an interface implemented by Prim.
-- The first parameter of the potentially overridden subprogram must
-- be an interface implemented by Prim.
if not Is_Interface (Iface_Typ)
or else not Is_Implemented (Ifaces_List, Iface_Typ)
@ -6548,8 +6550,8 @@ package body Sem_Ch6 is
return False;
end if;
-- The checks on the object parameters are done, move onto the
-- rest of the parameters.
-- The checks on the object parameters are done, move onto the rest
-- of the parameters.
if not In_Scope then
Prim_Param := Next (Prim_Param);
@ -6568,15 +6570,15 @@ package body Sem_Ch6 is
and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
then
Iface_Typ := Designated_Type (Iface_Typ);
Prim_Typ := Designated_Type (Prim_Typ);
Prim_Typ := Designated_Type (Prim_Typ);
end if;
-- Case of multiple interface types inside a parameter profile
-- (Obj_Param : in out Iface; ...; Param : Iface)
-- If the interface type is implemented, then the matching type
-- in the primitive should be the implementing record type.
-- If the interface type is implemented, then the matching type in
-- the primitive should be the implementing record type.
if Ekind (Iface_Typ) = E_Record_Type
and then Is_Interface (Iface_Typ)
@ -6626,9 +6628,9 @@ package body Sem_Ch6 is
return;
end if;
-- Search for the concurrent declaration since it contains the list
-- of all implemented interfaces. In this case, the subprogram is
-- declared within the scope of a protected or a task type.
-- Search for the concurrent declaration since it contains the list of
-- all implemented interfaces. In this case, the subprogram is declared
-- within the scope of a protected or a task type.
if Present (Scope (Def_Id))
and then Is_Concurrent_Type (Scope (Def_Id))
@ -6658,10 +6660,10 @@ package body Sem_Ch6 is
then
In_Scope := False;
-- This case occurs when the concurrent type is declared within
-- a generic unit. As a result the corresponding record has been
-- built and used as the type of the first formal, we just have
-- to retrieve the corresponding concurrent type.
-- This case occurs when the concurrent type is declared within a
-- generic unit. As a result the corresponding record has been built
-- and used as the type of the first formal, we just have to retrieve
-- the corresponding concurrent type.
elsif Is_Concurrent_Record_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
@ -6693,9 +6695,8 @@ package body Sem_Ch6 is
Subp : Entity_Id := Empty;
begin
-- Traverse the homonym chain, looking for a potentially
-- overridden subprogram that belongs to an implemented
-- interface.
-- Traverse the homonym chain, looking for a potentially overridden
-- subprogram that belongs to an implemented interface.
Hom := Current_Entity_In_Scope (Def_Id);
while Present (Hom) loop
@ -6710,11 +6711,10 @@ package body Sem_Ch6 is
then
null;
-- Entries and procedures can override abstract or null
-- interface procedures.
-- Entries and procedures can override abstract or null interface
-- procedures.
elsif (Ekind (Def_Id) = E_Procedure
or else Ekind (Def_Id) = E_Entry)
elsif Ekind_In (Def_Id, E_Entry, E_Procedure)
and then Ekind (Subp) = E_Procedure
and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)),
@ -6723,17 +6723,16 @@ package body Sem_Ch6 is
Candidate := Subp;
-- For an overridden subprogram Subp, check whether the mode
-- of its first parameter is correct depending on the kind
-- of synchronized type.
-- of its first parameter is correct depending on the kind of
-- synchronized type.
declare
Formal : constant Node_Id := First_Formal (Candidate);
begin
-- In order for an entry or a protected procedure to
-- override, the first parameter of the overridden
-- routine must be of mode "out", "in out" or
-- access-to-variable.
-- override, the first parameter of the overridden routine
-- must be of mode "out", "in out" or access-to-variable.
if Ekind_In (Candidate, E_Entry, E_Procedure)
and then Is_Protected_Type (Typ)
@ -6744,9 +6743,9 @@ package body Sem_Ch6 is
then
null;
-- All other cases are OK since a task entry or routine
-- does not have a restriction on the mode of the first
-- parameter of the overridden interface routine.
-- All other cases are OK since a task entry or routine does
-- not have a restriction on the mode of the first parameter
-- of the overridden interface routine.
else
Overridden_Subp := Candidate;
@ -6768,8 +6767,8 @@ package body Sem_Ch6 is
-- If an inherited subprogram is implemented by a protected
-- function, then the first parameter of the inherited
-- subprogram shall be of mode in, but not an
-- access-to-variable parameter (RM 9.4(11/9)
-- subprogram shall be of mode in, but not an access-to-
-- variable parameter (RM 9.4(11/9)
if Present (First_Formal (Subp))
and then Ekind (First_Formal (Subp)) = E_In_Parameter
@ -9692,7 +9691,8 @@ package body Sem_Ch6 is
-- Has_Matching_Entry_Or_Subprogram --
--------------------------------------
function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean
function Has_Matching_Entry_Or_Subprogram
(E : Entity_Id) return Boolean
is
function Check_Conforming_Parameters
(E1_Param : Node_Id;
@ -9738,12 +9738,13 @@ package body Sem_Ch6 is
begin
while Present (Param_E1) and then Present (Param_E2) loop
if Ekind (Defining_Identifier (Param_E1))
/= Ekind (Defining_Identifier (Param_E2))
if Ekind (Defining_Identifier (Param_E1)) /=
Ekind (Defining_Identifier (Param_E2))
or else not
Conforming_Types (Find_Parameter_Type (Param_E1),
Find_Parameter_Type (Param_E2),
Subtype_Conformant)
Conforming_Types
(Find_Parameter_Type (Param_E1),
Find_Parameter_Type (Param_E2),
Subtype_Conformant)
then
return False;
end if;
@ -9799,7 +9800,7 @@ package body Sem_Ch6 is
begin
-- Search for entities in the enclosing scope of this synchonized
-- type
-- type.
pragma Assert (Is_Concurrent_Type (Conc_Typ));
Push_Scope (Scope (Conc_Typ));
@ -9841,7 +9842,7 @@ package body Sem_Ch6 is
begin
-- Temporarily decorate the first parameter of Subp as controlling
-- formal; required to invoke Subtype_Conformant()
-- formal, required to invoke Subtype_Conformant.
Set_Is_Controlling_Formal (First_Entity (Subp));
@ -9866,6 +9867,7 @@ package body Sem_Ch6 is
end loop;
Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
return Empty;
end Matching_Original_Protected_Subprogram;
@ -9882,8 +9884,8 @@ package body Sem_Ch6 is
and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
then
if Scope (E) =
Scope (Corresponding_Concurrent_Type (
Etype (First_Entity (E))))
Scope (Corresponding_Concurrent_Type
(Etype (First_Entity (E))))
and then
Present
(Matching_Entry_Or_Subprogram
@ -9913,8 +9915,8 @@ package body Sem_Ch6 is
and then
Present
(Matching_Original_Protected_Subprogram
(Corresponding_Concurrent_Type (Etype (First_Entity (E))),
Subp => E))
(Corresponding_Concurrent_Type (Etype (First_Entity (E))),
Subp => E))
then
Report_Conflict (E,
Matching_Original_Protected_Subprogram
@ -9944,8 +9946,8 @@ package body Sem_Ch6 is
----------------------------
function Is_Private_Declaration (E : Entity_Id) return Boolean is
Priv_Decls : List_Id;
Decl : constant Node_Id := Unit_Declaration_Node (E);
Priv_Decls : List_Id;
begin
if Is_Package_Or_Generic_Package (Current_Scope)
@ -9979,6 +9981,7 @@ package body Sem_Ch6 is
is
AO : constant Entity_Id := Alias (Old_E);
AN : constant Entity_Id := Alias (New_E);
begin
return Scope (AO) /= Scope (AN)
or else No (DTC_Entity (AO))