diff options
Diffstat (limited to 'gcc/ada/exp_prag.adb')
| -rw-r--r-- | gcc/ada/exp_prag.adb | 539 |
1 files changed, 539 insertions, 0 deletions
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb new file mode 100644 index 00000000000..855c3725dd1 --- /dev/null +++ b/gcc/ada/exp_prag.adb @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P R A G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.53 $ +-- -- +-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch11; use Exp_Ch11; +with Exp_Tss; use Exp_Tss; +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 Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +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 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_Association + + procedure Expand_Pragma_Abort_Defer (N : Node_Id); + procedure Expand_Pragma_Assert (N : Node_Id); + procedure Expand_Pragma_Import (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); + + -------------- + -- Arg1,2,3 -- + -------------- + + function Arg1 (N : Node_Id) return Node_Id is + begin + return First (Pragma_Argument_Associations (N)); + end Arg1; + + function Arg2 (N : Node_Id) return Node_Id is + begin + return Next (Arg1 (N)); + end Arg2; + + function Arg3 (N : Node_Id) return Node_Id is + begin + return Next (Arg2 (N)); + end Arg3; + + --------------------- + -- Expand_N_Pragma -- + --------------------- + + procedure Expand_N_Pragma (N : Node_Id) is + begin + -- Note: we may have a pragma whose chars field is not a + -- recognized pragma, and we must ignore it at this stage. + + if Is_Pragma_Name (Chars (N)) then + case Get_Pragma_Id (Chars (N)) is + + -- Pragmas requiring special expander action + + when Pragma_Abort_Defer => + Expand_Pragma_Abort_Defer (N); + + when Pragma_Assert => + Expand_Pragma_Assert (N); + + when Pragma_Export_Exception => + Expand_Pragma_Import_Export_Exception (N); + + when Pragma_Import => + Expand_Pragma_Import (N); + + when Pragma_Import_Exception => + Expand_Pragma_Import_Export_Exception (N); + + when Pragma_Inspection_Point => + Expand_Pragma_Inspection_Point (N); + + when Pragma_Interrupt_Priority => + Expand_Pragma_Interrupt_Priority (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_Assert -- + -------------------------- + + procedure Expand_Pragma_Assert (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Cond : constant Node_Id := Expression (Arg1 (N)); + Msg : String_Id; + + begin + -- We already know that assertions are enabled, because otherwise + -- the semantic pass dealt with rewriting the assertion (see Sem_Prag) + + pragma Assert (Assertions_Enabled); + + -- Since assertions are on, we rewrite the pragma with its + -- corresponding if statement, and then analyze the statement + -- The expansion transforms: + + -- pragma Assert (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 + -- file:line if no message is given. + + -- First, we need to prepare the character literal + + if Present (Arg2 (N)) then + Msg := Strval (Expr_Value_S (Expression (Arg2 (N)))); + else + Build_Location_String (Loc); + Msg := String_From_Name_Buffer; + end if; + + -- Now generate the 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. + + 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 ( + Make_String_Literal (Loc, Msg)))))); + + Analyze (N); + + -- If new condition is always false, give a warning + + if 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 intented 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; + else + Error_Msg_N ("?assertion will fail at run-time", N); + end if; + end if; + end Expand_Pragma_Assert; + + -------------------------- + -- Expand_Pragma_Import -- + -------------------------- + + -- 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. + + -- 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 (N : Node_Id) is + Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N))); + Typ : Entity_Id; + After_Def : Node_Id; + + begin + if Ekind (Def_Id) = E_Variable then + Typ := Etype (Def_Id); + After_Def := Next (Parent (Def_Id)); + + if Has_Non_Null_Base_Init_Proc (Typ) + and then Nkind (After_Def) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (After_Def)) + and then Entity (Name (After_Def)) = Base_Init_Proc (Typ) + then + Remove (After_Def); + + elsif Is_Access_Type (Typ) then + Set_Expression (Parent (Def_Id), Empty); + end if; + end if; + end Expand_Pragma_Import; + + ------------------------------------------- + -- 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 + Id : constant Entity_Id := Entity (Expression (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_Defining_Identifier + (Loc, New_Internal_Name ('V')); + Export_Pragma : Node_Id; + Excep_Alias : Node_Id; + Excep_Object : Node_Id; + Excep_Image : String_Id; + Exdata : List_Id; + Lang1 : Node_Id; + Lang2 : Node_Id; + Lang3 : 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 + + Lang1 := Next (First (Exdata)); + Lang2 := Next (Lang1); + Lang3 := Next (Lang2); + + Rewrite (Expression (Lang1), + Make_Character_Literal (Loc, Name_uV, Get_Char_Code ('V'))); + Analyze (Expression (Lang1)); + + Rewrite (Expression (Lang2), + Make_Character_Literal (Loc, Name_uM, Get_Char_Code ('M'))); + Analyze (Expression (Lang2)); + + Rewrite (Expression (Lang3), + Make_Character_Literal (Loc, Name_uS, Get_Char_Code ('S'))); + Analyze (Expression (Lang3)); + + if Exception_Code (Id) /= No_Uint then + Code := Make_Integer_Literal (Loc, Exception_Code (Id)); + + Excep_Object := + Make_Object_Declaration (Loc, + Defining_Identifier => Excep_Internal, + Object_Definition => + New_Reference_To (Standard_Integer, 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, + Name_Linker_Alias, + New_List + (Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + New_Reference_To (Excep_Internal, Loc)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + Make_String_Literal + (Sloc => Loc, + Strval => End_String)))); + + Insert_Action (N, Excep_Alias); + Analyze (Excep_Alias); + + Export_Pragma := + Make_Pragma + (Loc, + Name_Export, + New_List + (Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => Make_Identifier (Loc, Name_C)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + New_Reference_To (Excep_Internal, Loc)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + Make_String_Literal + (Sloc => Loc, + Strval => Excep_Image)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + Make_String_Literal + (Sloc => Loc, + Strval => Excep_Image)))); + + Insert_Action (N, Export_Pragma); + Analyze (Export_Pragma); + + else + Code := + Unchecked_Convert_To (Standard_Integer, + 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))); + + Analyze_And_Resolve (Code, Standard_Integer); + Analyze (Call); + + end if; + + if not Present (Interface_Name (Id)) then + Set_Interface_Name (Id, + Make_String_Literal + (Sloc => Loc, + Strval => Excep_Image)); + end if; + end; + end if; + 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; + +end Exp_Prag; |