gcc/ada/exp_code.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ C O D E                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.17 $
  10 --                                                                          --
  11 --          Copyright (C) 1996-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Atree;    use Atree;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Fname;    use Fname;
  33 with Lib;      use Lib;
  34 with Namet;    use Namet;
  35 with Nlists;   use Nlists;
  36 with Nmake;    use Nmake;
  37 with Opt;      use Opt;
  38 with Rtsfind;  use Rtsfind;
  39 with Sem_Eval; use Sem_Eval;
  40 with Sem_Util; use Sem_Util;
  41 with Sinfo;    use Sinfo;
  42 with Stringt;  use Stringt;
  43 with Tbuild;   use Tbuild;
  44
  45 package body Exp_Code is
  46
  47    -----------------------
  48    -- Local_Subprograms --
  49    -----------------------
  50
  51    function Asm_Constraint (Operand_Var : Node_Id) return Node_Id;
  52    --  Common processing for Asm_Input_Constraint and Asm_Output_Constraint.
  53    --  Obtains the constraint argument from the global operand variable
  54    --  Operand_Var, which must be non-Empty.
  55
  56    function Asm_Operand (Operand_Var : Node_Id) return Node_Id;
  57    --  Common processing for Asm_Input_Value and Asm_Output_Variable. Obtains
  58    --  the value/variable argument from Operand_Var, the global operand
  59    --  variable. Returns Empty if no operand available.
  60
  61    function Get_String_Node (S : Node_Id) return Node_Id;
  62    --  Given S, a static expression node of type String, returns the
  63    --  string literal node. This is needed to deal with the use of constants
  64    --  for these expressions, which is perfectly permissible.
  65
  66    procedure Next_Asm_Operand (Operand_Var : in out Node_Id);
  67    --  Common processing for Next_Asm_Input and Next_Asm_Output, updates
  68    --  the value of the global operand variable Operand_Var appropriately.
  69
  70    procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id);
  71    --  Common processing for Setup_Asm_Inputs and Setup_Asm_Outputs. Arg
  72    --  is the actual parameter from the call, and Operand_Var is the global
  73    --  operand variable to be initialized to the first operand.
  74
  75    ----------------------
  76    -- Global Variables --
  77    ----------------------
  78
  79    Current_Input_Operand : Node_Id := Empty;
  80    --  Points to current Asm_Input_Operand attribute reference. Initialized
  81    --  by Setup_Asm_Inputs, updated by Next_Asm_Input, and referenced by
  82    --  Asm_Input_Constraint and Asm_Input_Value.
  83
  84    Current_Output_Operand : Node_Id := Empty;
  85    --  Points to current Asm_Output_Operand attribute reference. Initialized
  86    --  by Setup_Asm_Outputs, updated by Next_Asm_Output, and referenced by
  87    --  Asm_Output_Constraint and Asm_Output_Variable.
  88
  89    --------------------
  90    -- Asm_Constraint --
  91    --------------------
  92
  93    function Asm_Constraint (Operand_Var : Node_Id) return Node_Id is
  94    begin
  95       pragma Assert (Present (Operand_Var));
  96       return Get_String_Node (First (Expressions (Operand_Var)));
  97    end Asm_Constraint;
  98
  99    --------------------------
 100    -- Asm_Input_Constraint --
 101    --------------------------
 102
 103    --  Note: error checking on Asm_Input attribute done in Sem_Attr
 104
 105    function Asm_Input_Constraint return Node_Id is
 106    begin
 107       return Get_String_Node (Asm_Constraint (Current_Input_Operand));
 108    end Asm_Input_Constraint;
 109
 110    ---------------------
 111    -- Asm_Input_Value --
 112    ---------------------
 113
 114    --  Note: error checking on Asm_Input attribute done in Sem_Attr
 115
 116    function Asm_Input_Value return Node_Id is
 117    begin
 118       return Asm_Operand (Current_Input_Operand);
 119    end Asm_Input_Value;
 120
 121    -----------------
 122    -- Asm_Operand --
 123    -----------------
 124
 125    function Asm_Operand (Operand_Var : Node_Id) return Node_Id is
 126    begin
 127       if No (Operand_Var) then
 128          return Empty;
 129       else
 130          return Next (First (Expressions (Operand_Var)));
 131       end if;
 132    end Asm_Operand;
 133
 134    ---------------------------
 135    -- Asm_Output_Constraint --
 136    ---------------------------
 137
 138    --  Note: error checking on Asm_Output attribute done in Sem_Attr
 139
 140    function Asm_Output_Constraint return Node_Id is
 141    begin
 142       return Asm_Constraint (Current_Output_Operand);
 143    end Asm_Output_Constraint;
 144
 145    -------------------------
 146    -- Asm_Output_Variable --
 147    -------------------------
 148
 149    --  Note: error checking on Asm_Output attribute done in Sem_Attr
 150
 151    function Asm_Output_Variable return Node_Id is
 152    begin
 153       return Asm_Operand (Current_Output_Operand);
 154    end Asm_Output_Variable;
 155
 156    ------------------
 157    -- Asm_Template --
 158    ------------------
 159
 160    function Asm_Template (N : Node_Id) return Node_Id is
 161       Call : constant Node_Id := Expression (Expression (N));
 162       Temp : constant Node_Id := First_Actual (Call);
 163
 164    begin
 165       --  Require static expression for template. We also allow a string
 166       --  literal (this is useful for Ada 83 mode where string expressions
 167       --  are never static).
 168
 169       if Is_OK_Static_Expression (Temp)
 170         or else (Ada_83 and then Nkind (Temp) = N_String_Literal)
 171       then
 172          return Get_String_Node (Temp);
 173
 174       else
 175          Error_Msg_N ("asm template argument is not static", Temp);
 176          return Empty;
 177       end if;
 178    end Asm_Template;
 179
 180    ----------------------
 181    -- Clobber_Get_Next --
 182    ----------------------
 183
 184    Clobber_Node : Node_Id;
 185    --  String literal node for clobber string. Initialized by Clobber_Setup,
 186    --  and not modified by Clobber_Get_Next. Empty if clobber string was in
 187    --  error (resulting in no clobber arguments being returned).
 188
 189    Clobber_Ptr : Nat;
 190    --  Pointer to current character of string. Initialized to 1 by the call
 191    --  to Clobber_Setup, and then updated by Clobber_Get_Next.
 192
 193    function Clobber_Get_Next return Address is
 194       Str : constant String_Id := Strval (Clobber_Node);
 195       Len : constant Nat       := String_Length (Str);
 196       C   : Character;
 197
 198    begin
 199       if No (Clobber_Node) then
 200          return Null_Address;
 201       end if;
 202
 203       --  Skip spaces and commas before next register name
 204
 205       loop
 206          --  Return null string if no more names
 207
 208          if Clobber_Ptr > Len then
 209             return Null_Address;
 210          end if;
 211
 212          C := Get_Character (Get_String_Char (Str, Clobber_Ptr));
 213          exit when C /= ',' and then C /= ' ';
 214          Clobber_Ptr := Clobber_Ptr + 1;
 215       end loop;
 216
 217       --  Acquire next register name
 218
 219       Name_Len := 0;
 220       loop
 221          Name_Len := Name_Len + 1;
 222          Name_Buffer (Name_Len) := C;
 223          Clobber_Ptr := Clobber_Ptr + 1;
 224          exit when Clobber_Ptr > Len;
 225          C := Get_Character (Get_String_Char (Str, Clobber_Ptr));
 226          exit when C = ',' or else C = ' ';
 227       end loop;
 228
 229       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 230       return Name_Buffer'Address;
 231
 232    end Clobber_Get_Next;
 233
 234    -------------------
 235    -- Clobber_Setup --
 236    -------------------
 237
 238    procedure Clobber_Setup (N : Node_Id) is
 239       Call : constant Node_Id := Expression (Expression (N));
 240       Clob : constant Node_Id := Next_Actual (
 241                                    Next_Actual (
 242                                      Next_Actual (
 243                                        First_Actual (Call))));
 244
 245    begin
 246       if not Is_OK_Static_Expression (Clob) then
 247          Error_Msg_N ("asm clobber argument is not static", Clob);
 248          Clobber_Node := Empty;
 249
 250       else
 251          Clobber_Node := Get_String_Node (Clob);
 252          Clobber_Ptr := 1;
 253       end if;
 254    end Clobber_Setup;
 255
 256    ---------------------
 257    -- Expand_Asm_Call --
 258    ---------------------
 259
 260    procedure Expand_Asm_Call (N : Node_Id) is
 261       Loc : constant Source_Ptr := Sloc (N);
 262
 263       procedure Check_IO_Operand (N : Node_Id);
 264       --  Check for incorrect input or output operand
 265
 266       procedure Check_IO_Operand (N : Node_Id) is
 267          Err : Node_Id := N;
 268
 269       begin
 270          --  The only identifier allows is No_xxput_Operands. Since we
 271          --  know the type is right, it is sufficient to see if the
 272          --  referenced entity is in a runtime routine.
 273
 274          if Nkind (N) = N_Identifier
 275            and then
 276              Is_Predefined_File_Name (Unit_File_Name
 277                                        (Get_Source_Unit (Entity (N))))
 278          then
 279             return;
 280
 281          --  An attribute reference is fine, again the analysis reasonably
 282          --  guarantees that the attribute must be subtype'Asm_??put.
 283
 284          elsif Nkind (N) = N_Attribute_Reference then
 285             return;
 286
 287          --  The only other allowed form is an array aggregate in which
 288          --  all the entries are positional and are attribute references.
 289
 290          elsif Nkind (N) = N_Aggregate then
 291             if Present (Component_Associations (N)) then
 292                Err := First (Component_Associations (N));
 293
 294             elsif Present (Expressions (N)) then
 295                Err := First (Expressions (N));
 296                while Present (Err) loop
 297                   exit when Nkind (Err) /= N_Attribute_Reference;
 298                   Next (Err);
 299                end loop;
 300
 301                if No (Err) then
 302                   return;
 303                end if;
 304             end if;
 305          end if;
 306
 307          --  If we fall through, Err is pointing to the bad node
 308
 309          Error_Msg_N ("Asm operand has wrong form", Err);
 310       end Check_IO_Operand;
 311
 312    --  Start of processing for Expand_Asm_Call
 313
 314    begin
 315       --  Check that the input and output operands have the right
 316       --  form, as required by the documentation of the Asm feature:
 317
 318       --  OUTPUT_OPERAND_LIST ::=
 319       --    No_Output_Operands
 320       --  | OUTPUT_OPERAND_ATTRIBUTE
 321       --  | (OUTPUT_OPERAND_ATTRIBUTE @{,OUTPUT_OPERAND_ATTRIBUTE@})
 322
 323       --  OUTPUT_OPERAND_ATTRIBUTE ::=
 324       --    SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME)
 325
 326       --  INPUT_OPERAND_LIST ::=
 327       --    No_Input_Operands
 328       --  | INPUT_OPERAND_ATTRIBUTE
 329       --  | (INPUT_OPERAND_ATTRIBUTE @{,INPUT_OPERAND_ATTRIBUTE@})
 330
 331       --  INPUT_OPERAND_ATTRIBUTE ::=
 332       --    SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION)
 333
 334       declare
 335          Arg_Output : constant Node_Id := Next_Actual (First_Actual (N));
 336          Arg_Input  : constant Node_Id := Next_Actual (Arg_Output);
 337
 338       begin
 339          Check_IO_Operand (Arg_Output);
 340          Check_IO_Operand (Arg_Input);
 341       end;
 342
 343       --  If we have the function call case, we are inside a code statement,
 344       --  and the tree is already in the necessary form for gigi.
 345
 346       if Nkind (N) = N_Function_Call then
 347          null;
 348
 349       --  For the procedure case, we convert the call into a code statement
 350
 351       else
 352          pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
 353
 354          --  Note: strictly we should change the procedure call to a function
 355          --  call in the qualified expression, but since we are not going to
 356          --  reanalyze (see below), and the interface subprograms in this
 357          --  package don't care, we can leave it as a procedure call.
 358
 359          Rewrite (N,
 360            Make_Code_Statement (Loc,
 361              Expression =>
 362                Make_Qualified_Expression (Loc,
 363                  Subtype_Mark => New_Occurrence_Of (RTE (RE_Asm_Insn), Loc),
 364                  Expression => Relocate_Node (N))));
 365
 366          --  There is no need to reanalyze this node, it is completely analyzed
 367          --  already, at least sufficiently for the purposes of the abstract
 368          --  procedural interface defined in this package.
 369
 370          Set_Analyzed (N);
 371       end if;
 372    end Expand_Asm_Call;
 373
 374    ---------------------
 375    -- Get_String_Node --
 376    ---------------------
 377
 378    function Get_String_Node (S : Node_Id) return Node_Id is
 379    begin
 380       if Nkind (S) = N_String_Literal then
 381          return S;
 382
 383       else
 384          pragma Assert (Ekind (Entity (S)) = E_Constant);
 385          return Get_String_Node (Constant_Value (Entity (S)));
 386       end if;
 387    end Get_String_Node;
 388
 389    ---------------------
 390    -- Is_Asm_Volatile --
 391    ---------------------
 392
 393    function Is_Asm_Volatile (N : Node_Id) return Boolean is
 394       Call : constant Node_Id := Expression (Expression (N));
 395       Vol  : constant Node_Id :=
 396                Next_Actual (
 397                  Next_Actual (
 398                    Next_Actual (
 399                      Next_Actual (
 400                        First_Actual (Call)))));
 401
 402    begin
 403       if not Is_OK_Static_Expression (Vol) then
 404          Error_Msg_N ("asm volatile argument is not static", Vol);
 405          return False;
 406
 407       else
 408          return Is_True (Expr_Value (Vol));
 409       end if;
 410    end Is_Asm_Volatile;
 411
 412    --------------------
 413    -- Next_Asm_Input --
 414    --------------------
 415
 416    procedure Next_Asm_Input is
 417    begin
 418       Next_Asm_Operand (Current_Input_Operand);
 419    end Next_Asm_Input;
 420
 421    ----------------------
 422    -- Next_Asm_Operand --
 423    ----------------------
 424
 425    procedure Next_Asm_Operand (Operand_Var : in out Node_Id) is
 426    begin
 427       pragma Assert (Present (Operand_Var));
 428
 429       if Nkind (Parent (Operand_Var)) = N_Aggregate then
 430          Operand_Var := Next (Operand_Var);
 431
 432       else
 433          Operand_Var := Empty;
 434       end if;
 435    end Next_Asm_Operand;
 436
 437    ---------------------
 438    -- Next_Asm_Output --
 439    ---------------------
 440
 441    procedure Next_Asm_Output is
 442    begin
 443       Next_Asm_Operand (Current_Output_Operand);
 444    end Next_Asm_Output;
 445
 446    ----------------------
 447    -- Setup_Asm_Inputs --
 448    ----------------------
 449
 450    procedure Setup_Asm_Inputs (N : Node_Id) is
 451       Call : constant Node_Id := Expression (Expression (N));
 452
 453    begin
 454       Setup_Asm_IO_Args
 455         (Next_Actual (Next_Actual (First_Actual (Call))),
 456          Current_Input_Operand);
 457    end Setup_Asm_Inputs;
 458
 459    -----------------------
 460    -- Setup_Asm_IO_Args --
 461    -----------------------
 462
 463    procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id) is
 464    begin
 465       --  Case of single argument
 466
 467       if Nkind (Arg) = N_Attribute_Reference then
 468          Operand_Var := Arg;
 469
 470       --  Case of list of arguments
 471
 472       elsif Nkind (Arg) = N_Aggregate then
 473          if Expressions (Arg) = No_List then
 474             Operand_Var := Empty;
 475          else
 476             Operand_Var := First (Expressions (Arg));
 477          end if;
 478
 479       --  Otherwise must be default (no operands) case
 480
 481       else
 482          Operand_Var := Empty;
 483       end if;
 484    end Setup_Asm_IO_Args;
 485
 486    -----------------------
 487    -- Setup_Asm_Outputs --
 488    -----------------------
 489
 490    procedure Setup_Asm_Outputs (N : Node_Id) is
 491       Call : constant Node_Id := Expression (Expression (N));
 492
 493    begin
 494       Setup_Asm_IO_Args
 495         (Next_Actual (First_Actual (Call)),
 496          Current_Output_Operand);
 497    end Setup_Asm_Outputs;
 498
 499 end Exp_Code;