| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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 Expander; use Expander; |
| 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) |
| and then Nkind (Arg) = N_Pragma_Argument_Association |
| then |
| return Expression (Arg); |
| else |
| return Arg; |
| 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 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. |
| -- 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)))))))); |
| |
| -- 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)))))); |
| 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_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_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 := <Mem or 0>; |
| -- Stream_Id : CUDA.Driver_Types.Stream_T := <Stream or null>; |
| -- X_Id : <Type of X> := X; |
| -- Y_Id : <Type of Y> := 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 Elmts = No_Elist 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 : ...; |
| |
| -- <preconditions (if any)> |
| |
| -- -- 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"; |
| -- <or> |
| -- 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 := <prefix of 'Old found in Consequence_1> |
| -- . . . |
| -- elsif Flag_N then |
| -- Pref_M := <prefix of 'Old found in Consequence_N> |
| -- end if; |
| |
| -- procedure _Postconditions is |
| -- begin |
| -- <postconditions (if any)> |
| |
| -- 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)); |
| |
| 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 : <Pref type>; |
| |
| 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 |
| -- <evaluation statements> |
| -- end if; |
| |
| if No (Evals) then |
| Evals := |
| Make_Implicit_If_Statement (CCs, |
| Condition => New_Occurrence_Of (Flag, Loc), |
| Then_Statements => Eval_Stmts); |
| |
| -- Otherwise generate: |
| -- elsif Flag then |
| -- <evaluation statements> |
| -- 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))); |
| |
| 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); |
| |
| -- Detect a possible failure due to several case guards evaluating to |
| -- True. |
| |
| -- Generate: |
| -- elsif Count > 0 then |
| -- declare |
| -- <Error_Decls> |
| -- begin |
| -- raise Assertion_Error with <Msg_Str>; |
| -- 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_To (Decls, CG_Checks); |
| Analyze (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); |
| Analyze (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_Int (Character'Pos ('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 |
| -- <IC spec> <IC body> |
| -- private begin |
| -- ... <IC call> |
| -- 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 |
| -- <IC spec> |
| -- <IC body> |
| -- private |
| -- <IC call> |
| -- 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 <Pack_Id>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 <Pack_Id>Initial_Condition is |
| -- begin |
| -- pragma Check (Initial_Condition, <Expr>); |
| -- end <Pack_Id>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: |
| -- <Pack_Id>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 and expand them. 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 require this ??? |
| |
| 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))); |
| |
| Expand (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 |
| -- <preceding source statements> |
| -- pragma Loop_Variant |
| -- (Increases => Incr_Expr, |
| -- Decreases => Decr_Expr); |
| -- <succeeding source statements> |
| -- end loop; |
| |
| -- Expanded code |
| |
| -- Curr_1 : <type of Incr_Expr>; |
| -- Curr_2 : <type of Decr_Expr>; |
| -- Old_1 : <type of Incr_Expr>; |
| -- Old_2 : <type of Decr_Expr>; |
| -- Flag : Boolean := False; |
| |
| -- for | while ... loop |
| -- <preceding source statements> |
| |
| -- if Flag then |
| -- Old_1 := Curr_1; |
| -- Old_2 := Curr_2; |
| -- end if; |
| |
| -- Curr_1 := <Incr_Expr>; |
| -- Curr_2 := <Decr_Expr>; |
| |
| -- 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; |
| |
| -- <succeeding source statements> |
| -- 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 : <type of Expr>; |
| |
| 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 : <type of Expr>; |
| |
| 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 := <Expr>; |
| |
| 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), |
| Curr_Val => New_Occurrence_Of (Curr_Id, Loc), |
| Old_Val => New_Occurrence_Of (Old_Id, Loc))))); |
| |
| -- Generate: |
| -- if Curr /= Old then |
| -- <Prag>; |
| |
| 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 |
| -- <Prag>; |
| -- end if; |
| |
| elsif Is_Last then |
| Set_Else_Statements (If_Stmt, New_List (Prag)); |
| |
| -- Generate: |
| -- elsif Curr /= Old then |
| -- <Prag>; |
| |
| 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, do this in CodePeer mode, because the expanded code is too |
| -- complicated for CodePeer to analyse. |
| |
| if Is_Ignored (N) 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 |
| -- <Old_Assign> |
| -- 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 |
| -- <If_Stmt> |
| -- 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) |
| -- <declarations> |
| -- is |
| -- <source statements> |
| -- Proc (New_Param_Value); |
| -- end Proc; |
| |
| -- Expanded code |
| |
| -- procedure Proc (Param : T) is |
| -- Old_Incr : constant <type of Incr_Expr> := <Incr_Expr>; |
| -- Old_Decr : constant <type of Decr_Expr> := <Decr_Expr> ; |
| -- |
| -- procedure Variants (Param : T); |
| -- |
| -- procedure Variants (Param : T) is |
| -- Curr_Incr : constant <type of Incr_Expr> := <Incr_Expr>; |
| -- Curr_Decr : constant <type of Decr_Expr> := <Decr_Expr>; |
| -- 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; |
| -- |
| -- <declarations> |
| -- begin |
| -- <source statements> |
| -- 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 <type of Expr> := <Expr>; |
| |
| 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 <type of Expr> := <Expr>; |
| |
| 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))), |
| Curr_Val => New_Occurrence_Of (Curr_Id, Loc), |
| Old_Val => New_Occurrence_Of (Old_Id, Loc))))); |
| |
| -- Generate: |
| -- if Curr /= Old then |
| -- <Prag>; |
| |
| 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 |
| -- <Prag>; |
| -- end if; |
| |
| elsif Is_Last then |
| Set_Else_Statements (If_Stmt, New_List (Prag)); |
| |
| -- Generate: |
| -- elsif Curr /= Old then |
| -- <Prag>; |
| |
| 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 : Node_Id; |
| Formal_Map : Elist_Id; |
| Last : Node_Id; |
| Last_Variant : Node_Id; |
| 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 |
| |
| if Is_Ignored (Prag) then |
| return; |
| end if; |
| |
| Aggr := Expression (First (Pragma_Argument_Associations (Prag))); |
| |
| -- 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; |
| Last_Variant := Nlists.Last (Component_Associations (Aggr)); |
| |
| 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; |