+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.
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 :=
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;
-- 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);
-- 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,
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
(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
function Build_Adjust_Or_Finalize_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);
- Index_List : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (Typ);
- Num_Dims : constant Int := Number_Dimensions (Typ);
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Index_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Num_Dims : constant Int := Number_Dimensions (Typ);
procedure Build_Indexes;
-- Generate the indexes used in the dimension loops
---------------------------------
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);
- Num_Dims : constant Int := Number_Dimensions (Typ);
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Final_List : constant List_Id := New_List;
+ Index_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Num_Dims : constant Int := Number_Dimensions (Typ);
function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
-- Generate the following assignment:
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:
-----------------------------
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));
+ Loc : constant Source_Ptr := Sloc (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;
+ Finalizer_Data : Finalization_Exception_Data;
function Process_Component_List_For_Adjust
(Comps : Node_Id) return List_Id;
Decl_Typ : Entity_Id;
Has_POC : Boolean;
Num_Comps : Nat;
+ Var_Case : Node_Id;
-- Start of processing for Process_Component_List_For_Adjust
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
-------------------------------
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));
+ Loc : constant Source_Ptr := Sloc (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;
+ Counter : Int := 0;
+ Finalizer_Data : Finalization_Exception_Data;
+ Num_Comps : Nat := 0;
function Process_Component_List_For_Finalize
(Comps : Node_Id) return List_Id;
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;
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
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
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 --
-----------------------------------------
-- 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
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.
begin
Handler := First (L);
- Check_Restriction (No_Exceptions, Handler);
- Check_Restriction (No_Exception_Handlers, Handler);
+
+ -- 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.
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
("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
-- 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)
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 --
-------------------
-- 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
git://gcc.gnu.org / gcc.git / commitdiff