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