+2013-09-10 Yannick Moy <moy@adacore.com>
+
+ * sinfo.ads: Document splitting of pre/post in N_Contract description.
+
+2013-09-10 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Multiply): If the operation is of the
+ form X * 2 ** N and it has been marked Is_Power_Of_2_For_Shift,
+ add a mod operation if the result type is a binary modular type.
+
+2013-09-10 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Add local
+ variable Context. Remove local variable Subp_Id. Start the
+ context traversal from the current subprogram rather than the
+ current scope. Update the scope traversal and error reporting.
+
+2013-09-10 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Timed_Entry_Call): New procedure
+ Rewrite_Triggering_Statements, to encapsulate the statements that
+ follow the trigger of the entry call. This procedure is needed
+ when the trigger is a dispatching call, because the expansion
+ requires several copies of those statements. The procedure is
+ more efficient, and preserves non-local references when the
+ construct is within an instance.
+
2013-09-10 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Analyze_Package_Instantiation): If the
return;
else
- Rewrite (N,
- Make_Op_Shift_Left (Loc,
- Left_Opnd => Lop,
- Right_Opnd =>
- Convert_To (Standard_Natural, Right_Opnd (Rop))));
+ -- If the result is modular, perform the reduction of the result
+ -- appropriately.
+
+ if Is_Modular_Integer_Type (Typ)
+ and then not Non_Binary_Modulus (Typ)
+ then
+ Rewrite (N,
+ Make_Op_And (Loc,
+ Left_Opnd =>
+ Make_Op_Shift_Left (Loc,
+ Left_Opnd => Lop,
+ Right_Opnd =>
+ Convert_To (Standard_Natural, Right_Opnd (Rop))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
+ else
+ Rewrite (N,
+ Make_Op_Shift_Left (Loc,
+ Left_Opnd => Lop,
+ Right_Opnd =>
+ Convert_To (Standard_Natural, Right_Opnd (Rop))));
+ end if;
+
Analyze_And_Resolve (N, Typ);
return;
end if;
-- Same processing for the operands the other way round
elsif Lp2 then
- Rewrite (N,
- Make_Op_Shift_Left (Loc,
- Left_Opnd => Rop,
- Right_Opnd =>
- Convert_To (Standard_Natural, Right_Opnd (Lop))));
+ if Is_Modular_Integer_Type (Typ)
+ and then not Non_Binary_Modulus (Typ)
+ then
+ Rewrite (N,
+ Make_Op_And (Loc,
+ Left_Opnd =>
+ Make_Op_Shift_Left (Loc,
+ Left_Opnd => Rop,
+ Right_Opnd =>
+ Convert_To (Standard_Natural, Right_Opnd (Lop))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
+ else
+ Rewrite (N,
+ Make_Op_Shift_Left (Loc,
+ Left_Opnd => Rop,
+ Right_Opnd =>
+ Convert_To (Standard_Natural, Right_Opnd (Lop))));
+ end if;
+
Analyze_And_Resolve (N, Typ);
return;
end if;
-- end;
-- The triggering statement and the sequence of timed statements have not
- -- been analyzed yet (see Analyzed_Timed_Entry_Call). They may contain
- -- local declarations, and therefore the copies that are made during
- -- expansion must be disjoint, as for any other inlining.
+ -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
+ -- global references if within an instantiation. To prevent duplication
+ -- between various uses of those statements, they are encapsulated into a
+ -- local procedure which is invoked multiple time when the trigger is a
+ -- dispatching call.
procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
P : Entity_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
+ procedure Rewrite_Triggering_Statements;
+ -- If the trigger is a dispatching call, the expansion inserts multiple
+ -- copies of the abortable part. This is both inefficient, and may lead
+ -- to duplicate definitions that the back-end will reject, when the
+ -- abortable part includes loops. This procedure rewrites the abortable
+ -- part into a call to a generated procedure.
+
+ -----------------------------------
+ -- Rewrite_Triggering_Statements --
+ -----------------------------------
+
+ procedure Rewrite_Triggering_Statements is
+ Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
+ Decl : Node_Id;
+ Stat : Node_Id;
+
+ begin
+ Decl :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, E_Stats));
+
+ Append_To (Decls, Decl);
+
+ -- Adjust the scope of blocks in the procedure. Needed because blocks
+ -- generate declarations that are processed before other analysis
+ -- takes place, and their scope is already set. The backend depends
+ -- on the scope chain to determine the legality of some anonymous
+ -- types, and thus we must indicate that the block is within the new
+ -- procedure.
+
+ Stat := First (E_Stats);
+ while Present (Stat) loop
+ if Nkind (Stat) = N_Block_Statement then
+ Insert_Before (Stat,
+ Make_Implicit_Label_Declaration (Sloc (Stat),
+ Defining_Identifier =>
+ Make_Defining_Identifier (
+ Sloc (Stat), Chars (Identifier (Stat)))));
+ end if;
+
+ Next (Stat);
+ end loop;
+
+ -- Analyze (Decl);
+
+ -- Rewrite abortable part into a call to this procedure.
+
+ E_Stats :=
+ New_List
+ (Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc, Loc)));
+ end Rewrite_Triggering_Statements;
+
begin
-- Under the Ravenscar profile, timed entry calls are excluded. An error
-- was already reported on spec, so do not attempt to expand the call.
if Is_Disp_Select then
Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
-
Decls := New_List;
+ Rewrite_Triggering_Statements;
+
Stmts := New_List;
-- Generate:
-- <timed-statements>
-- end if;
- N_Stats := Copy_Separate_List (E_Stats);
+ N_Stats := New_Copy_List_Tree (E_Stats);
Prepend_To (N_Stats,
Make_Implicit_If_Statement (N,
-- <dispatching-call>;
-- <triggering-statements>
- Lim_Typ_Stmts := Copy_Separate_List (E_Stats);
+ Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
-- Generate:
(Item : Node_Id;
Item_Id : Entity_Id)
is
+ Context : Entity_Id;
Dummy : Boolean;
Inputs : Elist_Id := No_Elist;
Outputs : Elist_Id := No_Elist;
- Subp_Id : Entity_Id;
begin
-- Traverse the scope stack looking for enclosing subprograms
-- subject to aspect/pragma Global.
- Subp_Id := Scope (Current_Scope);
- while Present (Subp_Id) and then Subp_Id /= Standard_Standard loop
- if Is_Subprogram (Subp_Id)
- and then Has_Aspect (Subp_Id, Aspect_Global)
+ Context := Scope (Subp_Id);
+ while Present (Context)
+ and then Context /= Standard_Standard
+ loop
+ if Is_Subprogram (Context)
+ and then Has_Aspect (Context, Aspect_Global)
then
Collect_Subprogram_Inputs_Outputs
- (Subp_Id => Subp_Id,
+ (Subp_Id => Context,
Subp_Inputs => Inputs,
Subp_Outputs => Outputs,
Global_Seen => Dummy);
Item, Item_Id);
Error_Msg_NE
("\item already appears as input of subprogram &",
- Item, Subp_Id);
+ Item, Context);
+
+ -- Stop the traversal once an error has been detected
+
+ exit;
end if;
end if;
- Subp_Id := Scope (Subp_Id);
+ Context := Scope (Context);
end loop;
end Check_Mode_Restriction_In_Enclosing_Context;
-- The pragmas can either come from source or be the byproduct of aspect
-- expansion. The ordering in the list is of LIFO fashion.
+ -- Note that there might be multiple preconditions (resp.
+ -- postconditions) in this list, either because they come from
+ -- separate pragmas in the source, or because a Pre (resp. Post) aspect
+ -- specification has been broken into AND THEN sections. See Split_PPC
+ -- for details.
+
-- Contract_Test_Cases contains a collection of pragmas that correspond
-- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the
-- list is of LIFO fashion.