+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>
* sem_ch6.adb (Fully_Conformant_Expressions): Two entity
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
-- null-excluding component.
Apply_Compile_Time_Constraint_Error
(N => Expression (N),
- Msg => "(Ada 2005) null-excluding component % of object % " &
- "must be initialized??",
+ Msg =>
+ "(Ada 2005) null-excluding component % of object % must be "
+ & "initialized??",
Reason => CE_Null_Not_Allowed);
+
else
Apply_Compile_Time_Constraint_Error
(N => Expression (N),
Loc : Source_Ptr;
Loop_Id : Entity_Id;
Loop_Stmt : Node_Id;
- Result : Node_Id;
+ Result : Node_Id := Empty;
Scheme : Node_Id;
Temp_Decl : Node_Id;
Temp_Id : Entity_Id;
Decls := Declarations (Parent (Parent (Loop_Stmt)));
end if;
- Result := Empty;
-
-- Transform the loop into a conditional block
else
and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp)
then
- Rewrite (N,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Callable), Loc),
- Parameter_Associations => New_List (
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Pref),
- Selector_Name =>
- Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
+ declare
+ Id : constant Node_Id :=
+ New_Occurrence_Of
+ (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc);
+ Call : constant Node_Id :=
+ Make_Function_Call (Loc,
+ Name => Id,
+ Parameter_Associations => New_List (Pref));
+ begin
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Callable), Loc),
+ Parameter_Associations => New_List (
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
+ Expression => Call))));
+ end;
else
Rewrite (N,
and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp)
then
- Rewrite (N,
- Unchecked_Convert_To (Id_Kind,
- Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Pref),
- Selector_Name =>
- Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
+ declare
+ Id : constant Node_Id :=
+ New_Occurrence_Of
+ (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc);
+ Call : constant Node_Id :=
+ Make_Function_Call (Loc,
+ Name => Id,
+ Parameter_Associations => New_List (Pref));
+ begin
+ Rewrite (N, Unchecked_Convert_To (Id_Kind, Call));
+ end;
else
Rewrite (N,
-- The prefix of Terminated is of a task interface class-wide type.
-- Generate:
- -- terminated (Task_Id (Pref._disp_get_task_id));
+ -- terminated (Task_Id (_disp_get_task_id (Pref)));
if Ada_Version >= Ada_2005
and then Ekind (Ptyp) = E_Class_Wide_Type
and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp)
then
- Rewrite (N,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Terminated), Loc),
- Parameter_Associations => New_List (
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Pref),
- Selector_Name =>
- Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
+ declare
+ Id : constant Node_Id :=
+ New_Occurrence_Of
+ (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc);
+ Call : constant Node_Id :=
+ Make_Function_Call (Loc,
+ Name => Id,
+ Parameter_Associations => New_List (Pref));
+ begin
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Terminated), Loc),
+ 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
Rewrite (N,
function Find_Prim_Op
(T : Entity_Id;
Name : TSS_Name_Type) return Entity_Id;
- -- Find the first primitive operation of type T whose name has the form
- -- indicated by the name parameter (i.e. is a type support subprogram
- -- with the indicated suffix). This function allows use of a primitive
- -- 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.
+ -- Same as Find_Prim_Op above, except we're searching for an op that has
+ -- the form indicated by Name (i.e. is a type support subprogram with the
+ -- indicated suffix).
function Find_Optional_Prim_Op
(T : Entity_Id; Name : Name_Id) return Entity_Id;
T : Entity_Id;
E : Node_Id := Expression (N);
- -- E is set to Expression (N) throughout this routine. When
- -- Expression (N) is modified, E is changed accordingly.
+ -- E is set to Expression (N) throughout this routine. When Expression
+ -- (N) is modified, E is changed accordingly.
Prev_Entity : Entity_Id := Empty;
procedure Check_For_Null_Excluding_Components
(Obj_Typ : Entity_Id;
Obj_Decl : Node_Id);
- -- Recursively verify that each null-excluding component of an object
- -- declaration's type has explicit initialization, and generate
- -- compile-time warnings for each one that does not.
+ -- Verify that each null-excluding component of object declaration
+ -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit
+ -- a compile-time warning if this is not the case.
function Count_Tasks (T : Entity_Id) return Uint;
-- This function is called when a non-generic library level object of a
(Obj_Typ : Entity_Id;
Obj_Decl : Node_Id)
is
-
procedure Check_Component
(Comp_Typ : Entity_Id;
Comp_Decl : Node_Id := Empty);
- -- Perform compile-time null-exclusion checks on a given component
- -- and all of its subcomponents, if any.
+ -- Apply a compile-time null-exclusion check on a component denoted
+ -- by its declaration Comp_Decl and type Comp_Typ, and all of its
+ -- subcomponents (if any).
---------------------
-- Check_Component --
T : Entity_Id;
begin
- -- Return without further checking if the component has explicit
- -- initialization or does not come from source.
+ -- Do not consider internally-generated components or those that
+ -- are already initialized.
- if Present (Comp_Decl) then
- if not Comes_From_Source (Comp_Decl)
- or else Present (Expression (Comp_Decl))
- then
- return;
- end if;
+ if Present (Comp_Decl)
+ and then (not Comes_From_Source (Comp_Decl)
+ or else Present (Expression (Comp_Decl)))
+ then
+ return;
end if;
if Is_Incomplete_Or_Private_Type (Comp_Typ)
then
Null_Exclusion_Static_Checks (Obj_Decl, Comp_Decl);
- -- Check array type components
+ -- Check array components
elsif Is_Array_Type (T) then
+
-- There is no suitable component when the object is of an
-- array type. However, a namable component may appear at some
-- point during the recursive inspection, but not at the top
Check_Component (Component_Type (T), Comp_Decl);
end if;
- -- If T allows named components, then iterate through them,
- -- recursively verifying all subcomponents.
+ -- Verify all components of type T
- -- NOTE: Due to the complexities involved with checking components
- -- of nontrivial types with discriminants (variant records and
- -- the like), no static checking is performed on them. ???
+ -- Note: No checks are performed on types with discriminants due
+ -- to complexities involving variants. ???
elsif (Is_Concurrent_Type (T)
or else Is_Incomplete_Or_Private_Type (T)
-- out some static checks.
if Ada_Version >= Ada_2005 then
+
-- In case of aggregates we must also take care of the correct
-- initialization of nested aggregates bug this is done at the
-- point of the analysis of the aggregate (see sem_aggr.adb) ???
if Can_Never_Be_Null (T) then
-
if Present (Expression (N))
and then Nkind (Expression (N)) = N_Aggregate
then
if Present (Entity (E1)) then
return Entity (E1) = Entity (E2)
- -- One may be a discriminant that has been replaced by
- -- the corresponding discriminal.
+ -- One may be a discriminant that has been replaced by the
+ -- corresponding discriminal.
- or else (Chars (Entity (E1)) = Chars (Entity (E2))
- and then Ekind (Entity (E1)) = E_Discriminant
- and then Ekind (Entity (E2)) = E_In_Parameter)
+ or else
+ (Chars (Entity (E1)) = Chars (Entity (E2))
+ and then Ekind (Entity (E1)) = E_Discriminant
+ and then Ekind (Entity (E2)) = E_In_Parameter)
-- The discriminant of a protected type is transformed into
-- a local constant and then into a parameter of a protected
-- 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 Present (Discriminal_Link (Entity (E1)))
and then Discriminal_Link (Entity (E1)) =
-- match if they have the same identifier, even though they
-- are different entities.
- or else (Chars (Entity (E1)) = Chars (Entity (E2))
- and then Ekind (Entity (E1)) = E_Loop_Parameter
- and then Ekind (Entity (E2)) = E_Loop_Parameter);
+ or else
+ (Chars (Entity (E1)) = Chars (Entity (E2))
+ and then Ekind (Entity (E1)) = E_Loop_Parameter
+ and then Ekind (Entity (E2)) = E_Loop_Parameter);
elsif Nkind (E1) = N_Expanded_Name
and then Nkind (E2) = N_Expanded_Name
projects / gcc.git / commitdiff