Commit 62d40a7a by Arnaud Charlet

[multiple changes]

2017-05-02  Eric Botcazou  <ebotcazou@adacore.com>

	* atree.h (Flag290): Add missing terminating parenthesis.
	* einfo.adb (Is_Class_Wide_Clone): Use Flag290.
	(Set_Is_Class_Wide_Clone): Likewise.
	* einfo.ads (Is_Class_Wide_Clone): Likewise.

2017-05-02  Gary Dismukes  <dismukes@adacore.com>

	* checks.ads (Null_Exclusion_Static_Checks): Add Boolean
	parameter Array_Comp to indicate the case of an array object
	with null-excluding components.
	* checks.adb (Null_Exclusion_Static_Checks):
	Call Compile_Time_Constraint_Error instead of
	Apply_Compile_Time_Constraint_Error in the component case. Also
	call that when Array_Comp is True, with an appropriate warning for
	the array component case. Only create an explicit initialization
	by null in the case of an object of a null-excluding access type
	(and no longer do that in the component case).
	* sem_ch3.adb (Check_Component): Add a Boolean parameter
	Array_Comp defaulted to False.	Pass Empty for the Comp
	actual when calling Null_Exclusion_Static_Checks in the case
	where Comp_Decl matches Object_Decl, because we don't have a
	component in that case. In the case of an object or component
	of an array type, pass True for Array_Comp on the recursive call
	to Check_Component.

From-SVN: r247474
parent d86fb53f
2017-05-02 Eric Botcazou <ebotcazou@adacore.com>
* atree.h (Flag290): Add missing terminating parenthesis.
* einfo.adb (Is_Class_Wide_Clone): Use Flag290.
(Set_Is_Class_Wide_Clone): Likewise.
* einfo.ads (Is_Class_Wide_Clone): Likewise.
2017-05-02 Gary Dismukes <dismukes@adacore.com>
* checks.ads (Null_Exclusion_Static_Checks): Add Boolean
parameter Array_Comp to indicate the case of an array object
with null-excluding components.
* checks.adb (Null_Exclusion_Static_Checks):
Call Compile_Time_Constraint_Error instead of
Apply_Compile_Time_Constraint_Error in the component case. Also
call that when Array_Comp is True, with an appropriate warning for
the array component case. Only create an explicit initialization
by null in the case of an object of a null-excluding access type
(and no longer do that in the component case).
* sem_ch3.adb (Check_Component): Add a Boolean parameter
Array_Comp defaulted to False. Pass Empty for the Comp
actual when calling Null_Exclusion_Static_Checks in the case
where Comp_Decl matches Object_Decl, because we don't have a
component in that case. In the case of an object or component
of an array type, pass True for Array_Comp on the recursive call
to Check_Component.
2017-05-02 Bob Duff <duff@adacore.com> 2017-05-02 Bob Duff <duff@adacore.com>
* s-taprop-linux.adb (Prio_To_Linux_Prio): New function to correctly * s-taprop-linux.adb (Prio_To_Linux_Prio): New function to correctly
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * C Header File *
* * * *
* Copyright (C) 1992-2016, Free Software Foundation, Inc. * * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
* * * *
* GNAT is free software; you can redistribute it and/or modify it under * * GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -869,7 +869,7 @@ extern Node_Id Current_Error_Node; ...@@ -869,7 +869,7 @@ extern Node_Id Current_Error_Node;
#define Flag287(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.in_list) #define Flag287(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.in_list)
#define Flag288(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.has_aspects) #define Flag288(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.has_aspects)
#define Flag289(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.rewrite_ins) #define Flag289(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.rewrite_ins)
#define Flag290(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.analyzed #define Flag290(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.analyzed)
#define Flag291(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.c_f_s) #define Flag291(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.c_f_s)
#define Flag292(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.error_posted) #define Flag292(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.error_posted)
#define Flag293(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag4) #define Flag293(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag4)
......
...@@ -4043,8 +4043,9 @@ package body Checks is ...@@ -4043,8 +4043,9 @@ package body Checks is
---------------------------------- ----------------------------------
procedure Null_Exclusion_Static_Checks procedure Null_Exclusion_Static_Checks
(N : Node_Id; (N : Node_Id;
Comp : Node_Id := Empty) Comp : Node_Id := Empty;
Array_Comp : Boolean := False)
is is
Error_Node : Node_Id; Error_Node : Node_Id;
Expr : Node_Id; Expr : Node_Id;
...@@ -4120,13 +4121,6 @@ package body Checks is ...@@ -4120,13 +4121,6 @@ package body Checks is
and then not Constant_Present (N) and then not Constant_Present (N)
and then not No_Initialization (N) and then not No_Initialization (N)
then then
-- Add an expression that assigns null. This node is needed by
-- Apply_Compile_Time_Constraint_Error, which will replace this with
-- a Constraint_Error node.
Set_Expression (N, Make_Null (Sloc (N)));
Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
if Present (Comp) then if Present (Comp) then
-- Specialize the warning message to indicate that we are dealing -- Specialize the warning message to indicate that we are dealing
...@@ -4136,14 +4130,36 @@ package body Checks is ...@@ -4136,14 +4130,36 @@ package body Checks is
Error_Msg_Name_1 := Chars (Defining_Identifier (Comp)); Error_Msg_Name_1 := Chars (Defining_Identifier (Comp));
Error_Msg_Name_2 := Chars (Defining_Identifier (N)); Error_Msg_Name_2 := Chars (Defining_Identifier (N));
Apply_Compile_Time_Constraint_Error Discard_Node
(N => Expression (N), (Compile_Time_Constraint_Error
Msg => (N => N,
"(Ada 2005) null-excluding component % of object % must be " Msg =>
& "initialized??", "(Ada 2005) null-excluding component % of object % must "
Reason => CE_Null_Not_Allowed); & "be initialized??",
Ent => Defining_Identifier (Comp)));
-- This is a case of an array with null-excluding components, so
-- indicate that in the warning.
elsif Array_Comp then
Discard_Node
(Compile_Time_Constraint_Error
(N => N,
Msg =>
"(Ada 2005) null-excluding array components must "
& "be initialized??",
Ent => Defining_Identifier (N)));
-- Normal case of object of a null-excluding access type
else else
-- Add an expression that assigns null. This node is needed by
-- Apply_Compile_Time_Constraint_Error, which will replace this
-- with a Constraint_Error node.
Set_Expression (N, Make_Null (Sloc (N)));
Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N => Expression (N), (N => Expression (N),
Msg => Msg =>
......
...@@ -916,13 +916,17 @@ package Checks is ...@@ -916,13 +916,17 @@ package Checks is
-- see the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl. -- see the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl.
procedure Null_Exclusion_Static_Checks procedure Null_Exclusion_Static_Checks
(N : Node_Id; (N : Node_Id;
Comp : Node_Id := Empty); Comp : Node_Id := Empty;
-- Ada 2005 (AI-231): Check bad usages of the null-exclusion issue Array_Comp : Boolean := False);
-- Ada 2005 (AI-231): Test for and warn on null-excluding objects or
-- components that will raise an exception due to initialization by null.
-- --
-- When a value for Comp is supplied (as in the case of an uninitialized -- When a value for Comp is supplied (as in the case of an uninitialized
-- null-excluding component within a composite object), a reported warning -- null-excluding component within a composite object), a reported warning
-- will indicate the offending component instead of the object itself. -- will indicate the offending component instead of the object itself.
-- Array_Comp being True indicates an array object with null-excluding
-- components, and any reported warning will indicate that.
procedure Remove_Checks (Expr : Node_Id); procedure Remove_Checks (Expr : Node_Id);
-- Remove all checks from Expr except those that are only executed -- Remove all checks from Expr except those that are only executed
......
...@@ -603,8 +603,7 @@ package body Einfo is ...@@ -603,8 +603,7 @@ package body Einfo is
-- Rewritten_For_C Flag287 -- Rewritten_For_C Flag287
-- Predicates_Ignored Flag288 -- Predicates_Ignored Flag288
-- Has_Timing_Event Flag289 -- Has_Timing_Event Flag289
-- Is_Class_Wide_Clone Flag290
-- (unused) Flag290 -- ??? flag breaks einfo.h
-- Has_Inherited_Invariants Flag291 -- Has_Inherited_Invariants Flag291
-- Is_Partial_Invariant_Procedure Flag292 -- Is_Partial_Invariant_Procedure Flag292
...@@ -615,10 +614,10 @@ package body Einfo is ...@@ -615,10 +614,10 @@ package body Einfo is
-- Is_Entry_Wrapper Flag297 -- Is_Entry_Wrapper Flag297
-- Is_Underlying_Full_View Flag298 -- Is_Underlying_Full_View Flag298
-- Body_Needed_For_Inlining Flag299 -- Body_Needed_For_Inlining Flag299
-- Has_Private_Extension Flag300 -- Has_Private_Extension Flag300
-- Ignore_SPARK_Mode_Pragmas Flag301 -- Ignore_SPARK_Mode_Pragmas Flag301
-- Is_Class_Wide_Clone Flag302 -- (unused) Flag302
-- (unused) Flag303 -- (unused) Flag303
-- (unused) Flag304 -- (unused) Flag304
-- (unused) Flag305 -- (unused) Flag305
...@@ -2134,7 +2133,7 @@ package body Einfo is ...@@ -2134,7 +2133,7 @@ package body Einfo is
function Is_Class_Wide_Clone (Id : E) return B is function Is_Class_Wide_Clone (Id : E) return B is
begin begin
return Flag302 (Id); return Flag290 (Id);
end Is_Class_Wide_Clone; end Is_Class_Wide_Clone;
function Is_Class_Wide_Equivalent_Type (Id : E) return B is function Is_Class_Wide_Equivalent_Type (Id : E) return B is
...@@ -5258,7 +5257,7 @@ package body Einfo is ...@@ -5258,7 +5257,7 @@ package body Einfo is
procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True) is procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True) is
begin begin
Set_Flag302 (Id, V); Set_Flag290 (Id, V);
end Set_Is_Class_Wide_Clone; end Set_Is_Class_Wide_Clone;
procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is
......
...@@ -2356,7 +2356,7 @@ package Einfo is ...@@ -2356,7 +2356,7 @@ package Einfo is
-- Defined in all entities. Set only for defining entities of program -- Defined in all entities. Set only for defining entities of program
-- units that are child units (but False for subunits). -- units that are child units (but False for subunits).
-- Is_Class_Wide_Clone (Flag302) -- Is_Class_Wide_Clone (Flag290)
-- Defined on subprogram entities. Set for subprograms built in order -- Defined on subprogram entities. Set for subprograms built in order
-- to implement properly the inheritance of class-wide pre- or post- -- to implement properly the inheritance of class-wide pre- or post-
-- conditions when the condition contains calls to other primitives -- conditions when the condition contains calls to other primitives
......
...@@ -3648,7 +3648,9 @@ package body Sem_Ch3 is ...@@ -3648,7 +3648,9 @@ package body Sem_Ch3 is
then then
Comp := First_Component (Obj_Type); Comp := First_Component (Obj_Type);
while Present (Comp) loop while Present (Comp) loop
if Known_Static_Esize (Etype (Comp)) then if Known_Static_Esize (Etype (Comp))
or else Size_Known_At_Compile_Time (Etype (Comp))
then
null; null;
elsif not Discriminated_Size (Comp) elsif not Discriminated_Size (Comp)
...@@ -3674,8 +3676,9 @@ package body Sem_Ch3 is ...@@ -3674,8 +3676,9 @@ package body Sem_Ch3 is
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;
Array_Comp : Boolean := False);
-- Apply a compile-time null-exclusion check on a component denoted -- Apply a compile-time null-exclusion check on a component denoted
-- by its declaration Comp_Decl and type Comp_Typ, and all of its -- by its declaration Comp_Decl and type Comp_Typ, and all of its
-- subcomponents (if any). -- subcomponents (if any).
...@@ -3686,7 +3689,8 @@ package body Sem_Ch3 is ...@@ -3686,7 +3689,8 @@ package body Sem_Ch3 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;
Array_Comp : Boolean := False)
is is
Comp : Entity_Id; Comp : Entity_Id;
T : Entity_Id; T : Entity_Id;
...@@ -3715,7 +3719,12 @@ package body Sem_Ch3 is ...@@ -3715,7 +3719,12 @@ package body Sem_Ch3 is
if Is_Access_Type (T) if Is_Access_Type (T)
and then Can_Never_Be_Null (T) and then Can_Never_Be_Null (T)
then then
Null_Exclusion_Static_Checks (Obj_Decl, Comp_Decl); if Comp_Decl = Obj_Decl then
Null_Exclusion_Static_Checks (Obj_Decl, Empty, Array_Comp);
else
Null_Exclusion_Static_Checks
(Obj_Decl, Comp_Decl, Array_Comp);
end if;
-- Check array components -- Check array components
...@@ -3724,10 +3733,10 @@ package body Sem_Ch3 is ...@@ -3724,10 +3733,10 @@ package body Sem_Ch3 is
-- 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
-- level. -- level. At the top level just indicate array component case.
if Comp_Decl = Obj_Decl then if Comp_Decl = Obj_Decl then
Check_Component (Component_Type (T)); Check_Component (Component_Type (T), Array_Comp => True);
else else
Check_Component (Component_Type (T), Comp_Decl); Check_Component (Component_Type (T), Comp_Decl);
end if; end if;
......
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