diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/exp_prag.adb')
| -rw-r--r-- | gcc-4.9/gcc/ada/exp_prag.adb | 1939 |
1 files changed, 1939 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/exp_prag.adb b/gcc-4.9/gcc/ada/exp_prag.adb new file mode 100644 index 000000000..1925012b8 --- /dev/null +++ b/gcc-4.9/gcc/ada/exp_prag.adb @@ -0,0 +1,1939 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P R A G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch11; use Exp_Ch11; +with Exp_Util; use Exp_Util; +with Expander; use Expander; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Validsw; use Validsw; + +package body Exp_Prag is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Arg1 (N : Node_Id) return Node_Id; + function Arg2 (N : Node_Id) return Node_Id; + function Arg3 (N : Node_Id) return Node_Id; + -- Obtain specified pragma argument expression + + procedure Expand_Pragma_Abort_Defer (N : Node_Id); + procedure Expand_Pragma_Check (N : Node_Id); + procedure Expand_Pragma_Common_Object (N : Node_Id); + procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); + procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); + procedure Expand_Pragma_Inspection_Point (N : Node_Id); + procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); + procedure Expand_Pragma_Loop_Variant (N : Node_Id); + procedure Expand_Pragma_Psect_Object (N : Node_Id); + procedure Expand_Pragma_Relative_Deadline (N : Node_Id); + + ---------- + -- Arg1 -- + ---------- + + function Arg1 (N : Node_Id) return Node_Id is + Arg : constant Node_Id := First (Pragma_Argument_Associations (N)); + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end Arg1; + + ---------- + -- Arg2 -- + ---------- + + function Arg2 (N : Node_Id) return Node_Id is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + + begin + if No (Arg1) then + return Empty; + + else + declare + Arg : constant Node_Id := Next (Arg1); + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end; + end if; + end Arg2; + + ---------- + -- Arg3 -- + ---------- + + function Arg3 (N : Node_Id) return Node_Id is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + + begin + if No (Arg1) then + return Empty; + + else + declare + Arg : Node_Id := Next (Arg1); + begin + if No (Arg) then + return Empty; + + else + Next (Arg); + + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end if; + end; + end if; + end Arg3; + + --------------------------- + -- Expand_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_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_Old_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. Any temporaries generated in + -- the process are added to declarative list Decls. Evals is a complex + -- if statement tasked with the evaluation of all prefixes coming from + -- a 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_Old_In_Consequence -- + ------------------------------- + + procedure Expand_Old_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_Old (N : Node_Id) return Traverse_Result; + -- Determine whether an arbitrary node denotes attribute 'Old and if + -- it does, perform all expansion-related actions. + + ---------------- + -- Expand_Old -- + ---------------- + + function Expand_Old (N : Node_Id) return Traverse_Result is + Decl : Node_Id; + Pref : Node_Id; + Temp : Entity_Id; + + begin + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Old + then + Pref := Prefix (N); + 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)); + Set_No_Initialization (Decl); + + Append_To (Decls, Decl); + + -- Evaluate the prefix, generate: + -- Temp := <Pref>; + + 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)); + + -- 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. + + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + end if; + + return OK; + end Expand_Old; + + procedure Expand_Olds is new Traverse_Proc (Expand_Old); + + -- Start of processing for Expand_Old_In_Consequence + + begin + -- Inspect the consequence and expand any attribute 'Old references + -- found within. + + Expand_Olds (Conseq); + + -- 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_Old_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; + Error_Decls : List_Id; + Flag : Entity_Id; + Msg_Str : Entity_Id; + Multiple_PCs : Boolean; + Old_Evals : Node_Id := Empty; + Others_Flag : Entity_Id := Empty; + Post_Case : Node_Id; + + -- Start of processing for Expand_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; + + 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'); + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Count, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + -- 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'); + Prepend_To (Decls, Declaration_Of (Others_Flag)); + + -- 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 references found within. + + Expand_Old_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'); + Prepend_To (Decls, Declaration_Of (Flag)); + + -- The flag is set when the case guard is evaluated to True + -- if Case_Guard then + -- Flag := True; + -- Count := Count + 1; + -- end if; + + Append_To (Decls, + Make_Implicit_If_Statement (CCs, + Condition => Relocate_Node (Case_Guard), + Then_Statements => New_List ( + Set (Flag), + Increment (Count)))); + + -- 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 references found within. + + Expand_Old_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); + + -- Once all case guards are evaluated and checked, evaluate any prefixes + -- of attribute 'Old founds in the selected consequence. + + Append_To (Decls, Old_Evals); + + -- Raise Assertion_Error when the corresponding consequence of a case + -- guard that evaluated to True fails. + + if No (Stmts) then + Stmts := New_List; + end if; + + Append_To (Stmts, Conseq_Checks); + end Expand_Contract_Cases; + + --------------------- + -- Expand_N_Pragma -- + --------------------- + + procedure Expand_N_Pragma (N : Node_Id) is + Pname : constant Name_Id := Pragma_Name (N); + + begin + -- Note: we may have a pragma whose Pragma_Identifier field is not a + -- recognized pragma, and we must ignore it at this stage. + + if Is_Pragma_Name (Pname) then + case Get_Pragma_Id (Pname) is + + -- Pragmas requiring special expander action + + when Pragma_Abort_Defer => + Expand_Pragma_Abort_Defer (N); + + when Pragma_Check => + Expand_Pragma_Check (N); + + when Pragma_Common_Object => + Expand_Pragma_Common_Object (N); + + when Pragma_Export_Exception => + Expand_Pragma_Import_Export_Exception (N); + + when Pragma_Import => + Expand_Pragma_Import_Or_Interface (N); + + when Pragma_Import_Exception => + Expand_Pragma_Import_Export_Exception (N); + + when Pragma_Inspection_Point => + Expand_Pragma_Inspection_Point (N); + + when Pragma_Interface => + Expand_Pragma_Import_Or_Interface (N); + + when Pragma_Interrupt_Priority => + Expand_Pragma_Interrupt_Priority (N); + + when Pragma_Loop_Variant => + Expand_Pragma_Loop_Variant (N); + + when Pragma_Psect_Object => + Expand_Pragma_Psect_Object (N); + + when Pragma_Relative_Deadline => + Expand_Pragma_Relative_Deadline (N); + + -- All other pragmas need no expander action + + when others => null; + end case; + end if; + + end Expand_N_Pragma; + + ------------------------------- + -- Expand_Pragma_Abort_Defer -- + ------------------------------- + + -- An Abort_Defer pragma appears as the first statement in a handled + -- statement sequence (right after the begin). It defers aborts for + -- the entire statement sequence, but not for any declarations or + -- handlers (if any) associated with this statement sequence. + + -- The transformation is to transform + + -- pragma Abort_Defer; + -- statements; + + -- into + + -- begin + -- Abort_Defer.all; + -- statements + -- exception + -- when all others => + -- Abort_Undefer.all; + -- raise; + -- at end + -- Abort_Undefer_Direct; + -- end; + + procedure Expand_Pragma_Abort_Defer (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stm : Node_Id; + Stms : List_Id; + HSS : Node_Id; + Blk : constant Entity_Id := + New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); + + begin + Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); + + loop + Stm := Remove_Next (N); + exit when No (Stm); + Append (Stm, Stms); + end loop; + + HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms, + At_End_Proc => + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => HSS)); + + Set_Scope (Blk, Current_Scope); + Set_Etype (Blk, Standard_Void_Type); + Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); + Expand_At_End_Handler (HSS, Blk); + Analyze (N); + end Expand_Pragma_Abort_Defer; + + -------------------------- + -- Expand_Pragma_Check -- + -------------------------- + + procedure Expand_Pragma_Check (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + -- Location of the pragma node. Note: it is important to use this + -- location (and not the location of the expression) for the generated + -- statements, otherwise the implicit return statement in the body + -- of a pre/postcondition subprogram may inherit the source location + -- of part of the expression, which causes confusing debug information + -- to be generated, which interferes with coverage analysis tools. + + Cond : constant Node_Id := Arg2 (N); + Nam : constant Name_Id := Chars (Arg1 (N)); + Msg : Node_Id; + + begin + -- Nothing to do if pragma is ignored + + if Is_Ignored (N) then + return; + end if; + + -- Since this check is active, we rewrite the pragma into a + -- corresponding if statement, and then analyze the statement + + -- The normal case expansion transforms: + + -- pragma Check (name, condition [,message]); + + -- into + + -- if not condition then + -- System.Assertions.Raise_Assert_Failure (Str); + -- end if; + + -- where Str is the message if one is present, or the default of + -- name failed at file:line if no message is given (the "name failed + -- at" is omitted for name = Assertion, since it is redundant, given + -- that the name of the exception is Assert_Failure.) + + -- 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. + + -- Case where we generate a direct raise + + if ((Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation)) + and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) + or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) + then + Rewrite (N, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => Cond), + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Assert_Failure), Loc))))); + + -- Case where we call the procedure + + else + -- If we have a message given, use it + + if Present (Arg3 (N)) then + Msg := Get_Pragma_Arg (Arg3 (N)); + + -- Here we have no string, so prepare one + + else + declare + Msg_Loc : constant String := + Build_Location_String (Sloc (First_Node (Cond))); + -- Source location used in the case of a failed assertion: + -- point to the failing condition, not Loc. Note that the + -- source location of the expression is not usually the best + -- choice here. For example, it gets located on the last AND + -- keyword in a chain of boolean expressiond AND'ed together. + -- It is best to put the message on the first character of the + -- condition, which is the effect of the First_Node call here. + + begin + Name_Len := 0; + + -- For Assert, we just use the location + + if Nam = Name_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 (Nam, 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 current source file casing. + + else + Get_Name_String (Nam); + Set_Casing (Identifier_Casing (Current_Source_File)); + Add_Str_To_Name_Buffer (" failed at "); + end if; + + -- In all cases, add location string + + Add_Str_To_Name_Buffer (Msg_Loc); + + -- Build the message + + Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); + end; + end if; + + -- Now rewrite as an if statement + + Rewrite (N, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => Cond), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_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 + return; + + 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 := Arg1 (N); + External : constant Node_Id := Arg2 (N); + + Psect : Node_Id; + -- Psect value upper cased as string literal + + Iloc : constant Source_Ptr := Sloc (Internal); + Eloc : constant Source_Ptr := Sloc (External); + Ploc : Source_Ptr; + + begin + -- Acquire Psect value and fold to upper case + + if Present (External) then + if Nkind (External) = N_String_Literal then + String_To_Name_Buffer (Strval (External)); + else + Get_Name_String (Chars (External)); + end if; + + Set_All_Upper_Case; + + Psect := + Make_String_Literal (Eloc, + Strval => String_From_Name_Buffer); + + else + Get_Name_String (Chars (Internal)); + Set_All_Upper_Case; + Psect := + Make_String_Literal (Iloc, + Strval => String_From_Name_Buffer); + end if; + + Ploc := Sloc (Psect); + + -- Insert the pragma + + Insert_After_And_Analyze (N, + Make_Pragma (Loc, + Chars => Name_Machine_Attribute, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Iloc, + Expression => New_Copy_Tree (Internal)), + Make_Pragma_Argument_Association (Eloc, + Expression => + Make_String_Literal (Sloc => Ploc, + Strval => "common_object")), + Make_Pragma_Argument_Association (Ploc, + Expression => New_Copy_Tree (Psect))))); + + end Expand_Pragma_Common_Object; + + --------------------------------------- + -- Expand_Pragma_Import_Or_Interface -- + --------------------------------------- + + procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is + Def_Id : Entity_Id; + Init_Call : Node_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 Chars (Pragma_Identifier (N)) = Name_Import + and then Nkind (Arg2 (N)) = N_String_Literal + then + Def_Id := Entity (Arg1 (N)); + else + Def_Id := Entity (Arg2 (N)); + end if; + + -- Variable case + + if Ekind (Def_Id) = E_Variable then + + -- When applied to a variable, the default initialization must not be + -- done. As it is already done when the pragma is found, we just get + -- rid of the call the initialization procedure which followed the + -- object declaration. The call is inserted after the declaration, + -- but validity checks may also have been inserted and 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; + + -- 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 := Arg3 (N); + 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), + Unchecked_Convert_To (Standard_A_Char, + 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_Import_Export_Exception -- + ------------------------------------------- + + -- For a VMS exception fix up the language field with "VMS" + -- instead of "Ada" (gigi needs this), create a constant that will be the + -- value of the VMS condition code and stuff the Interface_Name field + -- with the unexpanded name of the exception (if not already set). + -- For a Ada exception, just stuff the Interface_Name field + -- with the unexpanded name of the exception (if not already set). + + procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is + begin + -- This pragma is only effective on OpenVMS systems, it was ignored + -- on non-VMS systems, and we need to ignore it here as well. + + if not OpenVMS_On_Target then + return; + end if; + + declare + Id : constant Entity_Id := Entity (Arg1 (N)); + Call : constant Node_Id := Register_Exception_Call (Id); + Loc : constant Source_Ptr := Sloc (N); + + begin + if Present (Call) then + declare + Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V'); + Export_Pragma : Node_Id; + Excep_Alias : Node_Id; + Excep_Object : Node_Id; + Excep_Image : String_Id; + Exdata : List_Id; + Lang_Char : Node_Id; + Code : Node_Id; + + begin + -- Compute the symbol for the code of the condition + + if Present (Interface_Name (Id)) then + Excep_Image := Strval (Interface_Name (Id)); + else + Get_Name_String (Chars (Id)); + Set_All_Upper_Case; + Excep_Image := String_From_Name_Buffer; + end if; + + Exdata := Component_Associations (Expression (Parent (Id))); + + if Is_VMS_Exception (Id) then + Lang_Char := Next (First (Exdata)); + + -- Change the one-character language designator to 'V' + + Rewrite (Expression (Lang_Char), + Make_Character_Literal (Loc, + Chars => Name_uV, + Char_Literal_Value => + UI_From_Int (Character'Pos ('V')))); + Analyze (Expression (Lang_Char)); + + if Exception_Code (Id) /= No_Uint then + + -- The code for the exception is present. Create a linker + -- alias to define the symbol. + + Code := + Unchecked_Convert_To (RTE (RE_Address), + Make_Integer_Literal (Loc, + Intval => Exception_Code (Id))); + + -- Declare a dummy object + + Excep_Object := + Make_Object_Declaration (Loc, + Defining_Identifier => Excep_Internal, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc)); + + Insert_Action (N, Excep_Object); + Analyze (Excep_Object); + + -- Clear severity bits + + Start_String; + Store_String_Int + (UI_To_Int (Exception_Code (Id)) / 8 * 8); + + -- Insert a pragma Linker_Alias to set the value of the + -- dummy object symbol. + + Excep_Alias := + Make_Pragma (Loc, + Chars => Name_Linker_Alias, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + New_Occurrence_Of (Excep_Internal, Loc)), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_String_Literal (Loc, End_String)))); + + Insert_Action (N, Excep_Alias); + Analyze (Excep_Alias); + + -- Insert a pragma Export to give a Linker_Name to the + -- dummy object. + + Export_Pragma := + Make_Pragma (Loc, + Chars => Name_Export, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_C)), + + Make_Pragma_Argument_Association (Loc, + Expression => + New_Occurrence_Of (Excep_Internal, Loc)), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_String_Literal (Loc, Excep_Image)), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_String_Literal (Loc, Excep_Image)))); + + Insert_Action (N, Export_Pragma); + Analyze (Export_Pragma); + + else + Code := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Import_Address), Loc), + Parameter_Associations => New_List + (Make_String_Literal (Loc, + Strval => Excep_Image))); + end if; + + -- Generate the call to Register_VMS_Exception + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of + (RTE (RE_Register_VMS_Exception), Loc), + Parameter_Associations => New_List ( + Code, + Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Id, Loc), + Attribute_Name => Name_Unrestricted_Access))))); + + Analyze_And_Resolve (Code, RTE (RE_Address)); + Analyze (Call); + end if; + + if No (Interface_Name (Id)) then + Set_Interface_Name (Id, + Make_String_Literal + (Sloc => Loc, + Strval => Excep_Image)); + end if; + end; + end if; + end; + end Expand_Pragma_Import_Export_Exception; + + ------------------------------------ + -- Expand_Pragma_Inspection_Point -- + ------------------------------------ + + -- If no argument is given, then we supply a default argument list that + -- includes all objects declared at the source level in all subprograms + -- that enclose the inspection point pragma. + + procedure Expand_Pragma_Inspection_Point (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + A : List_Id; + Assoc : Node_Id; + S : Entity_Id; + E : Entity_Id; + + begin + if No (Pragma_Argument_Associations (N)) then + A := New_List; + S := Current_Scope; + + while S /= Standard_Standard loop + E := First_Entity (S); + while Present (E) loop + if Comes_From_Source (E) + and then Is_Object (E) + and then not Is_Entry_Formal (E) + and then Ekind (E) /= E_Component + and then Ekind (E) /= E_Discriminant + and then Ekind (E) /= E_Generic_In_Parameter + and then Ekind (E) /= E_Generic_In_Out_Parameter + then + Append_To (A, + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc))); + end if; + + Next_Entity (E); + end loop; + + S := Scope (S); + end loop; + + Set_Pragma_Argument_Associations (N, A); + end if; + + -- Expand the arguments of the pragma. Expanding an entity reference + -- is a noop, except in a protected operation, where a reference may + -- have to be transformed into a reference to the corresponding prival. + -- Are there other pragmas that may require this ??? + + Assoc := First (Pragma_Argument_Associations (N)); + + while Present (Assoc) loop + Expand (Expression (Assoc)); + Next (Assoc); + end loop; + end Expand_Pragma_Inspection_Point; + + -------------------------------------- + -- Expand_Pragma_Interrupt_Priority -- + -------------------------------------- + + -- Supply default argument if none exists (System.Interrupt_Priority'Last) + + procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + if No (Pragma_Argument_Associations (N)) then + Set_Pragma_Argument_Associations (N, New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc), + Attribute_Name => Name_Last)))); + end if; + end Expand_Pragma_Interrupt_Priority; + + -------------------------------- + -- Expand_Pragma_Loop_Variant -- + -------------------------------- + + -- Pragma Loop_Variant is expanded in the following manner: + + -- Original code + + -- for | while ... loop + -- <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 + function Make_Op + (Loc : Source_Ptr; + Curr_Val : Node_Id; + Old_Val : Node_Id) return Node_Id; + -- Generate a comparison between Curr_Val and Old_Val depending on + -- the change mode (Increases / Decreases) of the variant. + + ------------- + -- Make_Op -- + ------------- + + function Make_Op + (Loc : Source_Ptr; + Curr_Val : Node_Id; + Old_Val : Node_Id) return Node_Id + is + begin + if Chars (Variant) = Name_Increases then + return Make_Op_Gt (Loc, Curr_Val, Old_Val); + else pragma Assert (Chars (Variant) = Name_Decreases); + return Make_Op_Lt (Loc, Curr_Val, Old_Val); + end if; + end Make_Op; + + -- Local variables + + Expr : constant Node_Id := Expression (Variant); + Expr_Typ : constant Entity_Id := Etype (Expr); + Loc : constant Source_Ptr := Sloc (Expr); + Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt); + Curr_Id : Entity_Id; + Old_Id : Entity_Id; + Prag : Node_Id; + + -- Start of processing for Process_Variant + + begin + -- All temporaries generated in this routine must be inserted before + -- the related loop statement. Ensure that the proper scope is on the + -- stack when analyzing the temporaries. Note that we also use the + -- Sloc of the related loop. + + Push_Scope (Scope (Loop_Scop)); + + -- Step 1: Create the declaration of the flag which controls the + -- behavior of the assertion on the first iteration of the loop. + + if No (Flag_Id) then + + -- Generate: + -- Flag : Boolean := False; + + Flag_Id := Make_Temporary (Loop_Loc, 'F'); + + Insert_Action (Loop_Stmt, + Make_Object_Declaration (Loop_Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_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 + + if No (Old_Assign) then + Old_Assign := New_List; + end if; + + -- Generate: + -- Old := Curr; + + Append_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 + + if No (Curr_Assign) then + Curr_Assign := New_List; + end if; + + -- Generate: + -- Curr := <Expr>; + + Append_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_Op (Loc, + 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. + + if Is_Ignored (N) then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + return; + end if; + + -- 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. + + 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, Arg1 (N))))))); + + Analyze (N); + end if; + end Expand_Pragma_Relative_Deadline; + +end Exp_Prag; |