gcc/ada/exp_prag.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ P R A G                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2002 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Exp_Ch11; use Exp_Ch11;
  32 with Exp_Tss;  use Exp_Tss;
  33 with Exp_Util; use Exp_Util;
  34 with Expander; use Expander;
  35 with Namet;    use Namet;
  36 with Nlists;   use Nlists;
  37 with Nmake;    use Nmake;
  38 with Opt;      use Opt;
  39 with Rtsfind;  use Rtsfind;
  40 with Sem;      use Sem;
  41 with Sem_Eval; use Sem_Eval;
  42 with Sem_Res;  use Sem_Res;
  43 with Sem_Util; use Sem_Util;
  44 with Sinfo;    use Sinfo;
  45 with Sinput;   use Sinput;
  46 with Snames;   use Snames;
  47 with Stringt;  use Stringt;
  48 with Stand;    use Stand;
  49 with Tbuild;   use Tbuild;
  50 with Uintp;    use Uintp;
  51
  52 package body Exp_Prag is
  53
  54    -----------------------
  55    -- Local Subprograms --
  56    -----------------------
  57
  58    function Arg1 (N : Node_Id) return Node_Id;
  59    function Arg2 (N : Node_Id) return Node_Id;
  60    --  Obtain specified Pragma_Argument_Association
  61
  62    procedure Expand_Pragma_Abort_Defer             (N : Node_Id);
  63    procedure Expand_Pragma_Assert                  (N : Node_Id);
  64    procedure Expand_Pragma_Import                  (N : Node_Id);
  65    procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
  66    procedure Expand_Pragma_Inspection_Point        (N : Node_Id);
  67    procedure Expand_Pragma_Interrupt_Priority      (N : Node_Id);
  68
  69    ----------
  70    -- Arg1 --
  71    ----------
  72
  73    function Arg1 (N : Node_Id) return Node_Id is
  74    begin
  75       return First (Pragma_Argument_Associations (N));
  76    end Arg1;
  77
  78    ----------
  79    -- Arg2 --
  80    ----------
  81
  82    function Arg2 (N : Node_Id) return Node_Id is
  83    begin
  84       return Next (Arg1 (N));
  85    end Arg2;
  86
  87    ---------------------
  88    -- Expand_N_Pragma --
  89    ---------------------
  90
  91    procedure Expand_N_Pragma (N : Node_Id) is
  92    begin
  93       --  Note: we may have a pragma whose chars field is not a
  94       --  recognized pragma, and we must ignore it at this stage.
  95
  96       if Is_Pragma_Name (Chars (N)) then
  97          case Get_Pragma_Id (Chars (N)) is
  98
  99             --  Pragmas requiring special expander action
 100
 101             when Pragma_Abort_Defer =>
 102                Expand_Pragma_Abort_Defer (N);
 103
 104             when Pragma_Assert =>
 105                Expand_Pragma_Assert (N);
 106
 107             when Pragma_Export_Exception =>
 108                Expand_Pragma_Import_Export_Exception (N);
 109
 110             when Pragma_Import =>
 111                Expand_Pragma_Import (N);
 112
 113             when Pragma_Import_Exception =>
 114                Expand_Pragma_Import_Export_Exception (N);
 115
 116             when Pragma_Inspection_Point =>
 117                Expand_Pragma_Inspection_Point (N);
 118
 119             when Pragma_Interrupt_Priority =>
 120                Expand_Pragma_Interrupt_Priority (N);
 121
 122             --  All other pragmas need no expander action
 123
 124             when others => null;
 125          end case;
 126       end if;
 127
 128    end Expand_N_Pragma;
 129
 130    -------------------------------
 131    -- Expand_Pragma_Abort_Defer --
 132    -------------------------------
 133
 134    --  An Abort_Defer pragma appears as the first statement in a handled
 135    --  statement sequence (right after the begin). It defers aborts for
 136    --  the entire statement sequence, but not for any declarations or
 137    --  handlers (if any) associated with this statement sequence.
 138
 139    --  The transformation is to transform
 140
 141    --    pragma Abort_Defer;
 142    --    statements;
 143
 144    --  into
 145
 146    --    begin
 147    --       Abort_Defer.all;
 148    --       statements
 149    --    exception
 150    --       when all others =>
 151    --          Abort_Undefer.all;
 152    --          raise;
 153    --    at end
 154    --       Abort_Undefer_Direct;
 155    --    end;
 156
 157    procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
 158       Loc  : constant Source_Ptr := Sloc (N);
 159       Stm  : Node_Id;
 160       Stms : List_Id;
 161       HSS  : Node_Id;
 162       Blk  : constant Entity_Id :=
 163         New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
 164
 165    begin
 166       Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
 167
 168       loop
 169          Stm := Remove_Next (N);
 170          exit when No (Stm);
 171          Append (Stm, Stms);
 172       end loop;
 173
 174       HSS :=
 175         Make_Handled_Sequence_Of_Statements (Loc,
 176           Statements => Stms,
 177           At_End_Proc =>
 178             New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
 179
 180       Rewrite (N,
 181         Make_Block_Statement (Loc,
 182           Handled_Statement_Sequence => HSS));
 183
 184       Set_Scope (Blk, Current_Scope);
 185       Set_Etype (Blk, Standard_Void_Type);
 186       Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
 187       Expand_At_End_Handler (HSS, Blk);
 188       Analyze (N);
 189    end Expand_Pragma_Abort_Defer;
 190
 191    --------------------------
 192    -- Expand_Pragma_Assert --
 193    --------------------------
 194
 195    procedure Expand_Pragma_Assert (N : Node_Id) is
 196       Loc  : constant Source_Ptr := Sloc (N);
 197       Cond : constant Node_Id    := Expression (Arg1 (N));
 198       Msg  : String_Id;
 199
 200    begin
 201       --  We already know that assertions are enabled, because otherwise
 202       --  the semantic pass dealt with rewriting the assertion (see Sem_Prag)
 203
 204       pragma Assert (Assertions_Enabled);
 205
 206       --  Since assertions are on, we rewrite the pragma with its
 207       --  corresponding if statement, and then analyze the statement
 208       --  The expansion transforms:
 209
 210       --    pragma Assert (condition [,message]);
 211
 212       --  into
 213
 214       --    if not condition then
 215       --       System.Assertions.Raise_Assert_Failure (Str);
 216       --    end if;
 217
 218       --  where Str is the message if one is present, or the default of
 219       --  file:line if no message is given.
 220
 221       --  First, we need to prepare the character literal
 222
 223       if Present (Arg2 (N)) then
 224          Msg := Strval (Expr_Value_S (Expression (Arg2 (N))));
 225       else
 226          Build_Location_String (Loc);
 227          Msg := String_From_Name_Buffer;
 228       end if;
 229
 230       --  Now generate the if statement. Note that we consider this to be
 231       --  an explicit conditional in the source, not an implicit if, so we
 232       --  do not call Make_Implicit_If_Statement.
 233
 234       Rewrite (N,
 235         Make_If_Statement (Loc,
 236           Condition =>
 237             Make_Op_Not (Loc,
 238               Right_Opnd => Cond),
 239           Then_Statements => New_List (
 240             Make_Procedure_Call_Statement (Loc,
 241               Name =>
 242                 New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
 243               Parameter_Associations => New_List (
 244                 Make_String_Literal (Loc, Msg))))));
 245
 246       Analyze (N);
 247
 248       --  If new condition is always false, give a warning
 249
 250       if Nkind (N) = N_Procedure_Call_Statement
 251         and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
 252       then
 253          --  If original condition was a Standard.False, we assume
 254          --  that this is indeed intented to raise assert error
 255          --  and no warning is required.
 256
 257          if Is_Entity_Name (Original_Node (Cond))
 258            and then Entity (Original_Node (Cond)) = Standard_False
 259          then
 260             return;
 261          else
 262             Error_Msg_N ("?assertion will fail at run-time", N);
 263          end if;
 264       end if;
 265    end Expand_Pragma_Assert;
 266
 267    --------------------------
 268    -- Expand_Pragma_Import --
 269    --------------------------
 270
 271    --  When applied to a variable, the default initialization must not be
 272    --  done. As it is already done when the pragma is found, we just get rid
 273    --  of the call the initialization procedure which followed the object
 274    --  declaration.
 275
 276    --  We can't use the freezing mechanism for this purpose, since we
 277    --  have to elaborate the initialization expression when it is first
 278    --  seen (i.e. this elaboration cannot be deferred to the freeze point).
 279
 280    procedure Expand_Pragma_Import (N : Node_Id) is
 281       Def_Id    : constant Entity_Id := Entity (Expression (Arg2 (N)));
 282       Typ       : Entity_Id;
 283       After_Def : Node_Id;
 284
 285    begin
 286       if Ekind (Def_Id) = E_Variable then
 287          Typ  := Etype (Def_Id);
 288          After_Def := Next (Parent (Def_Id));
 289
 290          if Has_Non_Null_Base_Init_Proc (Typ)
 291            and then Nkind (After_Def) = N_Procedure_Call_Statement
 292            and then Is_Entity_Name (Name (After_Def))
 293            and then Entity (Name (After_Def)) = Base_Init_Proc (Typ)
 294          then
 295             Remove (After_Def);
 296
 297          elsif Is_Access_Type (Typ) then
 298             Set_Expression (Parent (Def_Id), Empty);
 299          end if;
 300       end if;
 301    end Expand_Pragma_Import;
 302
 303    -------------------------------------------
 304    -- Expand_Pragma_Import_Export_Exception --
 305    -------------------------------------------
 306
 307    --  For a VMS exception fix up the language field with "VMS"
 308    --  instead of "Ada" (gigi needs this), create a constant that will be the
 309    --  value of the VMS condition code and stuff the Interface_Name field
 310    --  with the unexpanded name of the exception (if not already set).
 311    --  For a Ada exception, just stuff the Interface_Name field
 312    --  with the unexpanded name of the exception (if not already set).
 313
 314    procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
 315       Id     : constant Entity_Id := Entity (Expression (Arg1 (N)));
 316       Call   : constant Node_Id := Register_Exception_Call (Id);
 317       Loc    : constant Source_Ptr := Sloc (N);
 318    begin
 319       if Present (Call) then
 320          declare
 321             Excep_Internal : constant Node_Id :=
 322                               Make_Defining_Identifier
 323                                (Loc, New_Internal_Name ('V'));
 324             Export_Pragma  : Node_Id;
 325             Excep_Alias    : Node_Id;
 326             Excep_Object   : Node_Id;
 327             Excep_Image : String_Id;
 328             Exdata      : List_Id;
 329             Lang1       : Node_Id;
 330             Lang2       : Node_Id;
 331             Lang3       : Node_Id;
 332             Code        : Node_Id;
 333          begin
 334             if Present (Interface_Name (Id)) then
 335                Excep_Image := Strval (Interface_Name (Id));
 336             else
 337                Get_Name_String (Chars (Id));
 338                Set_All_Upper_Case;
 339                Excep_Image := String_From_Name_Buffer;
 340             end if;
 341
 342             Exdata := Component_Associations (Expression (Parent (Id)));
 343
 344             if Is_VMS_Exception (Id) then
 345
 346                Lang1 := Next (First (Exdata));
 347                Lang2 := Next (Lang1);
 348                Lang3 := Next (Lang2);
 349
 350                Rewrite (Expression (Lang1),
 351                  Make_Character_Literal (Loc, Name_uV, Get_Char_Code ('V')));
 352                Analyze (Expression (Lang1));
 353
 354                Rewrite (Expression (Lang2),
 355                  Make_Character_Literal (Loc, Name_uM, Get_Char_Code ('M')));
 356                Analyze (Expression (Lang2));
 357
 358                Rewrite (Expression (Lang3),
 359                  Make_Character_Literal (Loc, Name_uS, Get_Char_Code ('S')));
 360                Analyze (Expression (Lang3));
 361
 362                if Exception_Code (Id) /= No_Uint then
 363                   Code := Make_Integer_Literal (Loc, Exception_Code (Id));
 364
 365                   Excep_Object :=
 366                     Make_Object_Declaration (Loc,
 367                       Defining_Identifier => Excep_Internal,
 368                       Object_Definition   =>
 369                         New_Reference_To (Standard_Integer, Loc));
 370
 371                   Insert_Action (N, Excep_Object);
 372                   Analyze (Excep_Object);
 373
 374                   Start_String;
 375                   Store_String_Int (UI_To_Int (Exception_Code (Id)) / 8 * 8);
 376
 377                   Excep_Alias :=
 378                     Make_Pragma
 379                       (Loc,
 380                        Name_Linker_Alias,
 381                        New_List
 382                          (Make_Pragma_Argument_Association
 383                             (Sloc => Loc,
 384                              Expression =>
 385                                New_Reference_To (Excep_Internal, Loc)),
 386                           Make_Pragma_Argument_Association
 387                             (Sloc => Loc,
 388                              Expression =>
 389                                Make_String_Literal
 390                                  (Sloc => Loc,
 391                                   Strval => End_String))));
 392
 393                   Insert_Action (N, Excep_Alias);
 394                   Analyze (Excep_Alias);
 395
 396                   Export_Pragma :=
 397                     Make_Pragma
 398                       (Loc,
 399                        Name_Export,
 400                        New_List
 401                          (Make_Pragma_Argument_Association
 402                             (Sloc => Loc,
 403                              Expression => Make_Identifier (Loc, Name_C)),
 404                           Make_Pragma_Argument_Association
 405                             (Sloc => Loc,
 406                              Expression =>
 407                                New_Reference_To (Excep_Internal, Loc)),
 408                           Make_Pragma_Argument_Association
 409                             (Sloc => Loc,
 410                              Expression =>
 411                                Make_String_Literal
 412                                  (Sloc => Loc,
 413                                   Strval => Excep_Image)),
 414                           Make_Pragma_Argument_Association
 415                             (Sloc => Loc,
 416                              Expression =>
 417                                Make_String_Literal
 418                                  (Sloc => Loc,
 419                                   Strval => Excep_Image))));
 420
 421                   Insert_Action (N, Export_Pragma);
 422                   Analyze (Export_Pragma);
 423
 424                else
 425                   Code :=
 426                      Unchecked_Convert_To (Standard_Integer,
 427                        Make_Function_Call (Loc,
 428                          Name =>
 429                            New_Reference_To (RTE (RE_Import_Value), Loc),
 430                          Parameter_Associations => New_List
 431                            (Make_String_Literal (Loc,
 432                              Strval => Excep_Image))));
 433                end if;
 434
 435                Rewrite (Call,
 436                  Make_Procedure_Call_Statement (Loc,
 437                    Name => New_Reference_To
 438                              (RTE (RE_Register_VMS_Exception), Loc),
 439                    Parameter_Associations => New_List (Code)));
 440
 441                Analyze_And_Resolve (Code, Standard_Integer);
 442                Analyze (Call);
 443
 444             end if;
 445
 446             if not Present (Interface_Name (Id)) then
 447                Set_Interface_Name (Id,
 448                   Make_String_Literal
 449                     (Sloc => Loc,
 450                      Strval => Excep_Image));
 451             end if;
 452          end;
 453       end if;
 454    end Expand_Pragma_Import_Export_Exception;
 455
 456    ------------------------------------
 457    -- Expand_Pragma_Inspection_Point --
 458    ------------------------------------
 459
 460    --  If no argument is given, then we supply a default argument list that
 461    --  includes all objects declared at the source level in all subprograms
 462    --  that enclose the inspection point pragma.
 463
 464    procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
 465       Loc : constant Source_Ptr := Sloc (N);
 466       A     : List_Id;
 467       Assoc : Node_Id;
 468       S     : Entity_Id;
 469       E     : Entity_Id;
 470
 471    begin
 472       if No (Pragma_Argument_Associations (N)) then
 473          A := New_List;
 474          S := Current_Scope;
 475
 476          while S /= Standard_Standard loop
 477             E := First_Entity (S);
 478             while Present (E) loop
 479                if Comes_From_Source (E)
 480                  and then Is_Object (E)
 481                  and then not Is_Entry_Formal (E)
 482                  and then Ekind (E) /= E_Component
 483                  and then Ekind (E) /= E_Discriminant
 484                  and then Ekind (E) /= E_Generic_In_Parameter
 485                  and then Ekind (E) /= E_Generic_In_Out_Parameter
 486                then
 487                   Append_To (A,
 488                     Make_Pragma_Argument_Association (Loc,
 489                       Expression => New_Occurrence_Of (E, Loc)));
 490                end if;
 491
 492                Next_Entity (E);
 493             end loop;
 494
 495             S := Scope (S);
 496          end loop;
 497
 498          Set_Pragma_Argument_Associations (N, A);
 499       end if;
 500
 501       --  Expand the arguments of the pragma. Expanding an entity reference
 502       --  is a noop, except in a protected operation, where a reference may
 503       --  have to be transformed into a reference to the corresponding prival.
 504       --  Are there other pragmas that may require this ???
 505
 506       Assoc := First (Pragma_Argument_Associations (N));
 507
 508       while Present (Assoc) loop
 509          Expand (Expression (Assoc));
 510          Next (Assoc);
 511       end loop;
 512    end Expand_Pragma_Inspection_Point;
 513
 514    --------------------------------------
 515    -- Expand_Pragma_Interrupt_Priority --
 516    --------------------------------------
 517
 518    --  Supply default argument if none exists (System.Interrupt_Priority'Last)
 519
 520    procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
 521       Loc : constant Source_Ptr := Sloc (N);
 522
 523    begin
 524       if No (Pragma_Argument_Associations (N)) then
 525          Set_Pragma_Argument_Associations (N, New_List (
 526            Make_Pragma_Argument_Association (Loc,
 527              Expression =>
 528                Make_Attribute_Reference (Loc,
 529                  Prefix =>
 530                    New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
 531                  Attribute_Name => Name_Last))));
 532       end if;
 533    end Expand_Pragma_Interrupt_Priority;
 534
 535 end Exp_Prag;