------------------------------------------------------------------------------ -- -- -- 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;