Commit 321c24f7 by Arnaud Charlet

[multiple changes]

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): Move
	Has_Non_Trivial_Precondition to sem_util. for use elsewhere.
	Improve error message on operations that inherit non-conforming
	classwide preconditions from ancestor and progenitor.
	* sem_util.ads, sem_util.adb (Has_Non_Trivial_Precondition):
	moved here from sem_ch3.
	* sem_ch8.adb (Analyze_Subprogram_Renaming): Implement legality
	check given in RM 6.1.1 (17) concerning renamings of overriding
	operations that inherits class-wide preconditions from ancestor
	or progenitor.

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Code cleanup.
	(Build_Adjust_Statements): Code cleanup.
	(Build_Finalizer): Update the initialization of
	Exceptions_OK.
	(Build_Finalize_Statements): Code cleanup.
	(Build_Initialize_Statements): Code cleanup.
	(Make_Deep_Array_Body): Update the initialization of
	Exceptions_OK.
	(Make_Deep_Record_Body): Update the initialization of Exceptions_OK.
	(Process_Object_Declaration): Generate a null exception handler only
	when exceptions are allowed.
	(Process_Transients_In_Scope): Update the initialization of
	Exceptions_OK.
	* exp_util.ads, exp_util.adb (Exceptions_In_Finalization_OK): New
	routine.
	* sem_ch11.adb (Analyze_Exception_Handlers): Do not check any
	restrictions when the handler is internally generated and the
	mode is warnings.

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Has_Non_Trivial_Precondition): New predicate to
	enforce legality rule on classwide preconditions inherited from
	both an ancestor and a progenitor (RM 6.1.1 (10-13).
	* sem_disp.adb (Check_Dispatching_Context): A call to an abstract
	subprogram need not be dispatching if it appears in a precondition
	for an abstract or null subprogram.

2017-04-25  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch10.adb: Minor typo fix.

From-SVN: r247192
parent 6948bc18
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Add_Internal_Interface_Entities): Move
Has_Non_Trivial_Precondition to sem_util. for use elsewhere.
Improve error message on operations that inherit non-conforming
classwide preconditions from ancestor and progenitor.
* sem_util.ads, sem_util.adb (Has_Non_Trivial_Precondition):
moved here from sem_ch3.
* sem_ch8.adb (Analyze_Subprogram_Renaming): Implement legality
check given in RM 6.1.1 (17) concerning renamings of overriding
operations that inherits class-wide preconditions from ancestor
or progenitor.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Code cleanup.
(Build_Adjust_Statements): Code cleanup.
(Build_Finalizer): Update the initialization of
Exceptions_OK.
(Build_Finalize_Statements): Code cleanup.
(Build_Initialize_Statements): Code cleanup.
(Make_Deep_Array_Body): Update the initialization of
Exceptions_OK.
(Make_Deep_Record_Body): Update the initialization of Exceptions_OK.
(Process_Object_Declaration): Generate a null exception handler only
when exceptions are allowed.
(Process_Transients_In_Scope): Update the initialization of
Exceptions_OK.
* exp_util.ads, exp_util.adb (Exceptions_In_Finalization_OK): New
routine.
* sem_ch11.adb (Analyze_Exception_Handlers): Do not check any
restrictions when the handler is internally generated and the
mode is warnings.
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Has_Non_Trivial_Precondition): New predicate to
enforce legality rule on classwide preconditions inherited from
both an ancestor and a progenitor (RM 6.1.1 (10-13).
* sem_disp.adb (Check_Dispatching_Context): A call to an abstract
subprogram need not be dispatching if it appears in a precondition
for an abstract or null subprogram.
2017-04-25 Gary Dismukes <dismukes@adacore.com>
* sem_ch10.adb: Minor typo fix.
2017-04-25 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Makefile.in: Cleanup VxWorks targets.
......
......@@ -1327,8 +1327,7 @@ package body Exp_Ch7 is
or else
(Present (Clean_Stmts)
and then Is_Non_Empty_List (Clean_Stmts));
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
For_Package : constant Boolean :=
......@@ -2844,7 +2843,7 @@ package body Exp_Ch7 is
Body_Ins : Node_Id;
Count_Ins : Node_Id;
Fin_Call : Node_Id;
Fin_Stmts : List_Id;
Fin_Stmts : List_Id := No_List;
Inc_Decl : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
......@@ -3004,8 +3003,6 @@ package body Exp_Ch7 is
-- manual finalization of their lock managers.
if Is_Protected then
Fin_Stmts := No_List;
if Is_Simple_Protected_Type (Obj_Typ) then
Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
......@@ -3031,8 +3028,8 @@ package body Exp_Ch7 is
-- null;
-- end;
if Present (Fin_Stmts) then
Append_To (Finalizer_Stmts,
if Present (Fin_Stmts) and then Exceptions_OK then
Fin_Stmts := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
......@@ -4866,8 +4863,7 @@ package body Exp_Ch7 is
Last_Object : Node_Id;
Related_Node : Node_Id)
is
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
Must_Hook : Boolean := False;
-- Flag denoting whether the context requires transient object
......@@ -5529,6 +5525,8 @@ package body Exp_Ch7 is
(Prim : Final_Primitives;
Typ : Entity_Id) return List_Id
is
Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
function Build_Adjust_Or_Finalize_Statements
(Typ : Entity_Id) return List_Id;
-- Create the statements necessary to adjust or finalize an array of
......@@ -5646,8 +5644,6 @@ package body Exp_Ch7 is
(Typ : Entity_Id) return List_Id
is
Comp_Typ : constant Entity_Id := Component_Type (Typ);
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Index_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
Num_Dims : constant Int := Number_Dimensions (Typ);
......@@ -5823,8 +5819,6 @@ package body Exp_Ch7 is
function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
Comp_Typ : constant Entity_Id := Component_Type (Typ);
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Final_List : constant List_Id := New_List;
Index_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
......@@ -6349,6 +6343,8 @@ package body Exp_Ch7 is
Typ : Entity_Id;
Is_Local : Boolean := False) return List_Id
is
Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
-- Build the statements necessary to adjust a record type. The type may
-- have discriminants and contain variant parts. Generate:
......@@ -6498,17 +6494,10 @@ package body Exp_Ch7 is
-----------------------------
function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id :=
Type_Definition (Parent (Typ));
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
Bod_Stmts : List_Id;
Finalizer_Data : Finalization_Exception_Data;
Finalizer_Decls : List_Id := No_List;
Rec_Def : Node_Id;
Var_Case : Node_Id;
function Process_Component_List_For_Adjust
(Comps : Node_Id) return List_Id;
......@@ -6581,6 +6570,7 @@ package body Exp_Ch7 is
Decl_Typ : Entity_Id;
Has_POC : Boolean;
Num_Comps : Nat;
Var_Case : Node_Id;
-- Start of processing for Process_Component_List_For_Adjust
......@@ -6710,6 +6700,12 @@ package body Exp_Ch7 is
return Stmts;
end Process_Component_List_For_Adjust;
-- Local variables
Bod_Stmts : List_Id;
Finalizer_Decls : List_Id := No_List;
Rec_Def : Node_Id;
-- Start of processing for Build_Adjust_Statements
begin
......@@ -6914,18 +6910,12 @@ package body Exp_Ch7 is
-------------------------------
function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id :=
Type_Definition (Parent (Typ));
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
Bod_Stmts : List_Id;
Counter : Int := 0;
Finalizer_Data : Finalization_Exception_Data;
Finalizer_Decls : List_Id := No_List;
Rec_Def : Node_Id;
Var_Case : Node_Id;
Num_Comps : Nat := 0;
function Process_Component_List_For_Finalize
(Comps : Node_Id) return List_Id;
......@@ -6940,19 +6930,6 @@ package body Exp_Ch7 is
function Process_Component_List_For_Finalize
(Comps : Node_Id) return List_Id
is
Alts : List_Id;
Counter_Id : Entity_Id;
Decl : Node_Id;
Decl_Id : Entity_Id;
Decl_Typ : Entity_Id;
Decls : List_Id;
Has_POC : Boolean;
Jump_Block : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
Num_Comps : Nat;
Stmts : List_Id;
procedure Process_Component_For_Finalize
(Decl : Node_Id;
Alts : List_Id;
......@@ -7066,6 +7043,21 @@ package body Exp_Ch7 is
end if;
end Process_Component_For_Finalize;
-- Local variables
Alts : List_Id;
Counter_Id : Entity_Id;
Decl : Node_Id;
Decl_Id : Entity_Id;
Decl_Typ : Entity_Id;
Decls : List_Id;
Has_POC : Boolean;
Jump_Block : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
Stmts : List_Id;
Var_Case : Node_Id;
-- Start of processing for Process_Component_List_For_Finalize
begin
......@@ -7286,6 +7278,12 @@ package body Exp_Ch7 is
end if;
end Process_Component_List_For_Finalize;
-- Local variables
Bod_Stmts : List_Id;
Finalizer_Decls : List_Id := No_List;
Rec_Def : Node_Id;
-- Start of processing for Build_Finalize_Statements
begin
......
......@@ -4784,6 +4784,18 @@ package body Exp_Util is
end if;
end Evolve_Or_Else;
-----------------------------------
-- Exceptions_In_Finalization_OK --
-----------------------------------
function Exceptions_In_Finalization_OK return Boolean is
begin
return
not (Restriction_Active (No_Exception_Handlers) or else
Restriction_Active (No_Exception_Propagation) or else
Restriction_Active (No_Exceptions));
end Exceptions_In_Finalization_OK;
-----------------------------------------
-- Expand_Static_Predicates_In_Choices --
-----------------------------------------
......
......@@ -535,6 +535,10 @@ package Exp_Util is
-- indicating that no checks were required). The Sloc field of the
-- constructed N_Or_Else node is copied from Cond1.
function Exceptions_In_Finalization_OK return Boolean;
-- Determine whether the finalization machinery can safely add exception
-- handlers and recovery circuitry.
procedure Expand_Static_Predicates_In_Choices (N : Node_Id);
-- N is either a case alternative or a variant. The Discrete_Choices field
-- of N points to a list of choices. If any of these choices is the name
......
......@@ -1134,7 +1134,7 @@ package body Sem_Ch10 is
Style_Check := Save_Style_Check;
end;
-- In GNATprove mode, force the loading of a Interrupt_Priority when
-- In GNATprove mode, force the loading of an Interrupt_Priority when
-- processing compilation units with potentially "main" subprograms.
-- This is required for the ceiling priority protocol checks, which
-- are triggered by these subprograms.
......
......@@ -165,8 +165,24 @@ package body Sem_Ch11 is
begin
Handler := First (L);
-- Pragma Restriction_Warnings has more related semantics than pragma
-- Restrictions in that it flags exception handlers as violators. Note
-- that the compiler must still generate handlers for certain critical
-- scenarios such as finalization. As a result, these handlers should
-- not be subjected to the restriction check when in warnings mode.
if not Comes_From_Source (Handler)
and then (Restriction_Warnings (No_Exception_Handlers)
or else Restriction_Warnings (No_Exception_Propagation)
or else Restriction_Warnings (No_Exceptions))
then
null;
else
Check_Restriction (No_Exceptions, Handler);
Check_Restriction (No_Exception_Handlers, Handler);
end if;
-- Kill current remembered values, since we don't know where we were
-- when the exception was raised.
......
......@@ -1717,6 +1717,43 @@ package body Sem_Ch3 is
Derived_Type => Tagged_Type,
Parent_Type => Iface);
declare
Anc : Entity_Id;
begin
if Is_Inherited_Operation (Prim)
and then Present (Alias (Prim))
then
Anc := Alias (Prim);
else
Anc := Overridden_Operation (Prim);
end if;
-- Apply legality checks in RM 6.1.1 (10-13) concerning
-- non-conforming preconditions in both an ancestor and
-- a progenitor operation.
if Present (Anc)
and then Has_Non_Trivial_Precondition (Anc)
and then Has_Non_Trivial_Precondition (Iface_Prim)
then
if Is_Abstract_Subprogram (Prim)
or else (Ekind (Prim) = E_Procedure
and then
Nkind (Parent (Prim)) = N_Procedure_Specification
and then Null_Present (Parent (Prim)))
then
null;
-- The inherited operation must be overridden
elsif not Comes_From_Source (Prim) then
Error_Msg_NE ("&inherits non-conforming preconditions "
& "and must be overridden (RM 6.1.1 (10-16)",
Parent (Tagged_Type), Prim);
end if;
end if;
end;
-- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
-- associated with interface types. These entities are
-- only registered in the list of primitives of its
......
......@@ -3191,6 +3191,19 @@ package body Sem_Ch8 is
("renamed entity cannot be subprogram that requires overriding "
& "(RM 8.5.4 (5.1))", N);
end if;
declare
Prev : constant Entity_Id := Overridden_Operation (New_S);
begin
if Present (Prev)
and then
(Has_Non_Trivial_Precondition (Prev)
or else Has_Non_Trivial_Precondition (Old_S))
then
Error_Msg_NE ("conflicting inherited classwide preconditions "
& "in renaming of& (RM 6.1.1 (17)", N, Old_S);
end if;
end;
end if;
if Old_S /= Any_Id then
......
......@@ -574,9 +574,7 @@ package body Sem_Disp is
-- a primitive of an abstract type. The call is non-dispatching
-- but will be legal in overridings of the operation.
elsif In_Spec_Expression
and then
(Is_Subprogram (Scop)
elsif (Is_Subprogram (Scop)
or else Chars (Scop) = Name_Postcondition)
and then
(Is_Abstract_Subprogram (Scop)
......
......@@ -9820,6 +9820,18 @@ package body Sem_Util is
and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
end Has_Non_Null_Refinement;
----------------------------------
-- Has_Non_Trivial_Precondition --
----------------------------------
function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean is
Cont : constant Node_Id := Find_Aspect (P, Aspect_Pre);
begin
return Present (Cont)
and then Class_Present (Cont)
and then not Is_Entity_Name (Expression (Cont));
end Has_Non_Trivial_Precondition;
-------------------
-- Has_Null_Body --
-------------------
......
......@@ -1169,6 +1169,10 @@ package Sem_Util is
-- null statement, possibly followed by an optional return. Used to
-- optimize useless calls to assertion checks.
function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean;
-- True if subprogram has a class-wide precondition that is not
-- statically True.
function Has_Null_Exclusion (N : Node_Id) return Boolean;
-- Determine whether node N has a null exclusion
......
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