------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ P R A G -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2022, 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 Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Inline; use Inline; with Lib; use Lib; 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_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; package body Exp_Prag is ----------------------- -- Local Subprograms -- ----------------------- function Arg_N (N : Node_Id; Arg_Number : Positive) 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_CUDA_Execute (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (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); procedure Expand_Pragma_Suppress_Initialization (N : Node_Id); procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id); -- This procedure is used to undo initialization already done for Def_Id, -- which is always an E_Variable, in response to the occurrence of the -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all -- these cases we want no initialization to occur, but we have already done -- the initialization by the time we see the pragma, so we have to undo it. ----------- -- Arg_N -- ----------- function Arg_N (N : Node_Id; Arg_Number : Positive) return Node_Id is Arg : Node_Id := First (Pragma_Argument_Associations (N)); begin if No (Arg) then return Empty; end if; for J in 2 .. Arg_Number loop Next (Arg); if No (Arg) then return Empty; end if; end loop; if Present (Arg) then return Get_Pragma_Arg (Arg); else return Empty; end if; end Arg_N; --------------------- -- Expand_N_Pragma -- --------------------- procedure Expand_N_Pragma (N : Node_Id) is Pname : constant Name_Id := Pragma_Name (N); Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); begin -- Suppress the expansion of an ignored assertion pragma. Such a pragma -- should not be transformed into a null statement because: -- -- * The pragma may be part of the rep item chain of a type, in which -- case rewriting it will destroy the chain. -- -- * The analysis of the pragma may involve two parts (see routines -- Analyze_xxx_In_Decl_Part). The second part of the analysis will -- not happen if the pragma is rewritten. if Assertion_Expression_Pragma (Prag_Id) and then Is_Ignored (N) then return; -- Rewrite the pragma into a null statement when it is ignored using -- pragma Ignore_Pragma, or denotes Default_Scalar_Storage_Order and -- compilation switch -gnatI is in effect. elsif Should_Ignore_Pragma_Sem (N) or else (Prag_Id = Pragma_Default_Scalar_Storage_Order and then Ignore_Rep_Clauses) then Rewrite (N, Make_Null_Statement (Sloc (N))); return; end if; case Prag_Id 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_CUDA_Execute => Expand_Pragma_CUDA_Execute (N); when Pragma_Import => Expand_Pragma_Import_Or_Interface (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); when Pragma_Suppress_Initialization => Expand_Pragma_Suppress_Initialization (N); -- All other pragmas need no expander action (includes -- Unknown_Pragma). when others => null; end case; 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 begin -- Abort_Defer has no useful effect if Abort's are not allowed if not Abort_Allowed then return; end if; -- Normal case where abort is possible declare 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'); AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); 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 (AUD, Loc)); -- Present the Abort_Undefer_Direct function to the backend so that -- it can inline the call to the function. Add_Inlined_Body (AUD, N); 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; end Expand_Pragma_Abort_Defer; -------------------------- -- Expand_Pragma_Check -- -------------------------- procedure Expand_Pragma_Check (N : Node_Id) is Cond : constant Node_Id := Arg_N (N, 2); Nam : constant Name_Id := Chars (Arg_N (N, 1)); Msg : Node_Id; Loc : constant Source_Ptr := 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, because it points to -- the location of the topmost tree node, which may be an operator in -- the middle of the source text of the expression. For example, it gets -- located on the last AND keyword in a chain of boolean expressions -- 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. -- This source location is used to build the default exception message, -- and also as the sloc of the call to the runtime subprogram raising -- Assert_Failure, so that coverage analysis tools can relate the -- call to the failed check. procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id); -- Discriminants of the enclosing protected object may be referenced -- in the expression of a precondition of a protected operation. -- In the body of the operation these references must be replaced by -- the discriminal created for them, which are renamings of the -- discriminants of the object that is the target of the operation. -- This replacement is done by visibility when the references appear -- in the subprogram body, but in the case of a condition which appears -- on the specification of the subprogram it has be done separately -- because the condition has been replaced by a Check pragma and -- analyzed earlier, before the creation of the discriminal renaming -- declarations that are added to the subprogram body. ------------------------------------------ -- Replace_Discriminals_Of_Protected_Op -- ------------------------------------------ procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id) is function Find_Corresponding_Discriminal (E : Entity_Id) return Entity_Id; -- Find the local entity that renames a discriminant of the enclosing -- protected type, and has a matching name. function Replace_Discr_Ref (N : Node_Id) return Traverse_Result; -- Replace a reference to a discriminant of the original protected -- type by the local renaming declaration of the discriminant of -- the target object. ------------------------------------ -- Find_Corresponding_Discriminal -- ------------------------------------ function Find_Corresponding_Discriminal (E : Entity_Id) return Entity_Id is R : Entity_Id; begin R := First_Entity (Current_Scope); while Present (R) loop if Nkind (Parent (R)) = N_Object_Renaming_Declaration and then Present (Discriminal_Link (R)) and then Chars (Discriminal_Link (R)) = Chars (E) then return R; end if; Next_Entity (R); end loop; return Empty; end Find_Corresponding_Discriminal; ----------------------- -- Replace_Discr_Ref -- ----------------------- function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is R : Entity_Id; begin if Is_Entity_Name (N) and then Present (Discriminal_Link (Entity (N))) then R := Find_Corresponding_Discriminal (Entity (N)); Rewrite (N, New_Occurrence_Of (R, Sloc (N))); end if; return OK; end Replace_Discr_Ref; procedure Replace_Discriminant_References is new Traverse_Proc (Replace_Discr_Ref); -- Start of processing for Replace_Discriminals_Of_Protected_Op begin Replace_Discriminant_References (Expr); end Replace_Discriminals_Of_Protected_Op; -- Start of processing for Expand_Pragma_Check begin -- Nothing to do if pragma is ignored if Is_Ignored (N) then return; end if; -- Since this check is active, 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.) -- Also, instead of "XXX failed at", we generate slightly -- different messages for some of the contract assertions (see -- code below for details). -- 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. Note also that we wrap the -- raise statement in a block statement so that, if the condition is -- evaluated at compile time to False, then the rewriting of the if -- statement will not involve the raise but the block statement, and -- thus not leave a dangling reference to the raise statement in the -- Local_Raise_Statements list of the handler. -- 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 (Arg_N (N, 3))) then Rewrite (N, Make_If_Statement (Loc, Condition => Make_Op_Not (Loc, Right_Opnd => Cond), Then_Statements => New_List ( Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Raise_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc)))))))); Set_Comes_From_Check_Or_Contract (N); -- Case where we call the procedure else -- If we have a message given, use it if Present (Arg_N (N, 3)) then Msg := Get_Pragma_Arg (Arg_N (N, 3)); -- Here we have no string, so prepare one else declare Loc_Str : constant String := Build_Location_String (Loc); begin Name_Len := 0; -- For Assert, we just use the location if Nam = Name_Assert 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 in Name_Precondition | Name_Postcondition then Get_Name_String (Nam); Insert_Str_In_Name_Buffer ("failed ", 1); Add_Str_To_Name_Buffer (" from "); -- For special case of Invariant, the string is "failed -- invariant from yy", to be consistent with the string that is -- generated for the aspect case (the code later on checks for -- this specific string to modify it in some cases, so this is -- functionally important). elsif Nam = Name_Invariant then Add_Str_To_Name_Buffer ("failed invariant from "); -- For all other checks, the string is "xxx failed at yyy" -- where xxx is the check name with appropriate casing. else Get_Name_String (Nam); Set_Casing (Identifier_Casing (Source_Index (Current_Sem_Unit))); Add_Str_To_Name_Buffer (" failed at "); end if; -- In all cases, add location string Add_Str_To_Name_Buffer (Loc_Str); -- Build the message Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); end; end if; -- For a precondition, replace references to discriminants of a -- protected type with the local discriminals. if Is_Protected_Type (Scope (Current_Scope)) and then Has_Discriminants (Scope (Current_Scope)) and then From_Aspect_Specification (N) then Replace_Discriminals_Of_Protected_Op (Cond); 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_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), Parameter_Associations => New_List (Relocate_Node (Msg)))))); Set_Comes_From_Check_Or_Contract (N); 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 null; elsif Nam = Name_Assert 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 := Arg_N (N, 1); External : constant Node_Id := Arg_N (N, 2); 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_Casing (All_Upper_Case); Psect := Make_String_Literal (Eloc, Strval => String_From_Name_Buffer); else Get_Name_String (Chars (Internal)); Set_Casing (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_CUDA_Execute -- -------------------------------- -- Pragma CUDA_Execute is expanded in the following manner: -- Original Code -- pragma CUDA_Execute (My_Proc (X, Y), Blocks, Grids, Mem, Stream) -- Expanded Code -- declare -- Blocks_Id : CUDA.Vector_Types.Dim3 := Blocks; -- Grids_Id : CUDA.Vector_Types.Dim3 := Grids; -- Mem_Id : Integer := ; -- Stream_Id : CUDA.Driver_Types.Stream_T := ; -- X_Id : := X; -- Y_Id : := Y; -- Arg_Id : Array (1..2) of System.Address := -- (X'Address,_Id Y'Address);_Id -- begin -- CUDA.Internal.Push_Call_Configuration ( -- Grids_Id, -- Blocks_Id, -- Mem_Id, -- Stream_Id); -- CUDA.Internal.Pop_Call_Configuration ( -- Grids_Id'address, -- Blocks_Id'address, -- Mem_Id'address, -- Stream_Id'address), -- CUDA.Runtime_Api.Launch_Kernel ( -- My_Proc'Address, -- Blocks_Id, -- Grids_Id, -- Arg_Id'Address, -- Mem_Id, -- Stream_Id); -- end; procedure Expand_Pragma_CUDA_Execute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); procedure Append_Copies (Params : List_Id; Decls : List_Id; Copies : Elist_Id); -- For each parameter in list Params, create an object declaration of -- the followinng form: -- -- Copy_Id : Param_Typ := Param_Val; -- -- Param_Typ is the type of the parameter. Param_Val is the initial -- value of the parameter. The declarations are stored in Decls, the -- entities of the new objects are collected in list Copies. function Build_Dim3_Declaration (Decl_Id : Entity_Id; Init_Val : Node_Id) return Node_Id; -- Build an object declaration of the form -- -- Decl_Id : CUDA.Internal.Dim3 := Val; -- -- Val depends on the nature of Init_Val, as follows: -- -- * If Init_Val is of type CUDA.Vector_Types.Dim3, then Val has the -- following form: -- -- (Interfaces.C.Unsigned (Val.X), -- Interfaces.C.Unsigned (Val.Y), -- Interfaces.C.Unsigned (Val.Z)) -- -- * If Init_Val is a single Integer, Val has the following form: -- -- (Interfaces.C.Unsigned (Init_Val), -- Interfaces.C.Unsigned (1), -- Interfaces.C.Unsigned (1)) -- -- * If Init_Val is an aggregate of three values, Val has the -- following form: -- -- (Interfaces.C.Unsigned (Val_1), -- Interfaces.C.Unsigned (Val_2), -- Interfaces.C.Unsigned (Val_3)) function Build_Kernel_Args_Declaration (Kernel_Arg : Entity_Id; Var_Ids : Elist_Id) return Node_Id; -- Given a list of variables, return an object declaration of the -- following form: -- -- Kernel_Arg : ... := (Var_1'Address, ..., Var_N'Address); function Build_Launch_Kernel_Call (Proc : Entity_Id; Grid_Dims : Entity_Id; Block_Dims : Entity_Id; Kernel_Arg : Entity_Id; Memory : Entity_Id; Stream : Entity_Id) return Node_Id; -- Builds and returns a call to CUDA.Launch_Kernel using the given -- arguments. Proc is the entity of the procedure passed to the -- CUDA_Execute pragma. Grid_Dims and Block_Dims are entities of the -- generated declarations that hold the kernel's dimensions. Args is the -- entity of the temporary array that holds the arguments of the kernel. -- Memory and Stream are the entities of the temporaries that hold the -- fourth and fith arguments of CUDA_Execute or their default values. function Build_Shared_Memory_Declaration (Decl_Id : Entity_Id; Init_Val : Node_Id) return Node_Id; -- Builds a declaration the Defining_Identifier of which is Decl_Id, the -- type of which is inferred from CUDA.Internal.Launch_Kernel and the -- value of which is Init_Val if present or null if not. function Build_Simple_Declaration_With_Default (Decl_Id : Entity_Id; Init_Val : Node_Id; Typ : Node_Id; Default_Val : Node_Id) return Node_Id; -- Build a declaration the Defining_Identifier of which is Decl_Id, the -- Object_Definition of which is Typ, the value of which is Init_Val if -- present or Default otherwise. function Build_Stream_Declaration (Decl_Id : Entity_Id; Init_Val : Node_Id) return Node_Id; -- Build a declaration the Defining_Identifier of which is Decl_Id, the -- type of which is Integer, the value of which is Init_Val if present -- and 0 otherwise. function Etype_Or_Dim3 (N : Node_Id) return Node_Id; -- If N is an aggregate whose type is unknown, return a new occurrence -- of the public Dim3 type. Otherwise, return a new occurrence of N's -- type. function Get_Nth_Arg_Type (Subprogram : Entity_Id; N : Positive) return Entity_Id; -- Returns the type of the Nth argument of Subprogram function To_Addresses (Elmts : Elist_Id) return List_Id; -- Returns a new list containing each element of Elmts wrapped in an -- 'address attribute reference. When passed No_Elist, returns an empty -- list. ------------------- -- Append_Copies -- ------------------- procedure Append_Copies (Params : List_Id; Decls : List_Id; Copies : Elist_Id) is Copy : Entity_Id; Param : Node_Id; Expr : Node_Id; begin Param := First (Params); while Present (Param) loop Copy := Make_Temporary (Loc, 'C'); if Nkind (Param) = N_Parameter_Association then Expr := Explicit_Actual_Parameter (Param); else Expr := Param; end if; Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Copy, Object_Definition => New_Occurrence_Of (Etype (Expr), Loc), Expression => New_Copy_Tree (Expr))); Append_Elmt (Copy, Copies); Next (Param); end loop; end Append_Copies; ---------------------------- -- Build_Dim3_Declaration -- ---------------------------- function Build_Dim3_Declaration (Decl_Id : Entity_Id; Init_Val : Node_Id) return Node_Id is -- Expressions for each component of the returned Dim3 Dim_X : Node_Id; Dim_Y : Node_Id; Dim_Z : Node_Id; -- Type of CUDA.Internal.Dim3 - inferred from -- RE_Push_Call_Configuration to avoid needing changes in GNAT when -- the CUDA bindings change (this happens frequently). Internal_Dim3 : constant Entity_Id := Get_Nth_Arg_Type (RTE (RE_Push_Call_Configuration), 1); -- Entities for each component of external and internal Dim3 First_Component : Entity_Id := First_Entity (RTE (RE_Dim3)); Second_Component : Entity_Id := Next_Entity (First_Component); Third_Component : Entity_Id := Next_Entity (Second_Component); begin -- Sem_prag.adb ensured that Init_Val is either a Dim3, an aggregate -- of three Any_Integers or Any_Integer. -- If Init_Val is a Dim3, use each of its components if Etype (Init_Val) = RTE (RE_Dim3) then Dim_X := Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Entity (Init_Val), Loc), Selector_Name => New_Occurrence_Of (First_Component, Loc)); Dim_Y := Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Entity (Init_Val), Loc), Selector_Name => New_Occurrence_Of (Second_Component, Loc)); Dim_Z := Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Entity (Init_Val), Loc), Selector_Name => New_Occurrence_Of (Third_Component, Loc)); else -- If Init_Val is an aggregate, use each of its arguments if Nkind (Init_Val) = N_Aggregate then Dim_X := First (Expressions (Init_Val)); Dim_Y := Next (Dim_X); Dim_Z := Next (Dim_Y); -- Otherwise, we know it is an integer and the rest defaults to 1 else Dim_X := Init_Val; Dim_Y := Make_Integer_Literal (Loc, 1); Dim_Z := Make_Integer_Literal (Loc, 1); end if; end if; First_Component := First_Entity (Internal_Dim3); Second_Component := Next_Entity (First_Component); Third_Component := Next_Entity (Second_Component); -- Finally return the CUDA.Internal.Dim3 declaration with an -- aggregate initialization expression. return Make_Object_Declaration (Loc, Defining_Identifier => Decl_Id, Object_Definition => New_Occurrence_Of (Internal_Dim3, Loc), Expression => Make_Aggregate (Loc, Expressions => New_List ( Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Etype (First_Component), Loc), Expression => New_Copy_Tree (Dim_X)), Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Etype (Second_Component), Loc), Expression => New_Copy_Tree (Dim_Y)), Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Etype (Third_Component), Loc), Expression => New_Copy_Tree (Dim_Z))))); end Build_Dim3_Declaration; ----------------------------------- -- Build_Kernel_Args_Declaration -- ----------------------------------- function Build_Kernel_Args_Declaration (Kernel_Arg : Entity_Id; Var_Ids : Elist_Id) return Node_Id is Vals : constant List_Id := To_Addresses (Var_Ids); begin return Make_Object_Declaration (Loc, Defining_Identifier => Kernel_Arg, Object_Definition => Make_Constrained_Array_Definition (Loc, Discrete_Subtype_Definitions => New_List ( Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => Make_Integer_Literal (Loc, List_Length (Vals)))), Component_Definition => Make_Component_Definition (Loc, Subtype_Indication => New_Occurrence_Of (Etype (RTE (RE_Address)), Loc))), Expression => Make_Aggregate (Loc, Vals)); end Build_Kernel_Args_Declaration; ------------------------------- -- Build_Launch_Kernel_Call -- ------------------------------- function Build_Launch_Kernel_Call (Proc : Entity_Id; Grid_Dims : Entity_Id; Block_Dims : Entity_Id; Kernel_Arg : Entity_Id; Memory : Entity_Id; Stream : Entity_Id) return Node_Id is begin return Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Launch_Kernel), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Proc, Loc), Attribute_Name => Name_Address), New_Occurrence_Of (Grid_Dims, Loc), New_Occurrence_Of (Block_Dims, Loc), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Kernel_Arg, Loc), Attribute_Name => Name_Address), New_Occurrence_Of (Memory, Loc), New_Occurrence_Of (Stream, Loc))); end Build_Launch_Kernel_Call; ------------------------------------- -- Build_Shared_Memory_Declaration -- ------------------------------------- function Build_Shared_Memory_Declaration (Decl_Id : Entity_Id; Init_Val : Node_Id) return Node_Id is begin return Build_Simple_Declaration_With_Default (Decl_Id => Decl_Id, Init_Val => Init_Val, Typ => New_Occurrence_Of (Get_Nth_Arg_Type (RTE (RE_Launch_Kernel), 5), Loc), Default_Val => Make_Integer_Literal (Loc, 0)); end Build_Shared_Memory_Declaration; ------------------------------------------- -- Build_Simple_Declaration_With_Default -- ------------------------------------------- function Build_Simple_Declaration_With_Default (Decl_Id : Entity_Id; Init_Val : Node_Id; Typ : Node_Id; Default_Val : Node_Id) return Node_Id is Value : Node_Id := Init_Val; begin if No (Value) then Value := Default_Val; end if; return Make_Object_Declaration (Loc, Defining_Identifier => Decl_Id, Object_Definition => Typ, Expression => Value); end Build_Simple_Declaration_With_Default; ------------------------------ -- Build_Stream_Declaration -- ------------------------------ function Build_Stream_Declaration (Decl_Id : Entity_Id; Init_Val : Node_Id) return Node_Id is begin return Build_Simple_Declaration_With_Default (Decl_Id => Decl_Id, Init_Val => Init_Val, Typ => New_Occurrence_Of (Get_Nth_Arg_Type (RTE (RE_Launch_Kernel), 6), Loc), Default_Val => Make_Null (Loc)); end Build_Stream_Declaration; ------------------- -- Etype_Or_Dim3 -- ------------------- function Etype_Or_Dim3 (N : Node_Id) return Node_Id is begin if Nkind (N) = N_Aggregate and then Is_Composite_Type (Etype (N)) then return New_Occurrence_Of (RTE (RE_Dim3), Sloc (N)); end if; return New_Occurrence_Of (Etype (N), Loc); end Etype_Or_Dim3; ---------------------- -- Get_Nth_Arg_Type -- ---------------------- function Get_Nth_Arg_Type (Subprogram : Entity_Id; N : Positive) return Entity_Id is Argument : Entity_Id := First_Entity (Subprogram); begin for J in 2 .. N loop Next_Entity (Argument); end loop; return Etype (Argument); end Get_Nth_Arg_Type; ------------------ -- To_Addresses -- ------------------ function To_Addresses (Elmts : Elist_Id) return List_Id is Result : constant List_Id := New_List; Elmt : Elmt_Id; begin if No (Elmts) then return Result; end if; Elmt := First_Elmt (Elmts); while Present (Elmt) loop Append_To (Result, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Node (Elmt), Loc), Attribute_Name => Name_Address)); Next_Elmt (Elmt); end loop; return Result; end To_Addresses; -- Local variables -- Pragma arguments Procedure_Call : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 1)); Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 2)); Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 3)); Shared_Memory : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 4)); CUDA_Stream : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 5)); -- Entities of objects that will be overwritten by calls to cuda runtime Grids_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); Blocks_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); Memory_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); Stream_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); -- Entities of objects that capture the value of pragma arguments Temp_Grid : constant Entity_Id := Make_Temporary (Loc, 'C'); Temp_Block : constant Entity_Id := Make_Temporary (Loc, 'C'); -- Declarations for temporary block and grids. These needs to be stored -- in temporary declarations as the expressions will need to be -- referenced multiple times but could have side effects. Temp_Grid_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Grid, Object_Definition => Etype_Or_Dim3 (Grid_Dimensions), Expression => Grid_Dimensions); Temp_Block_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Block, Object_Definition => Etype_Or_Dim3 (Block_Dimensions), Expression => Block_Dimensions); -- List holding the entities of the copies of Procedure_Call's arguments Kernel_Arg_Copies : constant Elist_Id := New_Elmt_List; -- Entity of the array that contains the address of each of the kernel's -- arguments. Kernel_Args_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); -- Calls to the CUDA runtime API. Launch_Kernel_Call : Node_Id; Pop_Call : Node_Id; Push_Call : Node_Id; -- Declaration of all temporaries required for CUDA API Calls Blk_Decls : constant List_Id := New_List; -- Start of processing for CUDA_Execute begin -- Append temporary declarations Append_To (Blk_Decls, Temp_Grid_Decl); Analyze (Temp_Grid_Decl); Append_To (Blk_Decls, Temp_Block_Decl); Analyze (Temp_Block_Decl); -- Build parameter declarations for CUDA API calls Append_To (Blk_Decls, Build_Dim3_Declaration (Grids_Id, New_Occurrence_Of (Temp_Grid, Loc))); Append_To (Blk_Decls, Build_Dim3_Declaration (Blocks_Id, New_Occurrence_Of (Temp_Block, Loc))); Append_To (Blk_Decls, Build_Shared_Memory_Declaration (Memory_Id, Shared_Memory)); Append_To (Blk_Decls, Build_Stream_Declaration (Stream_Id, CUDA_Stream)); Append_Copies (Parameter_Associations (Procedure_Call), Blk_Decls, Kernel_Arg_Copies); Append_To (Blk_Decls, Build_Kernel_Args_Declaration (Kernel_Args_Id, Kernel_Arg_Copies)); -- Build calls to the CUDA API Push_Call := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Push_Call_Configuration), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Grids_Id, Loc), New_Occurrence_Of (Blocks_Id, Loc), New_Occurrence_Of (Memory_Id, Loc), New_Occurrence_Of (Stream_Id, Loc))); Pop_Call := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Pop_Call_Configuration), Loc), Parameter_Associations => To_Addresses (New_Elmt_List (Grids_Id, Blocks_Id, Memory_Id, Stream_Id))); Launch_Kernel_Call := Build_Launch_Kernel_Call (Proc => Entity (Name (Procedure_Call)), Grid_Dims => Grids_Id, Block_Dims => Blocks_Id, Kernel_Arg => Kernel_Args_Id, Memory => Memory_Id, Stream => Stream_Id); -- Finally make the block that holds declarations and calls Rewrite (N, Make_Block_Statement (Loc, Declarations => Blk_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Push_Call, Pop_Call, Launch_Kernel_Call)))); Analyze (N); end Expand_Pragma_CUDA_Execute; ---------------------------------- -- Expand_Pragma_Contract_Cases -- ---------------------------------- -- Pragma Contract_Cases is expanded in the following manner: -- subprogram S is -- Count : Natural := 0; -- Flag_1 : Boolean := False; -- . . . -- Flag_N : Boolean := False; -- Flag_N+1 : Boolean := False; -- when "others" present -- Pref_1 : ...; -- . . . -- Pref_M : ...; -- -- -- Evaluate all case guards -- if Case_Guard_1 then -- Flag_1 := True; -- Count := Count + 1; -- end if; -- . . . -- if Case_Guard_N then -- Flag_N := True; -- Count := Count + 1; -- end if; -- -- Emit errors depending on the number of case guards that -- -- evaluated to True. -- if Count = 0 then -- raise Assertion_Error with "xxx contract cases incomplete"; -- -- Flag_N+1 := True; -- when "others" present -- elsif Count > 1 then -- declare -- Str0 : constant String := -- "contract cases overlap for subprogram ABC"; -- Str1 : constant String := -- (if Flag_1 then -- Str0 & "case guard at xxx evaluates to True" -- else Str0); -- StrN : constant String := -- (if Flag_N then -- StrN-1 & "case guard at xxx evaluates to True" -- else StrN-1); -- begin -- raise Assertion_Error with StrN; -- end; -- end if; -- -- Evaluate all attribute 'Old prefixes found in the selected -- -- consequence. -- if Flag_1 then -- Pref_1 := -- . . . -- elsif Flag_N then -- Pref_M := -- end if; -- procedure _Postconditions is -- begin -- -- if Flag_1 and then not Consequence_1 then -- raise Assertion_Error with "failed contract case at xxx"; -- end if; -- . . . -- if Flag_N[+1] and then not Consequence_N[+1] then -- raise Assertion_Error with "failed contract case at xxx"; -- end if; -- end _Postconditions; -- begin -- . . . -- end S; procedure Expand_Pragma_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id; Decls : List_Id; Stmts : in out List_Id) is Loc : constant Source_Ptr := Sloc (CCs); procedure Case_Guard_Error (Decls : List_Id; Flag : Entity_Id; Error_Loc : Source_Ptr; Msg : in out Entity_Id); -- Given a declarative list Decls, status flag Flag, the location of the -- error and a string Msg, construct the following check: -- Msg : constant String := -- (if Flag then -- Msg & "case guard at Error_Loc evaluates to True" -- else Msg); -- The resulting code is added to Decls procedure Consequence_Error (Checks : in out Node_Id; Flag : Entity_Id; Conseq : Node_Id); -- Given an if statement Checks, status flag Flag and a consequence -- Conseq, construct the following check: -- [els]if Flag and then not Conseq then -- raise Assertion_Error -- with "failed contract case at Sloc (Conseq)"; -- [end if;] -- The resulting code is added to Checks function Declaration_Of (Id : Entity_Id) return Node_Id; -- Given the entity Id of a boolean flag, generate: -- Id : Boolean := False; procedure Expand_Attributes_In_Consequence (Decls : List_Id; Evals : in out Node_Id; Flag : Entity_Id; Conseq : Node_Id); -- Perform specialized expansion of all attribute 'Old references found -- in consequence Conseq such that at runtime only prefixes coming from -- the selected consequence are evaluated. Similarly expand attribute -- 'Result references by replacing them with identifier _result which -- resolves to the sole formal parameter of procedure _Postconditions. -- Any temporaries generated in the process are added to declarations -- Decls. Evals is a complex if statement tasked with the evaluation of -- all prefixes coming from a single selected consequence. Flag is the -- corresponding case guard flag. Conseq is the consequence expression. function Increment (Id : Entity_Id) return Node_Id; -- Given the entity Id of a numerical variable, generate: -- Id := Id + 1; function Set (Id : Entity_Id) return Node_Id; -- Given the entity Id of a boolean variable, generate: -- Id := True; ---------------------- -- Case_Guard_Error -- ---------------------- procedure Case_Guard_Error (Decls : List_Id; Flag : Entity_Id; Error_Loc : Source_Ptr; Msg : in out Entity_Id) is New_Line : constant Character := Character'Val (10); New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); begin Start_String; Store_String_Char (New_Line); Store_String_Chars (" case guard at "); Store_String_Chars (Build_Location_String (Error_Loc)); Store_String_Chars (" evaluates to True"); -- Generate: -- New_Msg : constant String := -- (if Flag then -- Msg & "case guard at Error_Loc evaluates to True" -- else Msg); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => New_Msg, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_If_Expression (Loc, Expressions => New_List ( New_Occurrence_Of (Flag, Loc), Make_Op_Concat (Loc, Left_Opnd => New_Occurrence_Of (Msg, Loc), Right_Opnd => Make_String_Literal (Loc, End_String)), New_Occurrence_Of (Msg, Loc))))); Msg := New_Msg; end Case_Guard_Error; ----------------------- -- Consequence_Error -- ----------------------- procedure Consequence_Error (Checks : in out Node_Id; Flag : Entity_Id; Conseq : Node_Id) is Cond : Node_Id; Error : Node_Id; begin -- Generate: -- Flag and then not Conseq Cond := Make_And_Then (Loc, Left_Opnd => New_Occurrence_Of (Flag, Loc), Right_Opnd => Make_Op_Not (Loc, Right_Opnd => Relocate_Node (Conseq))); -- Generate: -- raise Assertion_Error -- with "failed contract case at Sloc (Conseq)"; Start_String; Store_String_Chars ("failed contract case at "); Store_String_Chars (Build_Location_String (Sloc (Conseq))); Error := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, End_String))); if No (Checks) then Checks := Make_Implicit_If_Statement (CCs, Condition => Cond, Then_Statements => New_List (Error)); Set_Comes_From_Check_Or_Contract (Checks); else if No (Elsif_Parts (Checks)) then Set_Elsif_Parts (Checks, New_List); end if; Append_To (Elsif_Parts (Checks), Make_Elsif_Part (Loc, Condition => Cond, Then_Statements => New_List (Error))); end if; end Consequence_Error; -------------------- -- Declaration_Of -- -------------------- function Declaration_Of (Id : Entity_Id) return Node_Id is begin return Make_Object_Declaration (Loc, Defining_Identifier => Id, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Expression => New_Occurrence_Of (Standard_False, Loc)); end Declaration_Of; -------------------------------------- -- Expand_Attributes_In_Consequence -- -------------------------------------- procedure Expand_Attributes_In_Consequence (Decls : List_Id; Evals : in out Node_Id; Flag : Entity_Id; Conseq : Node_Id) is Eval_Stmts : List_Id := No_List; -- The evaluation sequence expressed as assignment statements of all -- prefixes of attribute 'Old found in the current consequence. function Expand_Attributes (N : Node_Id) return Traverse_Result; -- Determine whether an arbitrary node denotes attribute 'Old or -- 'Result and if it does, perform all expansion-related actions. ----------------------- -- Expand_Attributes -- ----------------------- function Expand_Attributes (N : Node_Id) return Traverse_Result is Decl : Node_Id; Pref : Node_Id; Temp : Entity_Id; Indirect : Boolean := False; use Sem_Util.Old_Attr_Util.Indirect_Temps; procedure Append_For_Indirect_Temp (N : Node_Id; Is_Eval_Stmt : Boolean); -- Append either a declaration (which is to be elaborated -- unconditionally) or an evaluation statement (which is -- to be executed conditionally). ------------------------------- -- Append_For_Indirect_Temp -- ------------------------------- procedure Append_For_Indirect_Temp (N : Node_Id; Is_Eval_Stmt : Boolean) is begin if Is_Eval_Stmt then Append_To (Eval_Stmts, N); else Prepend_To (Decls, N); -- This use of Prepend (as opposed to Append) is why -- we have the Append_Decls_In_Reverse_Order parameter. end if; end Append_For_Indirect_Temp; procedure Declare_Indirect_Temporary is new Declare_Indirect_Temp ( Append_Item => Append_For_Indirect_Temp, Append_Decls_In_Reverse_Order => True); -- Start of processing for Expand_Attributes begin -- Attribute 'Old if Is_Attribute_Old (N) then Pref := Prefix (N); Indirect := Indirect_Temp_Needed (Etype (Pref)); if Indirect then if No (Eval_Stmts) then Eval_Stmts := New_List; end if; Declare_Indirect_Temporary (Attr_Prefix => Pref, Indirect_Temp => Temp); -- Declare a temporary of the prefix type with no explicit -- initial value. If the appropriate contract case is selected -- at run time, then the temporary will be initialized via an -- assignment statement. else Temp := Make_Temporary (Loc, 'T', Pref); Set_Etype (Temp, Etype (Pref)); -- Generate a temporary to capture the value of the prefix: -- Temp : ; Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Etype (Pref), Loc)); -- Place that temporary at the beginning of declarations, to -- prevent anomalies in the GNATprove flow-analysis pass in -- the precondition procedure that follows. Prepend_To (Decls, Decl); -- Initially Temp is uninitialized (which is required for -- correctness if default initialization might have side -- effects). Assign prefix value to temp on Eval_Statement -- list, so assignment will be executed conditionally. Mutate_Ekind (Temp, E_Variable); Set_Suppress_Initialization (Temp); Analyze (Decl); if No (Eval_Stmts) then Eval_Stmts := New_List; end if; Append_To (Eval_Stmts, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Temp, Loc), Expression => Pref)); end if; -- Mark the temporary as coming from a 'Old reference if Present (Temp) then Set_Stores_Attribute_Old_Prefix (Temp); end if; -- Ensure that the prefix is valid if Validity_Checks_On and then Validity_Check_Operands then Ensure_Valid (Pref); end if; -- Replace the original attribute 'Old by a reference to the -- generated temporary. if Indirect then Rewrite (N, Indirect_Temp_Value (Temp => Temp, Typ => Etype (Pref), Loc => Loc)); else Rewrite (N, New_Occurrence_Of (Temp, Loc)); end if; -- Attribute 'Result elsif Is_Attribute_Result (N) then Rewrite (N, Make_Identifier (Loc, Name_uResult)); end if; return OK; end Expand_Attributes; procedure Expand_Attributes_In is new Traverse_Proc (Expand_Attributes); -- Start of processing for Expand_Attributes_In_Consequence begin -- Inspect the consequence and expand any attribute 'Old and 'Result -- references found within. Expand_Attributes_In (Conseq); -- The consequence does not contain any attribute 'Old references if No (Eval_Stmts) then return; end if; -- Augment the machinery to trigger the evaluation of all prefixes -- found in the step above. If Eval is empty, then this is the first -- consequence to yield expansion of 'Old. Generate: -- if Flag then -- -- end if; if No (Evals) then Evals := Make_Implicit_If_Statement (CCs, Condition => New_Occurrence_Of (Flag, Loc), Then_Statements => Eval_Stmts); Set_Comes_From_Check_Or_Contract (Evals); -- Otherwise generate: -- elsif Flag then -- -- end if; else if No (Elsif_Parts (Evals)) then Set_Elsif_Parts (Evals, New_List); end if; Append_To (Elsif_Parts (Evals), Make_Elsif_Part (Loc, Condition => New_Occurrence_Of (Flag, Loc), Then_Statements => Eval_Stmts)); end if; end Expand_Attributes_In_Consequence; --------------- -- Increment -- --------------- function Increment (Id : Entity_Id) return Node_Id is begin return Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Id, Loc), Expression => Make_Op_Add (Loc, Left_Opnd => New_Occurrence_Of (Id, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1))); end Increment; --------- -- Set -- --------- function Set (Id : Entity_Id) return Node_Id is begin return Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Id, Loc), Expression => New_Occurrence_Of (Standard_True, Loc)); end Set; -- Local variables Aggr : constant Node_Id := Expression (First (Pragma_Argument_Associations (CCs))); Case_Guard : Node_Id; CG_Checks : Node_Id; CG_Stmts : List_Id; Conseq : Node_Id; Conseq_Checks : Node_Id := Empty; Count : Entity_Id; Count_Decl : Node_Id; Error_Decls : List_Id := No_List; -- init to avoid warning Flag : Entity_Id; Flag_Decl : Node_Id; If_Stmt : Node_Id; Msg_Str : Entity_Id := Empty; Multiple_PCs : Boolean; Old_Evals : Node_Id := Empty; Others_Decl : Node_Id; Others_Flag : Entity_Id := Empty; Post_Case : Node_Id; -- Start of processing for Expand_Pragma_Contract_Cases begin -- Do nothing if pragma is not enabled. If pragma is disabled, it has -- already been rewritten as a Null statement. if Is_Ignored (CCs) then return; -- Guard against malformed contract cases elsif Nkind (Aggr) /= N_Aggregate then return; end if; -- The expansion of contract cases is quite distributed as it produces -- various statements to evaluate the case guards and consequences. To -- preserve the original context, set the Is_Assertion_Expr flag. This -- aids the Ghost legality checks when verifying the placement of a -- reference to a Ghost entity. In_Assertion_Expr := In_Assertion_Expr + 1; Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1; -- Create the counter which tracks the number of case guards that -- evaluate to True. -- Count : Natural := 0; Count := Make_Temporary (Loc, 'C'); Count_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Count, Object_Definition => New_Occurrence_Of (Standard_Natural, Loc), Expression => Make_Integer_Literal (Loc, 0)); Prepend_To (Decls, Count_Decl); Analyze (Count_Decl); -- Create the base error message for multiple overlapping case guards -- Msg_Str : constant String := -- "contract cases overlap for subprogram Subp_Id"; if Multiple_PCs then Msg_Str := Make_Temporary (Loc, 'S'); Start_String; Store_String_Chars ("contract cases overlap for subprogram "); Store_String_Chars (Get_Name_String (Chars (Subp_Id))); Error_Decls := New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Msg_Str, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, End_String))); end if; -- Process individual post cases Post_Case := First (Component_Associations (Aggr)); while Present (Post_Case) loop Case_Guard := First (Choices (Post_Case)); Conseq := Expression (Post_Case); -- The "others" choice requires special processing if Nkind (Case_Guard) = N_Others_Choice then Others_Flag := Make_Temporary (Loc, 'F'); Others_Decl := Declaration_Of (Others_Flag); Prepend_To (Decls, Others_Decl); Analyze (Others_Decl); -- Check possible overlap between a case guard and "others" if Multiple_PCs and Exception_Extra_Info then Case_Guard_Error (Decls => Error_Decls, Flag => Others_Flag, Error_Loc => Sloc (Case_Guard), Msg => Msg_Str); end if; -- Inspect the consequence and perform special expansion of any -- attribute 'Old and 'Result references found within. Expand_Attributes_In_Consequence (Decls => Decls, Evals => Old_Evals, Flag => Others_Flag, Conseq => Conseq); -- Check the corresponding consequence of "others" Consequence_Error (Checks => Conseq_Checks, Flag => Others_Flag, Conseq => Conseq); -- Regular post case else -- Create the flag which tracks the state of its associated case -- guard. Flag := Make_Temporary (Loc, 'F'); Flag_Decl := Declaration_Of (Flag); Prepend_To (Decls, Flag_Decl); Analyze (Flag_Decl); -- The flag is set when the case guard is evaluated to True -- if Case_Guard then -- Flag := True; -- Count := Count + 1; -- end if; If_Stmt := Make_Implicit_If_Statement (CCs, Condition => Relocate_Node (Case_Guard), Then_Statements => New_List ( Set (Flag), Increment (Count))); Set_Comes_From_Check_Or_Contract (If_Stmt); Append_To (Decls, If_Stmt); Analyze (If_Stmt); -- Check whether this case guard overlaps with another one if Multiple_PCs and Exception_Extra_Info then Case_Guard_Error (Decls => Error_Decls, Flag => Flag, Error_Loc => Sloc (Case_Guard), Msg => Msg_Str); end if; -- Inspect the consequence and perform special expansion of any -- attribute 'Old and 'Result references found within. Expand_Attributes_In_Consequence (Decls => Decls, Evals => Old_Evals, Flag => Flag, Conseq => Conseq); -- The corresponding consequence of the case guard which evaluated -- to True must hold on exit from the subprogram. Consequence_Error (Checks => Conseq_Checks, Flag => Flag, Conseq => Conseq); end if; Next (Post_Case); end loop; -- Raise Assertion_Error when none of the case guards evaluate to True. -- The only exception is when we have "others", in which case there is -- no error because "others" acts as a default True. -- Generate: -- Flag := True; if Present (Others_Flag) then CG_Stmts := New_List (Set (Others_Flag)); -- Generate: -- raise Assertion_Error with "xxx contract cases incomplete"; else Start_String; Store_String_Chars (Build_Location_String (Loc)); Store_String_Chars (" contract cases incomplete"); CG_Stmts := New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, End_String)))); end if; CG_Checks := Make_Implicit_If_Statement (CCs, Condition => Make_Op_Eq (Loc, Left_Opnd => New_Occurrence_Of (Count, Loc), Right_Opnd => Make_Integer_Literal (Loc, 0)), Then_Statements => CG_Stmts); Set_Comes_From_Check_Or_Contract (CG_Checks); -- Detect a possible failure due to several case guards evaluating to -- True. -- Generate: -- elsif Count > 0 then -- declare -- -- begin -- raise Assertion_Error with ; -- end if; if Multiple_PCs then Set_Elsif_Parts (CG_Checks, New_List ( Make_Elsif_Part (Loc, Condition => Make_Op_Gt (Loc, Left_Opnd => New_Occurrence_Of (Count, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1)), Then_Statements => New_List ( Make_Block_Statement (Loc, Declarations => Error_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Msg_Str, Loc)))))))))); end if; -- Append the checks, but do not analyze them at this point, because -- contracts get potentially expanded as part of a wrapper which gets -- fully analyzed once it is fully formed. Append_To (Decls, CG_Checks); -- Once all case guards are evaluated and checked, evaluate any prefixes -- of attribute 'Old founds in the selected consequence. if Present (Old_Evals) then Append_To (Decls, Old_Evals); end if; -- Raise Assertion_Error when the corresponding consequence of a case -- guard that evaluated to True fails. Append_New_To (Stmts, Conseq_Checks); In_Assertion_Expr := In_Assertion_Expr - 1; end Expand_Pragma_Contract_Cases; --------------------------------------- -- Expand_Pragma_Import_Or_Interface -- --------------------------------------- procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is Def_Id : Entity_Id; begin -- In Relaxed_RM_Semantics, support old Ada 83 style: -- pragma Import (Entity, "external name"); if Relaxed_RM_Semantics and then List_Length (Pragma_Argument_Associations (N)) = 2 and then Pragma_Name (N) = Name_Import and then Nkind (Arg_N (N, 2)) = N_String_Literal then Def_Id := Entity (Arg_N (N, 1)); else Def_Id := Entity (Arg_N (N, 2)); end if; -- Variable case (we have to undo any initialization already done) if Ekind (Def_Id) = E_Variable then Undo_Initialization (Def_Id, N); -- Case of exception with convention C++ elsif Ekind (Def_Id) = E_Exception and then Convention (Def_Id) = Convention_CPP then -- Import a C++ convention declare Loc : constant Source_Ptr := Sloc (N); Rtti_Name : constant Node_Id := Arg_N (N, 3); Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); Exdata : List_Id; Lang_Char : Node_Id; Foreign_Data : Node_Id; begin Exdata := Component_Associations (Expression (Parent (Def_Id))); Lang_Char := Next (First (Exdata)); -- Change the one-character language designator to 'C' Rewrite (Expression (Lang_Char), Make_Character_Literal (Loc, Chars => Name_uC, Char_Literal_Value => UI_From_CC (Get_Char_Code ('C')))); Analyze (Expression (Lang_Char)); -- Change the value of Foreign_Data Foreign_Data := Next (Next (Next (Next (Lang_Char)))); Insert_Actions (Def_Id, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Dum, Object_Definition => New_Occurrence_Of (Standard_Character, Loc)), Make_Pragma (Loc, Chars => Name_Import, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_Ada)), Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Chars (Dum))), Make_Pragma_Argument_Association (Loc, Chars => Name_External_Name, Expression => Relocate_Node (Rtti_Name)))))); Rewrite (Expression (Foreign_Data), OK_Convert_To (Standard_Address, Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (Dum)), Attribute_Name => Name_Address))); Analyze (Expression (Foreign_Data)); end; -- No special expansion required for any other case else null; end if; end Expand_Pragma_Import_Or_Interface; ------------------------------------- -- Expand_Pragma_Initial_Condition -- ------------------------------------- procedure Expand_Pragma_Initial_Condition (Pack_Id : Entity_Id; N : Node_Id) is procedure Extract_Package_Body_Lists (Pack_Body : Node_Id; Body_List : out List_Id; Call_List : out List_Id; Spec_List : out List_Id); -- Obtain the various declarative and statement lists of package body -- Pack_Body needed to insert the initial condition procedure and the -- call to it. The lists are as follows: -- -- * Body_List - used to insert the initial condition procedure body -- -- * Call_List - used to insert the call to the initial condition -- procedure. -- -- * Spec_List - used to insert the initial condition procedure spec procedure Extract_Package_Declaration_Lists (Pack_Decl : Node_Id; Body_List : out List_Id; Call_List : out List_Id; Spec_List : out List_Id); -- Obtain the various declarative lists of package declaration Pack_Decl -- needed to insert the initial condition procedure and the call to it. -- The lists are as follows: -- -- * Body_List - used to insert the initial condition procedure body -- -- * Call_List - used to insert the call to the initial condition -- procedure. -- -- * Spec_List - used to insert the initial condition procedure spec -------------------------------- -- Extract_Package_Body_Lists -- -------------------------------- procedure Extract_Package_Body_Lists (Pack_Body : Node_Id; Body_List : out List_Id; Call_List : out List_Id; Spec_List : out List_Id) is Pack_Spec : constant Entity_Id := Corresponding_Spec (Pack_Body); Dummy_1 : List_Id; Dummy_2 : List_Id; HSS : Node_Id; begin pragma Assert (Present (Pack_Spec)); -- The different parts of the invariant procedure are inserted as -- follows: -- package Pack is package body Pack is -- -- private begin -- ... -- end Pack; end Pack; -- The initial condition procedure spec is inserted in the visible -- declaration of the corresponding package spec. Extract_Package_Declaration_Lists (Pack_Decl => Unit_Declaration_Node (Pack_Spec), Body_List => Dummy_1, Call_List => Dummy_2, Spec_List => Spec_List); -- The initial condition procedure body is added to the declarations -- of the package body. Body_List := Declarations (Pack_Body); if No (Body_List) then Body_List := New_List; Set_Declarations (Pack_Body, Body_List); end if; -- The call to the initial condition procedure is inserted in the -- statements of the package body. HSS := Handled_Statement_Sequence (Pack_Body); if No (HSS) then HSS := Make_Handled_Sequence_Of_Statements (Sloc (Pack_Body), Statements => New_List); Set_Handled_Statement_Sequence (Pack_Body, HSS); end if; Call_List := Statements (HSS); end Extract_Package_Body_Lists; --------------------------------------- -- Extract_Package_Declaration_Lists -- --------------------------------------- procedure Extract_Package_Declaration_Lists (Pack_Decl : Node_Id; Body_List : out List_Id; Call_List : out List_Id; Spec_List : out List_Id) is Pack_Spec : constant Node_Id := Specification (Pack_Decl); begin -- The different parts of the invariant procedure are inserted as -- follows: -- package Pack is -- -- -- private -- -- end Pack; -- The initial condition procedure spec and body are inserted in the -- visible declarations of the package spec. Body_List := Visible_Declarations (Pack_Spec); if No (Body_List) then Body_List := New_List; Set_Visible_Declarations (Pack_Spec, Body_List); end if; Spec_List := Body_List; -- The call to the initial procedure is inserted in the private -- declarations of the package spec. Call_List := Private_Declarations (Pack_Spec); if No (Call_List) then Call_List := New_List; Set_Private_Declarations (Pack_Spec, Call_List); end if; end Extract_Package_Declaration_Lists; -- Local variables IC_Prag : constant Node_Id := Get_Pragma (Pack_Id, Pragma_Initial_Condition); Body_List : List_Id; Call : Node_Id; Call_List : List_Id; Call_Loc : Source_Ptr; Expr : Node_Id; Loc : Source_Ptr; Proc_Body : Node_Id; Proc_Body_Id : Entity_Id; Proc_Decl : Node_Id; Proc_Id : Entity_Id; Spec_List : List_Id; -- Start of processing for Expand_Pragma_Initial_Condition begin -- Nothing to do when the package is not subject to an Initial_Condition -- pragma. if No (IC_Prag) then return; end if; Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (IC_Prag))); Loc := Sloc (IC_Prag); -- Nothing to do when the pragma is ignored because its semantics are -- suppressed. if Is_Ignored (IC_Prag) then return; -- Nothing to do when the pragma or its argument are illegal because -- there is no valid expression to check. elsif Error_Posted (IC_Prag) or else Error_Posted (Expr) then return; end if; -- Obtain the various lists of the context where the individual pieces -- of the initial condition procedure are to be inserted. if Nkind (N) = N_Package_Body then Extract_Package_Body_Lists (Pack_Body => N, Body_List => Body_List, Call_List => Call_List, Spec_List => Spec_List); elsif Nkind (N) = N_Package_Declaration then Extract_Package_Declaration_Lists (Pack_Decl => N, Body_List => Body_List, Call_List => Call_List, Spec_List => Spec_List); -- This routine should not be used on anything other than packages else pragma Assert (False); return; end if; Proc_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Pack_Id), "Initial_Condition")); Mutate_Ekind (Proc_Id, E_Procedure); Set_Is_Initial_Condition_Procedure (Proc_Id); -- Generate: -- procedure Initial_Condition; Proc_Decl := Make_Subprogram_Declaration (Loc, Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc_Id)); Append_To (Spec_List, Proc_Decl); -- The initial condition procedure requires debug info when initial -- condition is subject to Source Coverage Obligations. if Generate_SCO then Set_Debug_Info_Needed (Proc_Id); end if; -- Generate: -- procedure Initial_Condition is -- begin -- pragma Check (Initial_Condition, ); -- end Initial_Condition; Proc_Body := Make_Subprogram_Body (Loc, Specification => Copy_Subprogram_Spec (Specification (Proc_Decl)), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Pragma (Loc, Chars => Name_Check, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_Initial_Condition)), Make_Pragma_Argument_Association (Loc, Expression => New_Copy_Tree (Expr))))))); Append_To (Body_List, Proc_Body); -- The initial condition procedure requires debug info when initial -- condition is subject to Source Coverage Obligations. Proc_Body_Id := Defining_Entity (Proc_Body); if Generate_SCO then Set_Debug_Info_Needed (Proc_Body_Id); end if; -- The location of the initial condition procedure call must be as close -- as possible to the intended semantic location of the check because -- the ABE mechanism relies heavily on accurate locations. Call_Loc := End_Keyword_Location (N); -- Generate: -- Initial_Condition; Call := Make_Procedure_Call_Statement (Call_Loc, Name => New_Occurrence_Of (Proc_Id, Call_Loc)); Append_To (Call_List, Call); Analyze (Proc_Decl); Analyze (Proc_Body); Analyze (Call); end Expand_Pragma_Initial_Condition; ------------------------------------ -- 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; E : Entity_Id; Rip : Boolean; S : 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 not Is_Formal_Object (E) and then Ekind (E) /= E_Component and then Ekind (E) /= E_Discriminant 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; -- Process the arguments of the pragma Rip := False; Assoc := First (Pragma_Argument_Associations (N)); while Present (Assoc) loop -- The back end may need to take the address of the object Set_Address_Taken (Entity (Expression (Assoc))); -- If any of the objects have a freeze node, it must appear before -- pragma Inspection_Point, otherwise the entity won't be elaborated -- when Gigi processes the pragma. if Has_Delayed_Freeze (Entity (Expression (Assoc))) and then not Is_Frozen (Entity (Expression (Assoc))) then Error_Msg_NE ("??inspection point references unfrozen object &", Assoc, Entity (Expression (Assoc))); Rip := True; end if; Next (Assoc); end loop; -- When the above requirement isn't met, turn the pragma into a no-op if Rip then Error_Msg_N ("\pragma will be ignored", N); -- We can't just remove the pragma from the tree as it might be -- iterated over by the caller. Turn it into a null statement -- instead. Rewrite (N, Make_Null_Statement (Loc)); end if; 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 Check (Loop_Variant, Curr_1 > Old_1); -- else -- pragma Check (Loop_Variant, 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 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; 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_Occurrence_Of (Standard_Boolean, Loop_Loc), Expression => New_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (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 -- Generate: -- Old := Curr; Append_New_To (Old_Assign, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Old_Id, Loc), Expression => New_Occurrence_Of (Curr_Id, Loc))); -- Step 4: Store the current value of the expression -- Generate: -- Curr := ; Append_New_To (Curr_Assign, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Curr_Id, Loc), Expression => Relocate_Node (Expr))); -- Step 5: Create corresponding assertion to verify change of value -- Generate: -- pragma Check (Loop_Variant, Curr <|> Old); Prag := Make_Pragma (Loc, Chars => Name_Check, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_Loop_Variant)), Make_Pragma_Argument_Association (Loc, Expression => Make_Variant_Comparison (Loc, Mode => Chars (Variant), Typ => Expr_Typ, Curr_Val => New_Occurrence_Of (Curr_Id, Loc), Old_Val => New_Occurrence_Of (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_Occurrence_Of (Curr_Id, Loc), Right_Opnd => New_Occurrence_Of (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_Occurrence_Of (Curr_Id, Loc), Right_Opnd => New_Occurrence_Of (Old_Id, Loc)), Then_Statements => New_List (Prag))); end if; end Process_Variant; -- Start of processing for Expand_Pragma_Loop_Variant begin -- If pragma is not enabled, rewrite as Null statement. If pragma is -- disabled, it has already been rewritten as a Null statement. -- -- Likewise, ignore structural variants for execution. -- -- Also do this in CodePeer mode, because the expanded code is too -- complicated for CodePeer to analyse. if Is_Ignored (N) or else Chars (Last_Var) = Name_Structural or else CodePeer_Mode then Rewrite (N, Make_Null_Statement (Loc)); Analyze (N); return; end if; -- The expansion of Loop_Variant is quite distributed as it produces -- various statements to capture and compare the arguments. To preserve -- the original context, set the Is_Assertion_Expr flag. This aids the -- Ghost legality checks when verifying the placement of a reference to -- a Ghost entity. In_Assertion_Expr := In_Assertion_Expr + 1; -- 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_Occurrence_Of (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_Occurrence_Of (Flag_Id, Loc), Then_Statements => New_List (If_Stmt), Else_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Flag_Id, Loc), Expression => New_Occurrence_Of (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. In_Assertion_Expr := In_Assertion_Expr - 1; 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_Occurrence_Of (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_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), New_List (Make_Function_Call (Loc, New_Occurrence_Of (RTE (RE_Clock), Loc)))), Right_Opnd => Unchecked_Convert_To ( Standard_Duration, Arg_N (N, 1))))))); Analyze (N); end if; end Expand_Pragma_Relative_Deadline; -------------------------------------- -- Expand_Pragma_Subprogram_Variant -- -------------------------------------- -- Aspect Subprogram_Variant is expanded in the following manner: -- Original code -- procedure Proc (Param : T) with -- with Variant (Increases => Incr_Expr, -- Decreases => Decr_Expr) -- -- is -- -- Proc (New_Param_Value); -- end Proc; -- Expanded code -- procedure Proc (Param : T) is -- Old_Incr : constant := ; -- Old_Decr : constant := ; -- -- procedure Variants (Param : T); -- -- procedure Variants (Param : T) is -- Curr_Incr : constant := ; -- Curr_Decr : constant := ; -- begin -- if Curr_Incr /= Old_Incr then -- pragma Check (Variant, Curr_Incr > Old_Incr); -- else -- pragma Check (Variant, Curr_Decr < Old_Decr); -- end if; -- end Variants; -- -- -- begin -- -- Variants (New_Param_Value); -- Proc (New_Param_Value); -- end Proc; procedure Expand_Pragma_Subprogram_Variant (Prag : Node_Id; Subp_Id : Entity_Id; Body_Decls : List_Id) is Curr_Decls : List_Id; If_Stmt : Node_Id := Empty; function Formal_Param_Map (Old_Subp : Entity_Id; New_Subp : Entity_Id) return Elist_Id; -- Given two subprogram entities Old_Subp and New_Subp with the same -- number of formal parameters return a list of the form: -- -- old formal 1 -- new formal 1 -- old formal 2 -- new formal 2 -- ... -- -- as required by New_Copy_Tree to replace references to formal -- parameters of Old_Subp with references to formal parameters of -- New_Subp. procedure Process_Variant (Variant : Node_Id; Formal_Map : Elist_Id; Prev_Decl : in out Node_Id; Is_Last : Boolean); -- Process a single increasing / decreasing termination variant given by -- a component association Variant. Formal_Map is a list of formal -- parameters of the annotated subprogram and of the internal procedure -- that verifies the variant in the format required by New_Copy_Tree. -- The Old_... object created by this routine will be appended after -- Prev_Decl and is stored in this parameter for a next call to this -- routine. Is_Last is True when there are no more variants to process. ---------------------- -- Formal_Param_Map -- ---------------------- function Formal_Param_Map (Old_Subp : Entity_Id; New_Subp : Entity_Id) return Elist_Id is Old_Formal : Entity_Id := First_Formal (Old_Subp); New_Formal : Entity_Id := First_Formal (New_Subp); Param_Map : Elist_Id; begin if Present (Old_Formal) then Param_Map := New_Elmt_List; while Present (Old_Formal) and then Present (New_Formal) loop Append_Elmt (Old_Formal, Param_Map); Append_Elmt (New_Formal, Param_Map); Next_Formal (Old_Formal); Next_Formal (New_Formal); end loop; return Param_Map; else return No_Elist; end if; end Formal_Param_Map; --------------------- -- Process_Variant -- --------------------- procedure Process_Variant (Variant : Node_Id; Formal_Map : Elist_Id; Prev_Decl : in out Node_Id; Is_Last : Boolean) is Expr : constant Node_Id := Expression (Variant); Expr_Typ : constant Entity_Id := Etype (Expr); Loc : constant Source_Ptr := Sloc (Expr); Old_Id : Entity_Id; Old_Decl : Node_Id; Curr_Id : Entity_Id; Curr_Decl : Node_Id; Prag : Node_Id; begin -- Create temporaries that store the old values of the associated -- expression. -- Generate: -- Old : constant := ; Old_Id := Make_Temporary (Loc, 'P'); Old_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Old_Id, Constant_Present => True, Object_Definition => New_Occurrence_Of (Expr_Typ, Loc), Expression => New_Copy_Tree (Expr)); Insert_After_And_Analyze (Prev_Decl, Old_Decl); Prev_Decl := Old_Decl; -- Generate: -- Curr : constant := ; Curr_Id := Make_Temporary (Loc, 'C'); Curr_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Curr_Id, Constant_Present => True, Object_Definition => New_Occurrence_Of (Expr_Typ, Loc), Expression => New_Copy_Tree (Expr, Map => Formal_Map)); Append (Curr_Decl, Curr_Decls); -- Generate: -- pragma Check (Variant, Curr <|> Old); Prag := Make_Pragma (Loc, Chars => Name_Check, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_Subprogram_Variant)), Make_Pragma_Argument_Association (Loc, Expression => Make_Variant_Comparison (Loc, Mode => Chars (First (Choices (Variant))), Typ => Expr_Typ, Curr_Val => New_Occurrence_Of (Curr_Id, Loc), Old_Val => New_Occurrence_Of (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_Occurrence_Of (Curr_Id, Loc), Right_Opnd => New_Occurrence_Of (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_Occurrence_Of (Curr_Id, Loc), Right_Opnd => New_Occurrence_Of (Old_Id, Loc)), Then_Statements => New_List (Prag))); end if; end Process_Variant; -- Local variables Loc : constant Source_Ptr := Sloc (Prag); Aggr : constant Node_Id := Expression (First (Pragma_Argument_Associations (Prag))); Formal_Map : Elist_Id; Last : Node_Id; Last_Variant : constant Node_Id := Nlists.Last (Component_Associations (Aggr)); Proc_Bod : Node_Id; Proc_Decl : Node_Id; Proc_Id : Entity_Id; Proc_Spec : Node_Id; Variant : Node_Id; begin -- Do nothing if pragma is not present or is disabled. -- Also ignore structural variants for execution. if Is_Ignored (Prag) or else Chars (Nlists.Last (Choices (Last_Variant))) = Name_Structural then return; end if; -- The expansion of Subprogram Variant is quite distributed as it -- produces various statements to capture and compare the arguments. -- To preserve the original context, set the Is_Assertion_Expr flag. -- This aids the Ghost legality checks when verifying the placement -- of a reference to a Ghost entity. In_Assertion_Expr := In_Assertion_Expr + 1; -- Create declaration of the procedure that compares values of the -- variant expressions captured at the start of subprogram with their -- values at the recursive call of the subprogram. Proc_Id := Make_Defining_Identifier (Loc, Name_uVariants); Proc_Spec := Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc_Id, Parameter_Specifications => Copy_Parameter_List (Subp_Id)); Proc_Decl := Make_Subprogram_Declaration (Loc, Proc_Spec); Insert_Before_First_Source_Declaration (Proc_Decl, Body_Decls); Analyze (Proc_Decl); -- Create a mapping between formals of the annotated subprogram (which -- are used to compute values of the variant expression at the start of -- subprogram) and formals of the internal procedure (which are used to -- compute values of of the variant expression at the recursive call). Formal_Map := Formal_Param_Map (Old_Subp => Subp_Id, New_Subp => Proc_Id); -- Process invidual increasing / decreasing variants Last := Proc_Decl; Curr_Decls := New_List; Variant := First (Component_Associations (Aggr)); while Present (Variant) loop Process_Variant (Variant => Variant, Formal_Map => Formal_Map, Prev_Decl => Last, Is_Last => Variant = Last_Variant); Next (Variant); end loop; -- Create a subprogram body with declarations of objects that capture -- the current values of variant expressions at a recursive call and an -- if-then-else statement that compares current with old values. Proc_Bod := Make_Subprogram_Body (Loc, Specification => Copy_Subprogram_Spec (Proc_Spec), Declarations => Curr_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (If_Stmt), End_Label => Make_Identifier (Loc, Chars (Proc_Id)))); Insert_After_And_Analyze (Last, Proc_Bod); -- Restore assertion context In_Assertion_Expr := In_Assertion_Expr - 1; -- Rewrite the aspect expression, which is no longer needed, with -- a reference to the procedure that has just been created. We will -- generate a call to this procedure at each recursive call of the -- subprogram that has been annotated with Subprogram_Variant. Rewrite (Aggr, New_Occurrence_Of (Proc_Id, Loc)); end Expand_Pragma_Subprogram_Variant; ------------------------------------------- -- Expand_Pragma_Suppress_Initialization -- ------------------------------------------- procedure Expand_Pragma_Suppress_Initialization (N : Node_Id) is Def_Id : constant Entity_Id := Entity (Arg_N (N, 1)); begin -- Variable case (we have to undo any initialization already done) if Ekind (Def_Id) = E_Variable then Undo_Initialization (Def_Id, N); end if; end Expand_Pragma_Suppress_Initialization; ------------------------- -- Undo_Initialization -- ------------------------- procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id) is Init_Call : Node_Id; begin -- 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 to the initialization procedure which followed the object -- declaration. The call is inserted after the declaration, but validity -- checks may also have been inserted and thus 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 (so -- this elaboration cannot be deferred to the freeze point). -- 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; -- The object may not have any initialization, but in the presence of -- Initialize_Scalars code is inserted after then declaration, which -- must now be removed as well. The code carries the same source -- location as the declaration itself. if Initialize_Scalars and then Is_Array_Type (Etype (Def_Id)) then declare Init : Node_Id; Nxt : Node_Id; begin Init := Next (Parent (Def_Id)); while not Comes_From_Source (Init) and then Sloc (Init) = Sloc (Def_Id) loop Nxt := Next (Init); Remove (Init); Init := Nxt; end loop; end; end if; end Undo_Initialization; end Exp_Prag;