8sa1-gcc/gcc/ada/exp_code.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ C O D E                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1996-2004 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 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_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
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;
      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
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := 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

      procedure Check_IO_Operand (N : Node_Id) is
         Err : Node_Id := N;

      begin
         --  The only identifier allows 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.

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