Index: exp_prag.adb =================================================================== --- exp_prag.adb (revision 194188) +++ exp_prag.adb (working copy) @@ -69,7 +69,7 @@ procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); - procedure Expand_Pragma_Loop_Assertion (N : Node_Id); + procedure Expand_Pragma_Loop_Variant (N : Node_Id); procedure Expand_Pragma_Psect_Object (N : Node_Id); procedure Expand_Pragma_Relative_Deadline (N : Node_Id); @@ -191,8 +191,8 @@ when Pragma_Interrupt_Priority => Expand_Pragma_Interrupt_Priority (N); - when Pragma_Loop_Assertion => - Expand_Pragma_Loop_Assertion (N); + when Pragma_Loop_Variant => + Expand_Pragma_Loop_Variant (N); when Pragma_Psect_Object => Expand_Pragma_Psect_Object (N); @@ -795,20 +795,19 @@ end if; end Expand_Pragma_Interrupt_Priority; - ---------------------------------- - -- Expand_Pragma_Loop_Assertion -- - ---------------------------------- + -------------------------------- + -- Expand_Pragma_Loop_Variant -- + -------------------------------- - -- Pragma Loop_Assertion is expanded in the following manner: + -- Pragma Loop_Variant is expanded in the following manner: -- Original code -- for | while ... loop -- - -- pragma Loop_Assertion - -- (Invariant => Invar_Expr, - -- Variant => (Increasing => Incr_Expr, - -- Decreasing => Decr_Expr)); + -- pragma Loop_Variant + -- (Increases => Incr_Expr, + -- Decreases => Decr_Expr); -- -- end loop; @@ -823,8 +822,6 @@ -- for | while ... loop -- - -- pragma Assert (); - -- if Flag then -- Old_1 := Curr_1; -- Old_2 := Curr_2; @@ -846,7 +843,9 @@ -- -- end loop; - procedure Expand_Pragma_Loop_Assertion (N : Node_Id) is + procedure Expand_Pragma_Loop_Variant (N : Node_Id) is + Last_Var : constant Node_Id := + Last (Pragma_Argument_Associations (N)); Loc : constant Source_Ptr := Sloc (N); Curr_Assign : List_Id := No_List; Flag_Id : Entity_Id := Empty; @@ -854,27 +853,23 @@ Loop_Scop : Entity_Id; Loop_Stmt : Node_Id; Old_Assign : List_Id := No_List; + Variant : Node_Id; - procedure Process_Increase_Decrease - (Variant : Node_Id; - Is_Last : Boolean); + procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean); -- Process a single increasing / decreasing termination variant. Flag -- Is_Last should be set when processing the last variant. - ------------------------------- - -- Process_Increase_Decrease -- - ------------------------------- + --------------------- + -- Process_Variant -- + --------------------- - procedure Process_Increase_Decrease - (Variant : Node_Id; - Is_Last : Boolean) - is + procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is function Make_Op (Loc : Source_Ptr; Curr_Val : Node_Id; Old_Val : Node_Id) return Node_Id; -- Generate a comparison between Curr_Val and Old_Val depending on - -- the argument name (Increases / Decreases). + -- the change mode (Increases / Decreases) of the variant. ------------- -- Make_Op -- @@ -885,12 +880,11 @@ Curr_Val : Node_Id; Old_Val : Node_Id) return Node_Id is - Modif : constant Node_Id := First (Choices (Variant)); begin - if Chars (Modif) = Name_Increasing then + if Chars (Variant) = Name_Increases then return Make_Op_Gt (Loc, Curr_Val, Old_Val); - else pragma Assert (Chars (Modif) = Name_Decreasing); + else pragma Assert (Chars (Variant) = Name_Decreases); return Make_Op_Lt (Loc, Curr_Val, Old_Val); end if; end Make_Op; @@ -898,13 +892,14 @@ -- Local variables Expr : constant Node_Id := Expression (Variant); + Expr_Typ : constant Entity_Id := Etype (Expr); Loc : constant Source_Ptr := Sloc (Expr); Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt); Curr_Id : Entity_Id; Old_Id : Entity_Id; Prag : Node_Id; - -- Start of processing for Process_Increase_Decrease + -- Start of processing for Process_Variant begin -- All temporaries generated in this routine must be inserted before @@ -959,8 +954,7 @@ Insert_Action (Loop_Stmt, Make_Object_Declaration (Loop_Loc, Defining_Identifier => Curr_Id, - Object_Definition => - New_Reference_To (Etype (Expr), Loop_Loc))); + Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc))); -- Generate: -- Old : ; @@ -970,8 +964,7 @@ Insert_Action (Loop_Stmt, Make_Object_Declaration (Loop_Loc, Defining_Identifier => Old_Id, - Object_Definition => - New_Reference_To (Etype (Expr), Loop_Loc))); + Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc))); -- Restore original scope after all temporaries have been analyzed @@ -1066,13 +1059,8 @@ Right_Opnd => New_Reference_To (Old_Id, Loc)), Then_Statements => New_List (Prag))); end if; - end Process_Increase_Decrease; + end Process_Variant; - -- Local variables - - Arg : Node_Id; - Invar : Node_Id := Empty; - -- Start of processing for Expand_Pragma_Loop_Assertion begin @@ -1093,76 +1081,29 @@ Loop_Scop := Entity (Identifier (Loop_Stmt)); - -- Process all pragma arguments + -- Create the circuitry which verifies individual variants - Arg := First (Pragma_Argument_Associations (N)); - while Present (Arg) loop + Variant := First (Pragma_Argument_Associations (N)); + while Present (Variant) loop + Process_Variant (Variant, Is_Last => Variant = Last_Var); - -- Termination variants appear as components in an aggregate - - if Chars (Arg) = Name_Variant then - declare - Variants : constant Node_Id := Expression (Arg); - Last_Var : constant Node_Id := - Last (Component_Associations (Variants)); - Variant : Node_Id; - - begin - Variant := First (Component_Associations (Variants)); - while Present (Variant) loop - Process_Increase_Decrease - (Variant => Variant, - Is_Last => Variant = Last_Var); - - Next (Variant); - end loop; - end; - - -- Invariant - - else - Invar := Expression (Arg); - end if; - - Next (Arg); + Next (Variant); end loop; - -- Verify the invariant expression, generate: - -- pragma Assert (); - - -- Use the Sloc of the invariant for better error reporting - - if Present (Invar) then - declare - Invar_Loc : constant Source_Ptr := Sloc (Invar); - begin - Insert_Action (N, - Make_Pragma (Invar_Loc, - Chars => Name_Assert, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Invar_Loc, - Expression => Relocate_Node (Invar))))); - end; - end if; - -- Construct the segment which stores the old values of all expressions. -- Generate: -- if Flag then -- -- end if; - if Present (Old_Assign) then - Insert_Action (N, - Make_If_Statement (Loc, - Condition => New_Reference_To (Flag_Id, Loc), - Then_Statements => Old_Assign)); - end if; + Insert_Action (N, + Make_If_Statement (Loc, + Condition => New_Reference_To (Flag_Id, Loc), + Then_Statements => Old_Assign)); -- Update the values of all expressions - if Present (Curr_Assign) then - Insert_Actions (N, Curr_Assign); - end if; + Insert_Actions (N, Curr_Assign); -- Add the assertion circuitry to test all changes in expressions. -- Generate: @@ -1172,22 +1113,20 @@ -- Flag := True; -- end if; - if Present (If_Stmt) then - Insert_Action (N, - Make_If_Statement (Loc, - Condition => New_Reference_To (Flag_Id, Loc), - Then_Statements => New_List (If_Stmt), - Else_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Flag_Id, Loc), - Expression => New_Reference_To (Standard_True, Loc))))); - end if; + Insert_Action (N, + Make_If_Statement (Loc, + Condition => New_Reference_To (Flag_Id, Loc), + Then_Statements => New_List (If_Stmt), + Else_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Flag_Id, Loc), + Expression => New_Reference_To (Standard_True, Loc))))); -- Note: the pragma has been completely transformed into a sequence of -- corresponding declarations and statements. We leave it in the tree -- for documentation purposes. It will be ignored by the backend. - end Expand_Pragma_Loop_Assertion; + end Expand_Pragma_Loop_Variant; -------------------------------- -- Expand_Pragma_Psect_Object -- Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 194199) +++ sem_prag.adb (working copy) @@ -618,6 +618,10 @@ -- Common processing for first argument of pragma Interrupt_Handler or -- pragma Attach_Handler. + procedure Check_Loop_Invariant_Variant_Placement; + -- Verify whether pragma Loop_Invariant or pragma Loop_Variant appear + -- immediately within the statements of the related loop. + procedure Check_Is_In_Decl_Part_Or_Package_Spec; -- Check that pragma appears in a declarative part, or in a package -- specification, i.e. that it does not occur in a statement sequence @@ -1912,6 +1916,44 @@ end if; end Check_Interrupt_Or_Attach_Handler; + -------------------------------------------- + -- Check_Loop_Invariant_Variant_Placement -- + -------------------------------------------- + + procedure Check_Loop_Invariant_Variant_Placement is + Loop_Stmt : Node_Id; + + begin + -- Locate the enclosing loop statement (if any) + + Loop_Stmt := N; + while Present (Loop_Stmt) loop + if Nkind (Loop_Stmt) = N_Loop_Statement then + exit; + + -- Prevent the search from going too far + + elsif Nkind_In (Loop_Stmt, N_Entry_Body, + N_Package_Body, + N_Package_Declaration, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + Error_Pragma ("pragma % must appear inside a loop statement"); + return; + + else + Loop_Stmt := Parent (Loop_Stmt); + end if; + end loop; + + if List_Containing (N) /= Statements (Loop_Stmt) then + Error_Pragma + ("pragma % must occur immediately in the statements of a loop"); + end if; + end Check_Loop_Invariant_Variant_Placement; + ------------------------------------------- -- Check_Is_In_Decl_Part_Or_Package_Spec -- ------------------------------------------- @@ -11453,74 +11495,62 @@ end Long_Float; -------------------- - -- Loop_Assertion -- + -- Loop_Invariant -- -------------------- - -- pragma Loop_Assertion - -- ( [Invariant =>] boolean_Expression ); - -- | ( [[Invariant =>] boolean_Expression ,] - -- Variant => - -- ( TERMINATION_VARIANT {, TERMINATION_VARIANT ) ); + -- pragma Loop_Invariant ( boolean_EXPRESSION ); - -- TERMINATION_VARIANT ::= CHANGE_MODIFIER => discrete_EXPRESSION + when Pragma_Loop_Invariant => Loop_Invariant : declare + begin + GNAT_Pragma; + S14_Pragma; + Check_Arg_Count (1); + Check_Loop_Invariant_Variant_Placement; - -- CHANGE_MODIFIER ::= Increasing | Decreasing + -- Completely ignore if disabled - when Pragma_Loop_Assertion => Loop_Assertion : declare - procedure Check_Variant (Arg : Node_Id); - -- Verify the legality of a variant + if Check_Disabled (Pname) then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + return; + end if; - ------------------- - -- Check_Variant -- - ------------------- + Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean); - procedure Check_Variant (Arg : Node_Id) is - Expr : constant Node_Id := Expression (Arg); + -- Transform pagma Loop_Invariant into an equivalent pragma Check. + -- Generate: + -- pragma Check (Loop_Invaraint, Arg1); - begin - -- Variants appear in aggregate form + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Loop_Invariant)), + Relocate_Node (Arg1)))); - if Nkind (Expr) = N_Aggregate then - declare - Comp : Node_Id; - Extra : Node_Id; - Modif : Node_Id; + Analyze (N); + end Loop_Invariant; - begin - Comp := First (Component_Associations (Expr)); - while Present (Comp) loop - Modif := First (Choices (Comp)); - Extra := Next (Modif); + ------------------ + -- Loop_Variant -- + ------------------ - Check_Arg_Is_One_Of - (Modif, Name_Decreasing, Name_Increasing); + -- pragma Loop_Variant + -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } ); - if Present (Extra) then - Error_Pragma_Arg - ("only one modifier allowed in argument", Expr); - end if; + -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION - Preanalyze_And_Resolve - (Expression (Comp), Any_Discrete); + -- CHANGE_DIRECTION ::= Increases | Decreases - Next (Comp); - end loop; - end; - else - Error_Pragma_Arg - ("expression on variant must be an aggregate", Expr); - end if; - end Check_Variant; + when Pragma_Loop_Variant => Loop_Variant : declare + Variant : Node_Id; - -- Local variables - - Stmt : Node_Id; - - -- Start of processing for Loop_Assertion - begin GNAT_Pragma; S14_Pragma; + Check_At_Least_N_Arguments (1); + Check_Loop_Invariant_Variant_Placement; -- Completely ignore if disabled @@ -11530,57 +11560,22 @@ return; end if; - -- Verify that the pragma appears inside a loop + -- Process all increasing / decreasing expressions - Stmt := N; - while Present (Stmt) and then Nkind (Stmt) /= N_Loop_Statement loop - Stmt := Parent (Stmt); - end loop; + Variant := First (Pragma_Argument_Associations (N)); + while Present (Variant) loop + if Chars (Variant) /= Name_Decreases + and then Chars (Variant) /= Name_Increases + then + Error_Pragma_Arg ("wrong change modifier", Variant); + end if; - if No (Stmt) then - Error_Pragma ("pragma % must appear inside a loop"); - end if; + Preanalyze_And_Resolve (Expression (Variant), Any_Discrete); - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (2); + Next (Variant); + end loop; + end Loop_Variant; - -- Process the first argument - - if Chars (Arg1) = Name_Variant then - Check_Variant (Arg1); - - elsif Chars (Arg1) = No_Name - or else Chars (Arg1) = Name_Invariant - then - Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean); - - else - Error_Pragma_Arg ("argument not allowed in pragma %", Arg1); - end if; - - -- Process the second argument - - if Present (Arg2) then - if Chars (Arg2) = Name_Variant then - if Chars (Arg1) = Name_Variant then - Error_Pragma ("only one variant allowed in pragma %"); - else - Check_Variant (Arg2); - end if; - - elsif Chars (Arg2) = Name_Invariant then - if Chars (Arg1) = Name_Variant then - Error_Pragma_Arg ("invariant must precede variant", Arg2); - else - Error_Pragma ("only one invariant allowed in pragma %"); - end if; - - else - Error_Pragma_Arg ("argument not allowed in pragma %", Arg2); - end if; - end if; - end Loop_Assertion; - ----------------------- -- Machine_Attribute -- ----------------------- @@ -15707,7 +15702,8 @@ Pragma_Lock_Free => -1, Pragma_Locking_Policy => -1, Pragma_Long_Float => -1, - Pragma_Loop_Assertion => -1, + Pragma_Loop_Invariant => -1, + Pragma_Loop_Variant => -1, Pragma_Machine_Attribute => -1, Pragma_Main => -1, Pragma_Main_Storage => -1, Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 194202) +++ sem_attr.adb (working copy) @@ -3795,15 +3795,17 @@ Stmt := N; while Present (Stmt) loop - -- Locate the enclosing Loop_Assertion pragma (if any). Note that - -- when Loop_Assertion is expanded, we must look for an Assertion - -- pragma. + -- Locate the enclosing Loop_Invariant / Loop_Variant pragma (if + -- any). Note that when these two are expanded, we must look for + -- an Assertion pragma. if Nkind (Original_Node (Stmt)) = N_Pragma and then (Pragma_Name (Original_Node (Stmt)) = Name_Assert or else - Pragma_Name (Original_Node (Stmt)) = Name_Loop_Assertion) + Pragma_Name (Original_Node (Stmt)) = Name_Loop_Invariant + or else + Pragma_Name (Original_Node (Stmt)) = Name_Loop_Variant) then In_Loop_Assertion := True; Index: par-prag.adb =================================================================== --- par-prag.adb (revision 194199) +++ par-prag.adb (working copy) @@ -1189,7 +1189,8 @@ Pragma_Lock_Free | Pragma_Locking_Policy | Pragma_Long_Float | - Pragma_Loop_Assertion | + Pragma_Loop_Invariant | + Pragma_Loop_Variant | Pragma_Machine_Attribute | Pragma_Main | Pragma_Main_Storage | Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 194199) +++ snames.ads-tmpl (working copy) @@ -405,7 +405,8 @@ Name_License : constant Name_Id := N + $; -- GNAT Name_Locking_Policy : constant Name_Id := N + $; Name_Long_Float : constant Name_Id := N + $; -- VMS - Name_Loop_Assertion : constant Name_Id := N + $; -- GNAT + Name_Loop_Invariant : constant Name_Id := N + $; -- GNAT + Name_Loop_Variant : constant Name_Id := N + $; -- GNAT Name_No_Run_Time : constant Name_Id := N + $; -- GNAT Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT Name_Normalize_Scalars : constant Name_Id := N + $; @@ -671,7 +672,7 @@ Name_Component_Size_4 : constant Name_Id := N + $; Name_Copy : constant Name_Id := N + $; Name_D_Float : constant Name_Id := N + $; - Name_Decreasing : constant Name_Id := N + $; + Name_Decreases : constant Name_Id := N + $; Name_Descriptor : constant Name_Id := N + $; Name_Disable : constant Name_Id := N + $; Name_Dot_Replacement : constant Name_Id := N + $; @@ -691,7 +692,7 @@ Name_GPL : constant Name_Id := N + $; Name_IEEE_Float : constant Name_Id := N + $; Name_Ignore : constant Name_Id := N + $; - Name_Increasing : constant Name_Id := N + $; + Name_Increases : constant Name_Id := N + $; Name_Info : constant Name_Id := N + $; Name_Internal : constant Name_Id := N + $; Name_Link_Name : constant Name_Id := N + $; @@ -1686,7 +1687,8 @@ Pragma_License, Pragma_Locking_Policy, Pragma_Long_Float, - Pragma_Loop_Assertion, + Pragma_Loop_Invariant, + Pragma_Loop_Variant, Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, Pragma_Normalize_Scalars,