Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

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