------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ P R A G -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Expander; use Expander; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; with Stand; use Stand; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Prag is ----------------------- -- Local Subprograms -- ----------------------- function Arg1 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id; function Arg3 (N : Node_Id) return Node_Id; -- Obtain specified pragma argument expression procedure Expand_Pragma_Abort_Defer (N : Node_Id); procedure Expand_Pragma_Check (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); 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_Variant (N : Node_Id); procedure Expand_Pragma_Psect_Object (N : Node_Id); procedure Expand_Pragma_Relative_Deadline (N : Node_Id); ---------- -- Arg1 -- ---------- function Arg1 (N : Node_Id) return Node_Id is Arg : constant Node_Id := First (Pragma_Argument_Associations (N)); begin if Present (Arg) and then Nkind (Arg) = N_Pragma_Argument_Association then return Expression (Arg); else return Arg; end if; end Arg1; ---------- -- Arg2 -- ---------- function Arg2 (N : Node_Id) return Node_Id is Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); begin if No (Arg1) then return Empty; else declare Arg : constant Node_Id := Next (Arg1); begin if Present (Arg) and then Nkind (Arg) = N_Pragma_Argument_Association then return Expression (Arg); else return Arg; end if; end; end if; end Arg2; ---------- -- Arg3 -- ---------- function Arg3 (N : Node_Id) return Node_Id is Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); begin if No (Arg1) then return Empty; else declare Arg : Node_Id := Next (Arg1); begin if No (Arg) then return Empty; else Next (Arg); if Present (Arg) and then Nkind (Arg) = N_Pragma_Argument_Association then return Expression (Arg); else return Arg; end if; end if; end; end if; end Arg3; --------------------- -- Expand_N_Pragma -- --------------------- procedure Expand_N_Pragma (N : Node_Id) is Pname : constant Name_Id := Pragma_Name (N); begin -- Note: we may have a pragma whose Pragma_Identifier field is not a -- recognized pragma, and we must ignore it at this stage. if Is_Pragma_Name (Pname) then case Get_Pragma_Id (Pname) is -- Pragmas requiring special expander action when Pragma_Abort_Defer => Expand_Pragma_Abort_Defer (N); when Pragma_Check => Expand_Pragma_Check (N); when Pragma_Common_Object => Expand_Pragma_Common_Object (N); when Pragma_Export_Exception => Expand_Pragma_Import_Export_Exception (N); when Pragma_Import => Expand_Pragma_Import_Or_Interface (N); when Pragma_Import_Exception => Expand_Pragma_Import_Export_Exception (N); when Pragma_Inspection_Point => Expand_Pragma_Inspection_Point (N); when Pragma_Interface => Expand_Pragma_Import_Or_Interface (N); when Pragma_Interrupt_Priority => Expand_Pragma_Interrupt_Priority (N); when Pragma_Loop_Variant => Expand_Pragma_Loop_Variant (N); when Pragma_Psect_Object => Expand_Pragma_Psect_Object (N); when Pragma_Relative_Deadline => Expand_Pragma_Relative_Deadline (N); -- All other pragmas need no expander action when others => null; end case; end if; end Expand_N_Pragma; ------------------------------- -- Expand_Pragma_Abort_Defer -- ------------------------------- -- An Abort_Defer pragma appears as the first statement in a handled -- statement sequence (right after the begin). It defers aborts for -- the entire statement sequence, but not for any declarations or -- handlers (if any) associated with this statement sequence. -- The transformation is to transform -- pragma Abort_Defer; -- statements; -- into -- begin -- Abort_Defer.all; -- statements -- exception -- when all others => -- Abort_Undefer.all; -- raise; -- at end -- Abort_Undefer_Direct; -- end; procedure Expand_Pragma_Abort_Defer (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Stm : Node_Id; Stms : List_Id; HSS : Node_Id; Blk : constant Entity_Id := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); begin Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); loop Stm := Remove_Next (N); exit when No (Stm); Append (Stm, Stms); end loop; HSS := Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms, At_End_Proc => New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); Rewrite (N, Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS)); Set_Scope (Blk, Current_Scope); Set_Etype (Blk, Standard_Void_Type); Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); Expand_At_End_Handler (HSS, Blk); Analyze (N); end Expand_Pragma_Abort_Defer; -------------------------- -- Expand_Pragma_Check -- -------------------------- procedure Expand_Pragma_Check (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); -- Location of the pragma node. Note: it is important to use this -- location (and not the location of the expression) for the generated -- statements, otherwise the implicit return statement in the body -- of a pre/postcondition subprogram may inherit the source location -- of part of the expression, which causes confusing debug information -- to be generated, which interferes with coverage analysis tools. Cond : constant Node_Id := Arg2 (N); Nam : constant Name_Id := Chars (Arg1 (N)); Msg : Node_Id; begin -- We already know that this check is enabled, because otherwise the -- semantic pass dealt with rewriting the assertion (see Sem_Prag) -- Since this check is enabled, we rewrite the pragma into a -- corresponding if statement, and then analyze the statement -- The normal case expansion transforms: -- pragma Check (name, condition [,message]); -- into -- if not condition then -- System.Assertions.Raise_Assert_Failure (Str); -- end if; -- where Str is the message if one is present, or the default of -- name failed at file:line if no message is given (the "name failed -- at" is omitted for name = Assertion, since it is redundant, given -- that the name of the exception is Assert_Failure.) -- An alternative expansion is used when the No_Exception_Propagation -- restriction is active and there is a local Assert_Failure handler. -- This is not a common combination of circumstances, but it occurs in -- the context of Aunit and the zero footprint profile. In this case we -- generate: -- if not condition then -- raise Assert_Failure; -- end if; -- This will then be transformed into a goto, and the local handler will -- be able to handle the assert error (which would not be the case if a -- call is made to the Raise_Assert_Failure procedure). -- We also generate the direct raise if the Suppress_Exception_Locations -- is active, since we don't want to generate messages in this case. -- Note that the reason we do not always generate a direct raise is that -- the form in which the procedure is called allows for more efficient -- breakpointing of assertion errors. -- Generate the appropriate if statement. Note that we consider this to -- be an explicit conditional in the source, not an implicit if, so we -- do not call Make_Implicit_If_Statement. -- Case where we generate a direct raise if ((Debug_Flag_Dot_G or else Restriction_Active (No_Exception_Propagation)) and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) then Rewrite (N, Make_If_Statement (Loc, Condition => Make_Op_Not (Loc, Right_Opnd => Cond), Then_Statements => New_List ( Make_Raise_Statement (Loc, Name => New_Reference_To (RTE (RE_Assert_Failure), Loc))))); -- Case where we call the procedure else -- If we have a message given, use it if Present (Arg3 (N)) then Msg := Get_Pragma_Arg (Arg3 (N)); -- Here we have no string, so prepare one else declare Msg_Loc : constant String := Build_Location_String (Sloc (First_Node (Cond))); -- Source location used in the case of a failed assertion: -- point to the failing condition, not Loc. Note that the -- source location of the expression is not usually the best -- choice here. For example, it gets located on the last AND -- keyword in a chain of boolean expressiond AND'ed together. -- It is best to put the message on the first character of the -- condition, which is the effect of the First_Node call here. begin Name_Len := 0; -- For Assert, we just use the location if Nam = Name_Assertion then null; -- For predicate, we generate the string "predicate failed -- at yyy". We prefer all lower case for predicate. elsif Nam = Name_Predicate then Add_Str_To_Name_Buffer ("predicate failed at "); -- For special case of Precondition/Postcondition the string is -- "failed xx from yy" where xx is precondition/postcondition -- in all lower case. The reason for this different wording is -- that the failure is not at the point of occurrence of the -- pragma, unlike the other Check cases. elsif Nam = Name_Precondition or else Nam = Name_Postcondition then Get_Name_String (Nam); Insert_Str_In_Name_Buffer ("failed ", 1); Add_Str_To_Name_Buffer (" from "); -- For all other checks, the string is "xxx failed at yyy" -- where xxx is the check name with current source file casing. else Get_Name_String (Nam); Set_Casing (Identifier_Casing (Current_Source_File)); Add_Str_To_Name_Buffer (" failed at "); end if; -- In all cases, add location string Add_Str_To_Name_Buffer (Msg_Loc); -- Build the message Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); end; end if; -- Now rewrite as an if statement Rewrite (N, Make_If_Statement (Loc, Condition => Make_Op_Not (Loc, Right_Opnd => Cond), Then_Statements => New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), Parameter_Associations => New_List (Relocate_Node (Msg)))))); end if; Analyze (N); -- If new condition is always false, give a warning if Warn_On_Assertion_Failure and then Nkind (N) = N_Procedure_Call_Statement and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) then -- If original condition was a Standard.False, we assume that this is -- indeed intended to raise assert error and no warning is required. if Is_Entity_Name (Original_Node (Cond)) and then Entity (Original_Node (Cond)) = Standard_False then return; elsif Nam = Name_Assertion then Error_Msg_N ("?A?assertion will fail at run time", N); else Error_Msg_N ("?A?check will fail at run time", N); end if; end if; end Expand_Pragma_Check; --------------------------------- -- Expand_Pragma_Common_Object -- --------------------------------- -- Use a machine attribute to replicate semantic effect in DEC Ada -- pragma Machine_Attribute (intern_name, "common_object", extern_name); -- For now we do nothing with the size attribute ??? -- Note: Psect_Object shares this processing procedure Expand_Pragma_Common_Object (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Internal : constant Node_Id := Arg1 (N); External : constant Node_Id := Arg2 (N); Psect : Node_Id; -- Psect value upper cased as string literal Iloc : constant Source_Ptr := Sloc (Internal); Eloc : constant Source_Ptr := Sloc (External); Ploc : Source_Ptr; begin -- Acquire Psect value and fold to upper case if Present (External) then if Nkind (External) = N_String_Literal then String_To_Name_Buffer (Strval (External)); else Get_Name_String (Chars (External)); end if; Set_All_Upper_Case; Psect := Make_String_Literal (Eloc, Strval => String_From_Name_Buffer); else Get_Name_String (Chars (Internal)); Set_All_Upper_Case; Psect := Make_String_Literal (Iloc, Strval => String_From_Name_Buffer); end if; Ploc := Sloc (Psect); -- Insert the pragma Insert_After_And_Analyze (N, Make_Pragma (Loc, Chars => Name_Machine_Attribute, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Iloc, Expression => New_Copy_Tree (Internal)), Make_Pragma_Argument_Association (Eloc, Expression => Make_String_Literal (Sloc => Ploc, Strval => "common_object")), Make_Pragma_Argument_Association (Ploc, Expression => New_Copy_Tree (Psect))))); end Expand_Pragma_Common_Object; --------------------------------------- -- Expand_Pragma_Import_Or_Interface -- --------------------------------------- -- When applied to a variable, the default initialization must not be done. -- As it is already done when the pragma is found, we just get rid of the -- call the initialization procedure which followed the object declaration. -- The call is inserted after the declaration, but validity checks may -- also have been inserted and the initialization call does not necessarily -- appear immediately after the object declaration. -- We can't use the freezing mechanism for this purpose, since we have to -- elaborate the initialization expression when it is first seen (i.e. this -- elaboration cannot be deferred to the freeze point). procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is Def_Id : Entity_Id; Init_Call : Node_Id; begin Def_Id := Entity (Arg2 (N)); if Ekind (Def_Id) = E_Variable then -- Find and remove generated initialization call for object, if any Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N); -- Any default initialization expression should be removed (e.g., -- null defaults for access objects, zero initialization of packed -- bit arrays). Imported objects aren't allowed to have explicit -- initialization, so the expression must have been generated by -- the compiler. if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then Set_Expression (Parent (Def_Id), Empty); end if; end if; end Expand_Pragma_Import_Or_Interface; ------------------------------------------- -- Expand_Pragma_Import_Export_Exception -- ------------------------------------------- -- For a VMS exception fix up the language field with "VMS" -- instead of "Ada" (gigi needs this), create a constant that will be the -- value of the VMS condition code and stuff the Interface_Name field -- with the unexpanded name of the exception (if not already set). -- For a Ada exception, just stuff the Interface_Name field -- with the unexpanded name of the exception (if not already set). procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is begin -- This pragma is only effective on OpenVMS systems, it was ignored -- on non-VMS systems, and we need to ignore it here as well. if not OpenVMS_On_Target then return; end if; declare Id : constant Entity_Id := Entity (Arg1 (N)); Call : constant Node_Id := Register_Exception_Call (Id); Loc : constant Source_Ptr := Sloc (N); begin if Present (Call) then declare Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V'); Export_Pragma : Node_Id; Excep_Alias : Node_Id; Excep_Object : Node_Id; Excep_Image : String_Id; Exdata : List_Id; Lang_Char : Node_Id; Code : Node_Id; begin if Present (Interface_Name (Id)) then Excep_Image := Strval (Interface_Name (Id)); else Get_Name_String (Chars (Id)); Set_All_Upper_Case; Excep_Image := String_From_Name_Buffer; end if; Exdata := Component_Associations (Expression (Parent (Id))); if Is_VMS_Exception (Id) then Lang_Char := Next (First (Exdata)); -- Change the one-character language designator to 'V' Rewrite (Expression (Lang_Char), Make_Character_Literal (Loc, Chars => Name_uV, Char_Literal_Value => UI_From_Int (Character'Pos ('V')))); Analyze (Expression (Lang_Char)); if Exception_Code (Id) /= No_Uint then Code := Make_Integer_Literal (Loc, Intval => Exception_Code (Id)); Excep_Object := Make_Object_Declaration (Loc, Defining_Identifier => Excep_Internal, Object_Definition => New_Reference_To (RTE (RE_Exception_Code), Loc)); Insert_Action (N, Excep_Object); Analyze (Excep_Object); Start_String; Store_String_Int (UI_To_Int (Exception_Code (Id)) / 8 * 8); Excep_Alias := Make_Pragma (Loc, Chars => Name_Linker_Alias, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => New_Reference_To (Excep_Internal, Loc)), Make_Pragma_Argument_Association (Loc, Expression => Make_String_Literal (Loc, End_String)))); Insert_Action (N, Excep_Alias); Analyze (Excep_Alias); Export_Pragma := Make_Pragma (Loc, Chars => Name_Export, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_C)), Make_Pragma_Argument_Association (Loc, Expression => New_Reference_To (Excep_Internal, Loc)), Make_Pragma_Argument_Association (Loc, Expression => Make_String_Literal (Loc, Excep_Image)), Make_Pragma_Argument_Association (Loc, Expression => Make_String_Literal (Loc, Excep_Image)))); Insert_Action (N, Export_Pragma); Analyze (Export_Pragma); else Code := Unchecked_Convert_To (RTE (RE_Exception_Code), Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Import_Value), Loc), Parameter_Associations => New_List (Make_String_Literal (Loc, Strval => Excep_Image)))); end if; Rewrite (Call, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Register_VMS_Exception), Loc), Parameter_Associations => New_List ( Code, Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Id, Loc), Attribute_Name => Name_Unrestricted_Access))))); Analyze_And_Resolve (Code, RTE (RE_Exception_Code)); Analyze (Call); end if; if No (Interface_Name (Id)) then Set_Interface_Name (Id, Make_String_Literal (Sloc => Loc, Strval => Excep_Image)); end if; end; end if; end; end Expand_Pragma_Import_Export_Exception; ------------------------------------ -- Expand_Pragma_Inspection_Point -- ------------------------------------ -- If no argument is given, then we supply a default argument list that -- includes all objects declared at the source level in all subprograms -- that enclose the inspection point pragma. procedure Expand_Pragma_Inspection_Point (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); A : List_Id; Assoc : Node_Id; S : Entity_Id; E : Entity_Id; begin if No (Pragma_Argument_Associations (N)) then A := New_List; S := Current_Scope; while S /= Standard_Standard loop E := First_Entity (S); while Present (E) loop if Comes_From_Source (E) and then Is_Object (E) and then not Is_Entry_Formal (E) and then Ekind (E) /= E_Component and then Ekind (E) /= E_Discriminant and then Ekind (E) /= E_Generic_In_Parameter and then Ekind (E) /= E_Generic_In_Out_Parameter then Append_To (A, Make_Pragma_Argument_Association (Loc, Expression => New_Occurrence_Of (E, Loc))); end if; Next_Entity (E); end loop; S := Scope (S); end loop; Set_Pragma_Argument_Associations (N, A); end if; -- Expand the arguments of the pragma. Expanding an entity reference -- is a noop, except in a protected operation, where a reference may -- have to be transformed into a reference to the corresponding prival. -- Are there other pragmas that may require this ??? Assoc := First (Pragma_Argument_Associations (N)); while Present (Assoc) loop Expand (Expression (Assoc)); Next (Assoc); end loop; end Expand_Pragma_Inspection_Point; -------------------------------------- -- Expand_Pragma_Interrupt_Priority -- -------------------------------------- -- Supply default argument if none exists (System.Interrupt_Priority'Last) procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); begin if No (Pragma_Argument_Associations (N)) then Set_Pragma_Argument_Associations (N, New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc), Attribute_Name => Name_Last)))); end if; end Expand_Pragma_Interrupt_Priority; -------------------------------- -- Expand_Pragma_Loop_Variant -- -------------------------------- -- Pragma Loop_Variant is expanded in the following manner: -- Original code -- for | while ... loop -- -- pragma Loop_Variant -- (Increases => Incr_Expr, -- Decreases => Decr_Expr); -- -- end loop; -- Expanded code -- Curr_1 : ; -- Curr_2 : ; -- Old_1 : ; -- Old_2 : ; -- Flag : Boolean := False; -- for | while ... loop -- -- if Flag then -- Old_1 := Curr_1; -- Old_2 := Curr_2; -- end if; -- Curr_1 := ; -- Curr_2 := ; -- if Flag then -- if Curr_1 /= Old_1 then -- pragma Assert (Curr_1 > Old_1); -- else -- pragma Assert (Curr_2 < Old_2); -- end if; -- else -- Flag := True; -- end if; -- -- end loop; procedure Expand_Pragma_Loop_Variant (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Last_Var : constant Node_Id := Last (Pragma_Argument_Associations (N)); Curr_Assign : List_Id := No_List; Flag_Id : Entity_Id := Empty; If_Stmt : Node_Id := Empty; Old_Assign : List_Id := No_List; Loop_Scop : Entity_Id; Loop_Stmt : Node_Id; Variant : Node_Id; 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_Variant -- --------------------- 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 change mode (Increases / Decreases) of the variant. ------------- -- Make_Op -- ------------- function Make_Op (Loc : Source_Ptr; Curr_Val : Node_Id; Old_Val : Node_Id) return Node_Id is begin if Chars (Variant) = Name_Increases then return Make_Op_Gt (Loc, Curr_Val, Old_Val); else pragma Assert (Chars (Variant) = Name_Decreases); return Make_Op_Lt (Loc, Curr_Val, Old_Val); end if; end Make_Op; -- 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_Variant begin -- All temporaries generated in this routine must be inserted before -- the related loop statement. Ensure that the proper scope is on the -- stack when analyzing the temporaries. Note that we also use the -- Sloc of the related loop. Push_Scope (Scope (Loop_Scop)); -- Step 1: Create the declaration of the flag which controls the -- behavior of the assertion on the first iteration of the loop. if No (Flag_Id) then -- Generate: -- Flag : Boolean := False; Flag_Id := Make_Temporary (Loop_Loc, 'F'); Insert_Action (Loop_Stmt, Make_Object_Declaration (Loop_Loc, Defining_Identifier => Flag_Id, Object_Definition => New_Reference_To (Standard_Boolean, Loop_Loc), Expression => New_Reference_To (Standard_False, Loop_Loc))); -- Prevent an unwanted optimization where the Current_Value of -- the flag eliminates the if statement which stores the variant -- values coming from the previous iteration. -- Flag : Boolean := False; -- loop -- if Flag then -- condition rewritten to False -- Old_N := Curr_N; -- and if statement eliminated -- end if; -- . . . -- Flag := True; -- end loop; Set_Current_Value (Flag_Id, Empty); end if; -- Step 2: Create the temporaries which store the old and current -- values of the associated expression. -- Generate: -- Curr : ; Curr_Id := Make_Temporary (Loc, 'C'); Insert_Action (Loop_Stmt, Make_Object_Declaration (Loop_Loc, Defining_Identifier => Curr_Id, Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc))); -- Generate: -- Old : ; Old_Id := Make_Temporary (Loc, 'P'); Insert_Action (Loop_Stmt, Make_Object_Declaration (Loop_Loc, Defining_Identifier => Old_Id, Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc))); -- Restore original scope after all temporaries have been analyzed Pop_Scope; -- Step 3: Store value of the expression from the previous iteration if No (Old_Assign) then Old_Assign := New_List; end if; -- Generate: -- Old := Curr; Append_To (Old_Assign, Make_Assignment_Statement (Loc, Name => New_Reference_To (Old_Id, Loc), Expression => New_Reference_To (Curr_Id, Loc))); -- Step 4: Store the current value of the expression if No (Curr_Assign) then Curr_Assign := New_List; end if; -- Generate: -- Curr := ; Append_To (Curr_Assign, Make_Assignment_Statement (Loc, Name => New_Reference_To (Curr_Id, Loc), Expression => Relocate_Node (Expr))); -- Step 5: Create corresponding assertion to verify change of value -- Generate: -- pragma Assert (Curr <|> Old); Prag := Make_Pragma (Loc, Chars => Name_Assert, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Op (Loc, Curr_Val => New_Reference_To (Curr_Id, Loc), Old_Val => New_Reference_To (Old_Id, Loc))))); -- Generate: -- if Curr /= Old then -- ; if No (If_Stmt) then -- When there is just one termination variant, do not compare the -- old and current value for equality, just check the pragma. if Is_Last then If_Stmt := Prag; else If_Stmt := Make_If_Statement (Loc, Condition => Make_Op_Ne (Loc, Left_Opnd => New_Reference_To (Curr_Id, Loc), Right_Opnd => New_Reference_To (Old_Id, Loc)), Then_Statements => New_List (Prag)); end if; -- Generate: -- else -- ; -- end if; elsif Is_Last then Set_Else_Statements (If_Stmt, New_List (Prag)); -- Generate: -- elsif Curr /= Old then -- ; else if Elsif_Parts (If_Stmt) = No_List then Set_Elsif_Parts (If_Stmt, New_List); end if; Append_To (Elsif_Parts (If_Stmt), Make_Elsif_Part (Loc, Condition => Make_Op_Ne (Loc, Left_Opnd => New_Reference_To (Curr_Id, Loc), Right_Opnd => New_Reference_To (Old_Id, Loc)), Then_Statements => New_List (Prag))); end if; end Process_Variant; -- Start of processing for Expand_Pragma_Loop_Assertion begin -- Locate the enclosing loop for which this assertion applies. In the -- case of Ada 2012 array iteration, we might be dealing with nested -- loops. Only the outermost loop has an identifier. Loop_Stmt := N; while Present (Loop_Stmt) loop if Nkind (Loop_Stmt) = N_Loop_Statement and then Present (Identifier (Loop_Stmt)) then exit; end if; Loop_Stmt := Parent (Loop_Stmt); end loop; Loop_Scop := Entity (Identifier (Loop_Stmt)); -- Create the circuitry which verifies individual variants Variant := First (Pragma_Argument_Associations (N)); while Present (Variant) loop Process_Variant (Variant, Is_Last => Variant = Last_Var); Next (Variant); end loop; -- Construct the segment which stores the old values of all expressions. -- Generate: -- if Flag then -- -- 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 Insert_Actions (N, Curr_Assign); -- Add the assertion circuitry to test all changes in expressions. -- Generate: -- if Flag then -- -- else -- Flag := True; -- 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_Variant; -------------------------------- -- Expand_Pragma_Psect_Object -- -------------------------------- -- Convert to Common_Object, and expand the resulting pragma procedure Expand_Pragma_Psect_Object (N : Node_Id) renames Expand_Pragma_Common_Object; ------------------------------------- -- Expand_Pragma_Relative_Deadline -- ------------------------------------- procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is P : constant Node_Id := Parent (N); Loc : constant Source_Ptr := Sloc (N); begin -- Expand the pragma only in the case of the main subprogram. For tasks -- the expansion is done in exp_ch9. Generate a call to Set_Deadline -- at Clock plus the relative deadline specified in the pragma. Time -- values are translated into Duration to allow for non-private -- addition operation. if Nkind (P) = N_Subprogram_Body then Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Deadline), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RO_RT_Time), Make_Op_Add (Loc, Left_Opnd => Make_Function_Call (Loc, New_Reference_To (RTE (RO_RT_To_Duration), Loc), New_List (Make_Function_Call (Loc, New_Reference_To (RTE (RE_Clock), Loc)))), Right_Opnd => Unchecked_Convert_To (Standard_Duration, Arg1 (N))))))); Analyze (N); end if; end Expand_Pragma_Relative_Deadline; end Exp_Prag;