From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/exp_code.adb | 498 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 498 insertions(+) create mode 100644 gcc/ada/exp_code.adb (limited to 'gcc/ada/exp_code.adb') diff --git a/gcc/ada/exp_code.adb b/gcc/ada/exp_code.adb new file mode 100644 index 000000000..2b0275268 --- /dev/null +++ b/gcc/ada/exp_code.adb @@ -0,0 +1,498 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C O D E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2008, 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 Einfo; use Einfo; +with Errout; use Errout; +with Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Stringt; use Stringt; +with Tbuild; use Tbuild; + +package body Exp_Code is + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + function Asm_Constraint (Operand_Var : Node_Id) return Node_Id; + -- Common processing for Asm_Input_Constraint and Asm_Output_Constraint. + -- Obtains the constraint argument from the global operand variable + -- Operand_Var, which must be non-Empty. + + function Asm_Operand (Operand_Var : Node_Id) return Node_Id; + -- Common processing for Asm_Input_Value and Asm_Output_Variable. Obtains + -- the value/variable argument from Operand_Var, the global operand + -- variable. Returns Empty if no operand available. + + function Get_String_Node (S : Node_Id) return Node_Id; + -- Given S, a static expression node of type String, returns the + -- string literal node. This is needed to deal with the use of constants + -- for these expressions, which is perfectly permissible. + + procedure Next_Asm_Operand (Operand_Var : in out Node_Id); + -- Common processing for Next_Asm_Input and Next_Asm_Output, updates + -- the value of the global operand variable Operand_Var appropriately. + + procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id); + -- Common processing for Setup_Asm_Inputs and Setup_Asm_Outputs. Arg + -- is the actual parameter from the call, and Operand_Var is the global + -- operand variable to be initialized to the first operand. + + ---------------------- + -- Global Variables -- + ---------------------- + + Current_Input_Operand : Node_Id := Empty; + -- Points to current Asm_Input_Operand attribute reference. Initialized + -- by Setup_Asm_Inputs, updated by Next_Asm_Input, and referenced by + -- Asm_Input_Constraint and Asm_Input_Value. + + Current_Output_Operand : Node_Id := Empty; + -- Points to current Asm_Output_Operand attribute reference. Initialized + -- by Setup_Asm_Outputs, updated by Next_Asm_Output, and referenced by + -- Asm_Output_Constraint and Asm_Output_Variable. + + -------------------- + -- Asm_Constraint -- + -------------------- + + function Asm_Constraint (Operand_Var : Node_Id) return Node_Id is + begin + pragma Assert (Present (Operand_Var)); + return Get_String_Node (First (Expressions (Operand_Var))); + end Asm_Constraint; + + -------------------------- + -- Asm_Input_Constraint -- + -------------------------- + + -- Note: error checking on Asm_Input attribute done in Sem_Attr + + function Asm_Input_Constraint return Node_Id is + begin + return Get_String_Node (Asm_Constraint (Current_Input_Operand)); + end Asm_Input_Constraint; + + --------------------- + -- Asm_Input_Value -- + --------------------- + + -- Note: error checking on Asm_Input attribute done in Sem_Attr + + function Asm_Input_Value return Node_Id is + begin + return Asm_Operand (Current_Input_Operand); + end Asm_Input_Value; + + ----------------- + -- Asm_Operand -- + ----------------- + + function Asm_Operand (Operand_Var : Node_Id) return Node_Id is + begin + if No (Operand_Var) then + return Empty; + elsif Error_Posted (Operand_Var) then + return Error; + else + return Next (First (Expressions (Operand_Var))); + end if; + end Asm_Operand; + + --------------------------- + -- Asm_Output_Constraint -- + --------------------------- + + -- Note: error checking on Asm_Output attribute done in Sem_Attr + + function Asm_Output_Constraint return Node_Id is + begin + return Asm_Constraint (Current_Output_Operand); + end Asm_Output_Constraint; + + ------------------------- + -- Asm_Output_Variable -- + ------------------------- + + -- Note: error checking on Asm_Output attribute done in Sem_Attr + + function Asm_Output_Variable return Node_Id is + begin + return Asm_Operand (Current_Output_Operand); + end Asm_Output_Variable; + + ------------------ + -- Asm_Template -- + ------------------ + + function Asm_Template (N : Node_Id) return Node_Id is + Call : constant Node_Id := Expression (Expression (N)); + Temp : constant Node_Id := First_Actual (Call); + + begin + -- Require static expression for template. We also allow a string + -- literal (this is useful for Ada 83 mode where string expressions + -- are never static). + + if Is_OK_Static_Expression (Temp) + or else (Ada_Version = Ada_83 + and then Nkind (Temp) = N_String_Literal) + then + return Get_String_Node (Temp); + + else + Flag_Non_Static_Expr ("asm template argument is not static!", Temp); + return Empty; + end if; + end Asm_Template; + + ---------------------- + -- Clobber_Get_Next -- + ---------------------- + + Clobber_Node : Node_Id; + -- String literal node for clobber string. Initialized by Clobber_Setup, + -- and not modified by Clobber_Get_Next. Empty if clobber string was in + -- error (resulting in no clobber arguments being returned). + + Clobber_Ptr : Nat; + -- Pointer to current character of string. Initialized to 1 by the call + -- to Clobber_Setup, and then updated by Clobber_Get_Next. + + function Clobber_Get_Next return Address is + Str : constant String_Id := Strval (Clobber_Node); + Len : constant Nat := String_Length (Str); + C : Character; + + begin + if No (Clobber_Node) then + return Null_Address; + end if; + + -- Skip spaces and commas before next register name + + loop + -- Return null string if no more names + + if Clobber_Ptr > Len then + return Null_Address; + end if; + + C := Get_Character (Get_String_Char (Str, Clobber_Ptr)); + exit when C /= ',' and then C /= ' '; + Clobber_Ptr := Clobber_Ptr + 1; + end loop; + + -- Acquire next register name + + Name_Len := 0; + loop + Add_Char_To_Name_Buffer (C); + Clobber_Ptr := Clobber_Ptr + 1; + exit when Clobber_Ptr > Len; + C := Get_Character (Get_String_Char (Str, Clobber_Ptr)); + exit when C = ',' or else C = ' '; + end loop; + + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return Name_Buffer'Address; + end Clobber_Get_Next; + + ------------------- + -- Clobber_Setup -- + ------------------- + + procedure Clobber_Setup (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + Clob : constant Node_Id := Next_Actual ( + Next_Actual ( + Next_Actual ( + First_Actual (Call)))); + begin + if not Is_OK_Static_Expression (Clob) then + Flag_Non_Static_Expr ("asm clobber argument is not static!", Clob); + Clobber_Node := Empty; + else + Clobber_Node := Get_String_Node (Clob); + Clobber_Ptr := 1; + end if; + end Clobber_Setup; + + --------------------- + -- Expand_Asm_Call -- + --------------------- + + procedure Expand_Asm_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + procedure Check_IO_Operand (N : Node_Id); + -- Check for incorrect input or output operand + + ---------------------- + -- Check_IO_Operand -- + ---------------------- + + procedure Check_IO_Operand (N : Node_Id) is + Err : Node_Id := N; + + begin + -- The only identifier allowed is No_xxput_Operands. Since we + -- know the type is right, it is sufficient to see if the + -- referenced entity is in a runtime routine. + + if Is_Entity_Name (N) + and then + Is_Predefined_File_Name (Unit_File_Name + (Get_Source_Unit (Entity (N)))) + then + return; + + -- An attribute reference is fine, again the analysis reasonably + -- guarantees that the attribute must be subtype'Asm_??put. + + elsif Nkind (N) = N_Attribute_Reference then + return; + + -- The only other allowed form is an array aggregate in which + -- all the entries are positional and are attribute references. + + elsif Nkind (N) = N_Aggregate then + if Present (Component_Associations (N)) then + Err := First (Component_Associations (N)); + + elsif Present (Expressions (N)) then + Err := First (Expressions (N)); + while Present (Err) loop + exit when Nkind (Err) /= N_Attribute_Reference; + Next (Err); + end loop; + + if No (Err) then + return; + end if; + end if; + end if; + + -- If we fall through, Err is pointing to the bad node + + Error_Msg_N ("Asm operand has wrong form", Err); + end Check_IO_Operand; + + -- Start of processing for Expand_Asm_Call + + begin + -- Check that the input and output operands have the right + -- form, as required by the documentation of the Asm feature: + + -- OUTPUT_OPERAND_LIST ::= + -- No_Output_Operands + -- | OUTPUT_OPERAND_ATTRIBUTE + -- | (OUTPUT_OPERAND_ATTRIBUTE @{,OUTPUT_OPERAND_ATTRIBUTE@}) + + -- OUTPUT_OPERAND_ATTRIBUTE ::= + -- SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME) + + -- INPUT_OPERAND_LIST ::= + -- No_Input_Operands + -- | INPUT_OPERAND_ATTRIBUTE + -- | (INPUT_OPERAND_ATTRIBUTE @{,INPUT_OPERAND_ATTRIBUTE@}) + + -- INPUT_OPERAND_ATTRIBUTE ::= + -- SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION) + + declare + Arg_Output : constant Node_Id := Next_Actual (First_Actual (N)); + Arg_Input : constant Node_Id := Next_Actual (Arg_Output); + begin + Check_IO_Operand (Arg_Output); + Check_IO_Operand (Arg_Input); + end; + + -- If we have the function call case, we are inside a code statement, + -- and the tree is already in the necessary form for gigi. + + if Nkind (N) = N_Function_Call then + null; + + -- For the procedure case, we convert the call into a code statement + + else + pragma Assert (Nkind (N) = N_Procedure_Call_Statement); + + -- Note: strictly we should change the procedure call to a function + -- call in the qualified expression, but since we are not going to + -- reanalyze (see below), and the interface subprograms in this + -- package don't care, we can leave it as a procedure call. + + Rewrite (N, + Make_Code_Statement (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (RTE (RE_Asm_Insn), Loc), + Expression => Relocate_Node (N)))); + + -- There is no need to reanalyze this node, it is completely analyzed + -- already, at least sufficiently for the purposes of the abstract + -- procedural interface defined in this package. Furthermore if we + -- let it go through the normal analysis, that would include some + -- inappropriate checks that apply only to explicit code statements + -- in the source, and not to calls to intrinsics. + + Set_Analyzed (N); + Check_Code_Statement (N); + end if; + end Expand_Asm_Call; + + --------------------- + -- Get_String_Node -- + --------------------- + + function Get_String_Node (S : Node_Id) return Node_Id is + begin + if Nkind (S) = N_String_Literal then + return S; + else + pragma Assert (Ekind (Entity (S)) = E_Constant); + return Get_String_Node (Constant_Value (Entity (S))); + end if; + end Get_String_Node; + + --------------------- + -- Is_Asm_Volatile -- + --------------------- + + function Is_Asm_Volatile (N : Node_Id) return Boolean is + Call : constant Node_Id := Expression (Expression (N)); + Vol : constant Node_Id := + Next_Actual ( + Next_Actual ( + Next_Actual ( + Next_Actual ( + First_Actual (Call))))); + begin + if not Is_OK_Static_Expression (Vol) then + Flag_Non_Static_Expr ("asm volatile argument is not static!", Vol); + return False; + else + return Is_True (Expr_Value (Vol)); + end if; + end Is_Asm_Volatile; + + -------------------- + -- Next_Asm_Input -- + -------------------- + + procedure Next_Asm_Input is + begin + Next_Asm_Operand (Current_Input_Operand); + end Next_Asm_Input; + + ---------------------- + -- Next_Asm_Operand -- + ---------------------- + + procedure Next_Asm_Operand (Operand_Var : in out Node_Id) is + begin + pragma Assert (Present (Operand_Var)); + + if Nkind (Parent (Operand_Var)) = N_Aggregate then + Operand_Var := Next (Operand_Var); + else + Operand_Var := Empty; + end if; + end Next_Asm_Operand; + + --------------------- + -- Next_Asm_Output -- + --------------------- + + procedure Next_Asm_Output is + begin + Next_Asm_Operand (Current_Output_Operand); + end Next_Asm_Output; + + ---------------------- + -- Setup_Asm_Inputs -- + ---------------------- + + procedure Setup_Asm_Inputs (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + begin + Setup_Asm_IO_Args + (Next_Actual (Next_Actual (First_Actual (Call))), + Current_Input_Operand); + end Setup_Asm_Inputs; + + ----------------------- + -- Setup_Asm_IO_Args -- + ----------------------- + + procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id) is + begin + -- Case of single argument + + if Nkind (Arg) = N_Attribute_Reference then + Operand_Var := Arg; + + -- Case of list of arguments + + elsif Nkind (Arg) = N_Aggregate then + if Expressions (Arg) = No_List then + Operand_Var := Empty; + else + Operand_Var := First (Expressions (Arg)); + end if; + + -- Otherwise must be default (no operands) case + + else + Operand_Var := Empty; + end if; + end Setup_Asm_IO_Args; + + ----------------------- + -- Setup_Asm_Outputs -- + ----------------------- + + procedure Setup_Asm_Outputs (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + begin + Setup_Asm_IO_Args + (Next_Actual (First_Actual (Call)), + Current_Output_Operand); + end Setup_Asm_Outputs; + +end Exp_Code; -- cgit v1.2.3