X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fexp_prag.adb;fp=gcc%2Fada%2Fexp_prag.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=8189022398bc9399af924cf0d302678884b85371;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb deleted file mode 100644 index 81890223..00000000 --- a/gcc/ada/exp_prag.adb +++ /dev/null @@ -1,539 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P _ P R A G -- --- -- --- B o d y -- --- -- --- $Revision: 1.1.16.1 $ --- -- --- 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -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;