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