Skip to content

R
riscv-gcc-1
Commit 31e358e1 by Arnaud Charlet
Options

[multiple changes] 

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

	* checks.adb, sem_ch3.adb, sem_ch6.adb: Minor reformatting.

2017-05-02  Bob Duff  <duff@adacore.com>

	* exp_attr.adb (Callable, Identity, Terminated): Use Find_Prim_Op
	to find primitive ops, instead of using an Identifier that will
	later be looked up. This is necessary because these ops are not
	necessarily visible at all places where we need to call them.
	* exp_util.ads: Minor comment fix.

From-SVN: r247466
parent d59179b1
Showing with 104 additions and 79 deletions
gcc/ada/ChangeLog
2017-05-02 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb, sem_ch3.adb, sem_ch6.adb: Minor reformatting.
2017-05-02 Bob Duff <duff@adacore.com>
* exp_attr.adb (Callable, Identity, Terminated): Use Find_Prim_Op
to find primitive ops, instead of using an Identifier that will
later be looked up. This is necessary because these ops are not
necessarily visible at all places where we need to call them.
* exp_util.ads: Minor comment fix.
2017-05-02 Ed Schonberg <schonberg@adacore.com> 2017-05-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Fully_Conformant_Expressions): Two entity * sem_ch6.adb (Fully_Conformant_Expressions): Two entity
......
gcc/ada/checks.adb
...@@ -4124,7 +4124,7 @@ package body Checks is ...@@ -4124,7 +4124,7 @@ package body Checks is
if Present (Comp) then if Present (Comp) then
-- Specialize the error message to indicate that we are dealing -- Specialize the warning message to indicate that we are dealing
-- with an uninitialized composite object that has a defaulted -- with an uninitialized composite object that has a defaulted
-- null-excluding component. -- null-excluding component.
...@@ -4133,9 +4133,11 @@ package body Checks is ...@@ -4133,9 +4133,11 @@ package body Checks is
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N => Expression (N), (N => Expression (N),
Msg => "(Ada 2005) null-excluding component % of object % " & Msg =>
"must be initialized??", "(Ada 2005) null-excluding component % of object % must be "
& "initialized??",
Reason => CE_Null_Not_Allowed); Reason => CE_Null_Not_Allowed);
else else
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N => Expression (N), (N => Expression (N),
......
gcc/ada/exp_attr.adb
...@@ -1028,7 +1028,7 @@ package body Exp_Attr is ...@@ -1028,7 +1028,7 @@ package body Exp_Attr is
Loc : Source_Ptr; Loc : Source_Ptr;
Loop_Id : Entity_Id; Loop_Id : Entity_Id;
Loop_Stmt : Node_Id; Loop_Stmt : Node_Id;
Result : Node_Id; Result : Node_Id := Empty;
Scheme : Node_Id; Scheme : Node_Id;
Temp_Decl : Node_Id; Temp_Decl : Node_Id;
Temp_Id : Entity_Id; Temp_Id : Entity_Id;
...@@ -1093,8 +1093,6 @@ package body Exp_Attr is ...@@ -1093,8 +1093,6 @@ package body Exp_Attr is
Decls := Declarations (Parent (Parent (Loop_Stmt))); Decls := Declarations (Parent (Parent (Loop_Stmt)));
end if; end if;
Result := Empty;
-- Transform the loop into a conditional block -- Transform the loop into a conditional block
else else
...@@ -2480,20 +2478,25 @@ package body Exp_Attr is ...@@ -2480,20 +2478,25 @@ package body Exp_Attr is
and then Is_Interface (Ptyp) and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp) and then Is_Task_Interface (Ptyp)
then then
Rewrite (N, declare
Make_Function_Call (Loc, Id : constant Node_Id :=
Name => New_Occurrence_Of
New_Occurrence_Of (RTE (RE_Callable), Loc), (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc);
Parameter_Associations => New_List ( Call : constant Node_Id :=
Make_Unchecked_Type_Conversion (Loc, Make_Function_Call (Loc,
Subtype_Mark => Name => Id,
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), Parameter_Associations => New_List (Pref));
Expression => begin
Make_Selected_Component (Loc, Rewrite (N,
Prefix => Make_Function_Call (Loc,
New_Copy_Tree (Pref), Name =>
Selector_Name => New_Occurrence_Of (RTE (RE_Callable), Loc),
Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); Parameter_Associations => New_List (
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
Expression => Call))));
end;
else else
Rewrite (N, Rewrite (N,
...@@ -3578,13 +3581,17 @@ package body Exp_Attr is ...@@ -3578,13 +3581,17 @@ package body Exp_Attr is
and then Is_Interface (Ptyp) and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp) and then Is_Task_Interface (Ptyp)
then then
Rewrite (N, declare
Unchecked_Convert_To (Id_Kind, Id : constant Node_Id :=
Make_Selected_Component (Loc, New_Occurrence_Of
Prefix => (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc);
New_Copy_Tree (Pref), Call : constant Node_Id :=
Selector_Name => Make_Function_Call (Loc,
Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))); Name => Id,
Parameter_Associations => New_List (Pref));
begin
Rewrite (N, Unchecked_Convert_To (Id_Kind, Call));
end;
else else
Rewrite (N, Rewrite (N,
...@@ -6264,27 +6271,32 @@ package body Exp_Attr is ...@@ -6264,27 +6271,32 @@ package body Exp_Attr is
-- The prefix of Terminated is of a task interface class-wide type. -- The prefix of Terminated is of a task interface class-wide type.
-- Generate: -- Generate:
-- terminated (Task_Id (Pref._disp_get_task_id)); -- terminated (Task_Id (_disp_get_task_id (Pref)));
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005
and then Ekind (Ptyp) = E_Class_Wide_Type and then Ekind (Ptyp) = E_Class_Wide_Type
and then Is_Interface (Ptyp) and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp) and then Is_Task_Interface (Ptyp)
then then
Rewrite (N, declare
Make_Function_Call (Loc, Id : constant Node_Id :=
Name => New_Occurrence_Of
New_Occurrence_Of (RTE (RE_Terminated), Loc), (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc);
Parameter_Associations => New_List ( Call : constant Node_Id :=
Make_Unchecked_Type_Conversion (Loc, Make_Function_Call (Loc,
Subtype_Mark => Name => Id,
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), Parameter_Associations => New_List (Pref));
Expression => begin
Make_Selected_Component (Loc, Rewrite (N,
Prefix => Make_Function_Call (Loc,
New_Copy_Tree (Pref), Name =>
Selector_Name => New_Occurrence_Of (RTE (RE_Terminated), Loc),
Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); Parameter_Associations => New_List (
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
Expression => Call))));
end;
elsif Restricted_Profile then elsif Restricted_Profile then
Rewrite (N, Rewrite (N,
......
gcc/ada/exp_util.ads
...@@ -592,11 +592,9 @@ package Exp_Util is ...@@ -592,11 +592,9 @@ package Exp_Util is
function Find_Prim_Op function Find_Prim_Op
(T : Entity_Id; (T : Entity_Id;
Name : TSS_Name_Type) return Entity_Id; Name : TSS_Name_Type) return Entity_Id;
-- Find the first primitive operation of type T whose name has the form -- Same as Find_Prim_Op above, except we're searching for an op that has
-- indicated by the name parameter (i.e. is a type support subprogram -- the form indicated by Name (i.e. is a type support subprogram with the
-- with the indicated suffix). This function allows use of a primitive -- indicated suffix).
-- operation which is not directly visible. If T is a class wide type,
-- then the reference is to an operation of the corresponding root type.
function Find_Optional_Prim_Op function Find_Optional_Prim_Op
(T : Entity_Id; Name : Name_Id) return Entity_Id; (T : Entity_Id; Name : Name_Id) return Entity_Id;
......
gcc/ada/sem_ch3.adb
...@@ -3583,17 +3583,17 @@ package body Sem_Ch3 is ...@@ -3583,17 +3583,17 @@ package body Sem_Ch3 is
T : Entity_Id; T : Entity_Id;
E : Node_Id := Expression (N); E : Node_Id := Expression (N);
-- E is set to Expression (N) throughout this routine. When -- E is set to Expression (N) throughout this routine. When Expression
-- Expression (N) is modified, E is changed accordingly. -- (N) is modified, E is changed accordingly.
Prev_Entity : Entity_Id := Empty; Prev_Entity : Entity_Id := Empty;
procedure Check_For_Null_Excluding_Components procedure Check_For_Null_Excluding_Components
(Obj_Typ : Entity_Id; (Obj_Typ : Entity_Id;
Obj_Decl : Node_Id); Obj_Decl : Node_Id);
-- Recursively verify that each null-excluding component of an object -- Verify that each null-excluding component of object declaration
-- declaration's type has explicit initialization, and generate -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit
-- compile-time warnings for each one that does not. -- a compile-time warning if this is not the case.
function Count_Tasks (T : Entity_Id) return Uint; function Count_Tasks (T : Entity_Id) return Uint;
-- This function is called when a non-generic library level object of a -- This function is called when a non-generic library level object of a
...@@ -3622,12 +3622,12 @@ package body Sem_Ch3 is ...@@ -3622,12 +3622,12 @@ package body Sem_Ch3 is
(Obj_Typ : Entity_Id; (Obj_Typ : Entity_Id;
Obj_Decl : Node_Id) Obj_Decl : Node_Id)
is is
procedure Check_Component procedure Check_Component
(Comp_Typ : Entity_Id; (Comp_Typ : Entity_Id;
Comp_Decl : Node_Id := Empty); Comp_Decl : Node_Id := Empty);
-- Perform compile-time null-exclusion checks on a given component -- Apply a compile-time null-exclusion check on a component denoted
-- and all of its subcomponents, if any. -- by its declaration Comp_Decl and type Comp_Typ, and all of its
-- subcomponents (if any).
--------------------- ---------------------
-- Check_Component -- -- Check_Component --
...@@ -3641,15 +3641,14 @@ package body Sem_Ch3 is ...@@ -3641,15 +3641,14 @@ package body Sem_Ch3 is
T : Entity_Id; T : Entity_Id;
begin begin
-- Return without further checking if the component has explicit -- Do not consider internally-generated components or those that
-- initialization or does not come from source. -- are already initialized.
if Present (Comp_Decl) then if Present (Comp_Decl)
if not Comes_From_Source (Comp_Decl) and then (not Comes_From_Source (Comp_Decl)
or else Present (Expression (Comp_Decl)) or else Present (Expression (Comp_Decl)))
then then
return; return;
end if;
end if; end if;
if Is_Incomplete_Or_Private_Type (Comp_Typ) if Is_Incomplete_Or_Private_Type (Comp_Typ)
...@@ -3667,9 +3666,10 @@ package body Sem_Ch3 is ...@@ -3667,9 +3666,10 @@ package body Sem_Ch3 is
then then
Null_Exclusion_Static_Checks (Obj_Decl, Comp_Decl); Null_Exclusion_Static_Checks (Obj_Decl, Comp_Decl);
-- Check array type components -- Check array components
elsif Is_Array_Type (T) then elsif Is_Array_Type (T) then
-- There is no suitable component when the object is of an -- There is no suitable component when the object is of an
-- array type. However, a namable component may appear at some -- array type. However, a namable component may appear at some
-- point during the recursive inspection, but not at the top -- point during the recursive inspection, but not at the top
...@@ -3681,12 +3681,10 @@ package body Sem_Ch3 is ...@@ -3681,12 +3681,10 @@ package body Sem_Ch3 is
Check_Component (Component_Type (T), Comp_Decl); Check_Component (Component_Type (T), Comp_Decl);
end if; end if;
-- If T allows named components, then iterate through them, -- Verify all components of type T
-- recursively verifying all subcomponents.
-- NOTE: Due to the complexities involved with checking components -- Note: No checks are performed on types with discriminants due
-- of nontrivial types with discriminants (variant records and -- to complexities involving variants. ???
-- the like), no static checking is performed on them. ???
elsif (Is_Concurrent_Type (T) elsif (Is_Concurrent_Type (T)
or else Is_Incomplete_Or_Private_Type (T) or else Is_Incomplete_Or_Private_Type (T)
...@@ -3910,12 +3908,12 @@ package body Sem_Ch3 is ...@@ -3910,12 +3908,12 @@ package body Sem_Ch3 is
-- out some static checks. -- out some static checks.
if Ada_Version >= Ada_2005 then if Ada_Version >= Ada_2005 then
-- In case of aggregates we must also take care of the correct -- In case of aggregates we must also take care of the correct
-- initialization of nested aggregates bug this is done at the -- initialization of nested aggregates bug this is done at the
-- point of the analysis of the aggregate (see sem_aggr.adb) ??? -- point of the analysis of the aggregate (see sem_aggr.adb) ???
if Can_Never_Be_Null (T) then if Can_Never_Be_Null (T) then
if Present (Expression (N)) if Present (Expression (N))
and then Nkind (Expression (N)) = N_Aggregate and then Nkind (Expression (N)) = N_Aggregate
then then
......
gcc/ada/sem_ch6.adb
...@@ -8763,18 +8763,20 @@ package body Sem_Ch6 is ...@@ -8763,18 +8763,20 @@ package body Sem_Ch6 is
if Present (Entity (E1)) then if Present (Entity (E1)) then
return Entity (E1) = Entity (E2) return Entity (E1) = Entity (E2)
-- One may be a discriminant that has been replaced by -- One may be a discriminant that has been replaced by the
-- the corresponding discriminal. -- corresponding discriminal.
or else (Chars (Entity (E1)) = Chars (Entity (E2)) or else
and then Ekind (Entity (E1)) = E_Discriminant (Chars (Entity (E1)) = Chars (Entity (E2))
and then Ekind (Entity (E2)) = E_In_Parameter) and then Ekind (Entity (E1)) = E_Discriminant
and then Ekind (Entity (E2)) = E_In_Parameter)
-- The discriminant of a protected type is transformed into -- The discriminant of a protected type is transformed into
-- a local constant and then into a parameter of a protected -- a local constant and then into a parameter of a protected
-- operation. -- operation.
or else (Ekind (Entity (E1)) = E_Constant or else
(Ekind (Entity (E1)) = E_Constant
and then Ekind (Entity (E2)) = E_In_Parameter and then Ekind (Entity (E2)) = E_In_Parameter
and then Present (Discriminal_Link (Entity (E1))) and then Present (Discriminal_Link (Entity (E1)))
and then Discriminal_Link (Entity (E1)) = and then Discriminal_Link (Entity (E1)) =
...@@ -8784,9 +8786,10 @@ package body Sem_Ch6 is ...@@ -8784,9 +8786,10 @@ package body Sem_Ch6 is
-- match if they have the same identifier, even though they -- match if they have the same identifier, even though they
-- are different entities. -- are different entities.
or else (Chars (Entity (E1)) = Chars (Entity (E2)) or else
and then Ekind (Entity (E1)) = E_Loop_Parameter (Chars (Entity (E1)) = Chars (Entity (E2))
and then Ekind (Entity (E2)) = E_Loop_Parameter); and then Ekind (Entity (E1)) = E_Loop_Parameter
and then Ekind (Entity (E2)) = E_Loop_Parameter);
elsif Nkind (E1) = N_Expanded_Name elsif Nkind (E1) = N_Expanded_Name
and then Nkind (E2) = N_Expanded_Name and then Nkind (E2) = N_Expanded_Name
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment