+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,
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);
---------------------------------
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,
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
-- 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);
-- 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
-- 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;
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;
--------------------------------
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.
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.
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;
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
-- (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;
-- 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)
((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);
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
-- 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
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 --
-----------------------------------
-- 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);
projects / gcc.git / commitdiff