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