Commit a187206c by Arnaud Charlet

[multiple changes]

2017-04-25  Tristan Gingold  <gingold@adacore.com>

	* s-mmap.ads (Data): Add pragma Inline.

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

	* checks.adb (Insert_Valid_Check): Do not use
	a renaming to alias a volatile name because this will lead to
	multiple evaluations of the volatile name. Use a constant to
	capture the value instead.

2017-04-25  Doug Rupp  <rupp@adacore.com>

	* init.c [VxWorks Section]: Disable sigtramp for ppc64-vx7.

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

	* exp_util.adb, exp_util.ads (Build_Class_Wide_Expression):
	Add out parameter to indicate to caller that a wrapper must
	be constructed for an inherited primitive whose inherited
	pre/postcondition has called to overridden primitives.
	* freeze.adb (Check_Inherited_Conditions): Build wrapper body
	for inherited primitive that requires it.
	* sem_disp.adb (Check_Dispatching_Operation): Such wrappers are
	legal primitive operations and belong to the list of bodies
	generated after the freeze point of a type.
	* sem_prag.adb (Build_Pragma_Check_Equivalent): Use new signature
	of Build_Class_Wide_Expression.
	* sem_util.adb, sem_util.ads (Build_Overriding_Spec): New procedure
	to construct the specification of the wrapper subprogram created
	for an inherited operation.

From-SVN: r247140
parent 15fc8cb7
2017-04-25 Tristan Gingold <gingold@adacore.com>
* s-mmap.ads (Data): Add pragma Inline.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb (Insert_Valid_Check): Do not use
a renaming to alias a volatile name because this will lead to
multiple evaluations of the volatile name. Use a constant to
capture the value instead.
2017-04-25 Doug Rupp <rupp@adacore.com>
* init.c [VxWorks Section]: Disable sigtramp for ppc64-vx7.
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* exp_util.adb, exp_util.ads (Build_Class_Wide_Expression):
Add out parameter to indicate to caller that a wrapper must
be constructed for an inherited primitive whose inherited
pre/postcondition has called to overridden primitives.
* freeze.adb (Check_Inherited_Conditions): Build wrapper body
for inherited primitive that requires it.
* sem_disp.adb (Check_Dispatching_Operation): Such wrappers are
legal primitive operations and belong to the list of bodies
generated after the freeze point of a type.
* sem_prag.adb (Build_Pragma_Check_Equivalent): Use new signature
of Build_Class_Wide_Expression.
* sem_util.adb, sem_util.ads (Build_Overriding_Spec): New procedure
to construct the specification of the wrapper subprogram created
for an inherited operation.
2017-04-25 Bob Duff <duff@adacore.com>
* s-osinte-linux.ads (pthread_mutexattr_setprotocol,
......
......@@ -7210,17 +7210,18 @@ package body Checks is
end if;
-- Build the prefix for the 'Valid call. If the expression denotes
-- a name, use a renaming to alias it, otherwise use a constant to
-- capture the value of the expression.
-- a non-volatile name, use a renaming to alias it, otherwise use a
-- constant to capture the value of the expression.
-- Temp : ... renames Expr; -- reference to a name
-- Temp : ... renames Expr; -- non-volatile name
-- Temp : constant ... := Expr; -- all other cases
PV :=
Duplicate_Subexpr_No_Checks
(Exp => Exp,
Name_Req => False,
Renaming_Req => Is_Name_Reference (Exp),
Renaming_Req =>
Is_Name_Reference (Exp) and then not Is_Volatile (Typ),
Related_Id => Related_Id,
Is_Low_Bound => Is_Low_Bound,
Is_High_Bound => Is_High_Bound);
......
......@@ -1041,11 +1041,13 @@ package body Exp_Util is
---------------------------------
procedure Build_Class_Wide_Expression
(Prag : Node_Id;
Subp : Entity_Id;
Par_Subp : Entity_Id;
Adjust_Sloc : Boolean)
(Prag : Node_Id;
Subp : Entity_Id;
Par_Subp : Entity_Id;
Adjust_Sloc : Boolean;
Needs_Wrapper : out Boolean)
is
function Replace_Entity (N : Node_Id) return Traverse_Result;
-- Replace reference to formal of inherited operation or to primitive
-- operation of root type, with corresponding entity for derived type,
......@@ -1089,6 +1091,13 @@ package body Exp_Util is
if Present (New_E) then
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
-- If the entity is an overridden primitive, we must build
-- a wrapper for the current inherited operation.
if Is_Subprogram (New_E) then
Needs_Wrapper := True;
end if;
end if;
-- Check that there are no calls left to abstract operations if
......@@ -1156,6 +1165,8 @@ package body Exp_Util is
-- Start of processing for Build_Class_Wide_Expression
begin
Needs_Wrapper := False;
-- Add mapping from old formals to new formals
Par_Formal := First_Formal (Par_Subp);
......
......@@ -248,10 +248,11 @@ package Exp_Util is
-- not install a call to Abort_Defer.
procedure Build_Class_Wide_Expression
(Prag : Node_Id;
Subp : Entity_Id;
Par_Subp : Entity_Id;
Adjust_Sloc : Boolean);
(Prag : Node_Id;
Subp : Entity_Id;
Par_Subp : Entity_Id;
Adjust_Sloc : Boolean;
Needs_Wrapper : out Boolean);
-- Build the expression for an inherited class-wide condition. Prag is
-- the pragma constructed from the corresponding aspect of the parent
-- subprogram, and Subp is the overriding operation, and Par_Subp is
......@@ -264,6 +265,11 @@ package Exp_Util is
-- is the expression of the original class-wide aspect. In SPARK_Mode, such
-- operation which are just inherited but have modified pre/postconditions
-- are illegal.
-- If there are calls to overridden operations in the condition, and the
-- pragma applies to an inherited operation, a wrapper must be built for
-- it to capture the new inherited condition. The flag Needs_Wrapper is
-- set in that case so that the wrapper can be built, when the controlling
-- type is frozen.
function Build_DIC_Call
(Loc : Source_Ptr;
......
......@@ -55,6 +55,7 @@ with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Prag; use Sem_Prag;
......@@ -1395,17 +1396,22 @@ package body Freeze is
--------------------------------
procedure Check_Inherited_Conditions (R : Entity_Id) is
Prim_Ops : constant Elist_Id := Primitive_Operations (R);
A_Post : Node_Id;
A_Pre : Node_Id;
Op_Node : Elmt_Id;
Par_Prim : Entity_Id;
Prim : Entity_Id;
Prim_Ops : constant Elist_Id := Primitive_Operations (R);
A_Post : Node_Id;
A_Pre : Node_Id;
Decls : List_Id;
Op_Node : Elmt_Id;
Par_Prim : Entity_Id;
Par_Type : Entity_Id;
New_Prag : Node_Id;
Prim : Entity_Id;
Needs_Wrapper : Boolean;
begin
Op_Node := First_Elmt (Prim_Ops);
while Present (Op_Node) loop
Prim := Node (Op_Node);
Prim := Node (Op_Node);
Needs_Wrapper := False;
-- Map the overridden primitive to the overriding one. This takes
-- care of all overridings and is done only once.
......@@ -1446,9 +1452,12 @@ package body Freeze is
Op_Node := First_Elmt (Prim_Ops);
while Present (Op_Node) loop
Prim := Node (Op_Node);
Decls := Empty_List;
Prim := Node (Op_Node);
if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then
Par_Prim := Alias (Prim);
Par_Type := Find_Dispatching_Type (Par_Prim);
-- Analyze the contract items of the parent operation, before
-- they are rewritten when inherited.
......@@ -1458,24 +1467,116 @@ package body Freeze is
A_Pre := Get_Pragma (Par_Prim, Pragma_Precondition);
if Present (A_Pre) and then Class_Present (A_Pre) then
New_Prag := New_Copy_Tree (A_Pre);
Build_Class_Wide_Expression
(Prag => New_Copy_Tree (A_Pre),
Subp => Prim,
Par_Subp => Par_Prim,
Adjust_Sloc => False);
(Prag => New_Prag,
Subp => Prim,
Par_Subp => Par_Prim,
Adjust_Sloc => False,
Needs_Wrapper => Needs_Wrapper);
if Needs_Wrapper then
Append (New_Prag, Decls);
end if;
end if;
A_Post := Get_Pragma (Par_Prim, Pragma_Postcondition);
if Present (A_Post) and then Class_Present (A_Post) then
New_Prag := New_Copy_Tree (A_Pre);
Build_Class_Wide_Expression
(Prag => New_Copy_Tree (A_Post),
Subp => Prim,
Par_Subp => Par_Prim,
Adjust_Sloc => False);
(Prag => New_Prag,
Subp => Prim,
Par_Subp => Par_Prim,
Adjust_Sloc => False,
Needs_Wrapper => Needs_Wrapper);
if Needs_Wrapper then
Append (New_Prag, Decls);
end if;
end if;
end if;
if Needs_Wrapper and then not Is_Abstract_Subprogram (Par_Prim) then
-- We need to build a new primitive that overrides the inherited
-- one, and whose inherited expression has been updated above.
-- These expressions are the arguments of pragmas that are part
-- of the declarations of the wrapper. The wrapper holds a single
-- statement that is a call to the parent primitive, where the
-- controlling actuals are conversions to the corresponding type
-- in the parent primitive:
-- procedure New_Prim (F1 : T1.; ...) is
-- pragma Check (Precondition, Expr);
-- begin
-- Par_Prim (Par_Type (F1) ..);
-- end;
--
-- If the primitive is a function the statement is a call.
declare
Loc : constant Source_Ptr := Sloc (R);
Formal : Entity_Id;
Actuals : List_Id;
New_F_Spec : Node_Id;
New_Formal : Entity_Id;
New_Proc : Node_Id;
New_Spec : Node_Id;
Call : Node_Id;
begin
Actuals := Empty_List;
New_Spec := Build_Overriding_Spec (Par_Prim, R);
Formal := First_Formal (Par_Prim);
New_F_Spec := First (Parameter_Specifications (New_Spec));
while Present (Formal) loop
New_Formal := Defining_Identifier (New_F_Spec);
-- If controlling argument, add conversion.
if Etype (Formal) = Par_Type then
Append_To (Actuals,
Make_Type_Conversion (Loc,
New_Occurrence_Of (Par_Type, Loc),
New_Occurrence_Of (New_Formal, Loc)));
else
Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
end if;
Next_Formal (Formal);
Next (New_F_Spec);
end loop;
if Ekind (Par_Prim) = E_Procedure then
Call := Make_Procedure_Call_Statement (Loc,
Parameter_Associations => Actuals,
Name => New_Occurrence_Of (Par_Prim, Loc));
else
Call := Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Parameter_Associations => Actuals,
Name => New_Occurrence_Of (Par_Prim, Loc)));
end if;
New_Proc := Make_Subprogram_Body (Loc,
Specification => New_Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call),
End_Label => Make_Identifier (Loc, Chars (Prim))));
Insert_After (Parent (R), New_Proc);
Analyze (New_Proc);
end;
Needs_Wrapper := False;
end if;
Next_Elmt (Op_Node);
end loop;
end Check_Inherited_Conditions;
......
......@@ -2005,7 +2005,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc)
sigdelset (&mask, sig);
sigprocmask (SIG_SETMASK, &mask, NULL);
#if defined (__ARMEL__) || defined (__PPC__) || defined (__i386__) || defined (__x86_64__)
#if defined (__ARMEL__) || (defined (__PPC__) && !defined (__PPC64__)) || defined (__i386__) || defined (__x86_64__)
/* On certain targets, kernel mode, we process signals through a Call Frame
Info trampoline, voiding the need for myriads of fallback_frame_state
variants in the ZCX runtime. We have no simple way to distinguish ZCX
......
......@@ -223,11 +223,13 @@ package System.Mmap is
-- (File); such accesses may cause Storage_Error to be raised.
function Data (Region : Mapped_Region) return Str_Access;
pragma Inline (Data);
-- The data mapped in Region as requested. The result is an unconstrained
-- string, so you cannot use the usual 'First and 'Last attributes.
-- Instead, these are respectively 1 and Size.
function Data (File : Mapped_File) return Str_Access;
pragma Inline (Data);
-- Likewise for the region contained in File
function Is_Mutable (Region : Mapped_Region) return Boolean;
......
......@@ -1090,6 +1090,11 @@ package body Sem_Disp is
-- 3. Subprograms associated with stream attributes (built by
-- New_Stream_Subprogram)
-- 4. Wrapper built for inherited operations with inherited class-
-- wide conditions, where the conditions include calls to other
-- overridden primitives. The wrappers include checks on these
-- modified conditions. (AI12-113).
if Present (Old_Subp)
and then Present (Overridden_Operation (Subp))
and then Is_Dispatching_Operation (Old_Subp)
......@@ -1098,14 +1103,18 @@ package body Sem_Disp is
((Ekind (Subp) = E_Function
and then Is_Dispatching_Operation (Old_Subp)
and then Is_Null_Extension (Base_Type (Etype (Subp))))
or else
(Ekind (Subp) = E_Procedure
and then Is_Dispatching_Operation (Old_Subp)
and then Present (Alias (Old_Subp))
and then Is_Null_Interface_Primitive
(Ultimate_Alias (Old_Subp)))
or else Get_TSS_Name (Subp) = TSS_Stream_Read
or else Get_TSS_Name (Subp) = TSS_Stream_Write);
or else Get_TSS_Name (Subp) = TSS_Stream_Write
or else Present (Contract (Overridden_Operation (Subp))));
Check_Controlling_Formals (Tagged_Type, Subp);
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
......
......@@ -27017,6 +27017,9 @@ package body Sem_Prag is
Inher_Id : Entity_Id := Empty;
Keep_Pragma_Id : Boolean := False) return Node_Id
is
Needs_Wrapper : Boolean;
pragma Unreferenced (Needs_Wrapper);
function Suppress_Reference (N : Node_Id) return Traverse_Result;
-- Detect whether node N references a formal parameter subject to
-- pragma Unreferenced. If this is the case, set Comes_From_Source
......@@ -27085,7 +27088,8 @@ package body Sem_Prag is
-- Build the inherited class-wide condition
Build_Class_Wide_Expression
(Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True);
(Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True,
Needs_Wrapper => Needs_Wrapper);
-- If not an inherited condition simply copy the original pragma
......@@ -1581,6 +1581,40 @@ package body Sem_Util is
Set_Etype (Expr, Designated_Type (Etype (Disc)));
end Build_Explicit_Dereference;
---------------------------
-- Build_Overriding_Spec --
---------------------------
function Build_Overriding_Spec
(Op : Entity_Id;
Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op);
Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op));
Formal_Spec : Node_Id;
Formal_Type : Node_Id;
New_Spec : Node_Id;
begin
New_Spec := Copy_Subprogram_Spec (Spec);
Formal_Spec := First (Parameter_Specifications (New_Spec));
while Present (Formal_Spec) loop
Formal_Type := Parameter_Type (Formal_Spec);
if Is_Entity_Name (Formal_Type)
and then Entity (Formal_Type) = Par_Typ
then
Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc));
end if;
-- Nothing needs to be done for access parameters.
Next (Formal_Spec);
end loop;
return New_Spec;
end Build_Overriding_Spec;
-----------------------------------
-- Cannot_Raise_Constraint_Error --
-----------------------------------
......
......@@ -227,6 +227,14 @@ package Sem_Util is
-- the compilation unit, and install it in the Elaboration_Entity field
-- of Spec_Id, the entity for the compilation unit.
function Build_Overriding_Spec
(Op : Node_Id;
Typ : Entity_Id) return Node_Id;
-- Build a subprogram specification for the wrapper of an inherited
-- operation with a modified pre- or postcondition (See AI12-0113).
-- Op is the parent operation, and Typ is the descendant type that
-- inherits the operation.
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id);
......
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