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