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