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-2003 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.
 276
 277    --  We can't use the freezing mechanism for this purpose, since we
 278    --  have to elaborate the initialization expression when it is first
 279    --  seen (i.e. this elaboration cannot be deferred to the freeze point).
 280
 281    procedure Expand_Pragma_Import (N : Node_Id) is
 282       Def_Id    : constant Entity_Id := Entity (Expression (Arg2 (N)));
 283       Typ       : Entity_Id;
 284       After_Def : Node_Id;
 285
 286    begin
 287       if Ekind (Def_Id) = E_Variable then
 288          Typ  := Etype (Def_Id);
 289          After_Def := Next (Parent (Def_Id));
 290
 291          if Has_Non_Null_Base_Init_Proc (Typ)
 292            and then Nkind (After_Def) = N_Procedure_Call_Statement
 293            and then Is_Entity_Name (Name (After_Def))
 294            and then Entity (Name (After_Def)) = Base_Init_Proc (Typ)
 295          then
 296             Remove (After_Def);
 297
 298          --  Any default initialization expression should be removed
 299          --  (e.g., null defaults for access objects, zero initialization
 300          --  of packed bit arrays). Imported objects aren't allowed to
 301          --  have explicit initialization, so the expression must have
 302          --  been generated by the compiler.
 303
 304          elsif Present (Expression (Parent (Def_Id))) then
 305             Set_Expression (Parent (Def_Id), Empty);
 306          end if;
 307       end if;
 308    end Expand_Pragma_Import;
 309
 310    -------------------------------------------
 311    -- Expand_Pragma_Import_Export_Exception --
 312    -------------------------------------------
 313
 314    --  For a VMS exception fix up the language field with "VMS"
 315    --  instead of "Ada" (gigi needs this), create a constant that will be the
 316    --  value of the VMS condition code and stuff the Interface_Name field
 317    --  with the unexpanded name of the exception (if not already set).
 318    --  For a Ada exception, just stuff the Interface_Name field
 319    --  with the unexpanded name of the exception (if not already set).
 320
 321    procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
 322    begin
 323       --  This pragma is only effective on OpenVMS systems, it was ignored
 324       --  on non-VMS systems, and we need to ignore it here as well.
 325
 326       if not OpenVMS_On_Target then
 327          return;
 328       end if;
 329
 330       declare
 331          Id     : constant Entity_Id := Entity (Expression (Arg1 (N)));
 332          Call   : constant Node_Id := Register_Exception_Call (Id);
 333          Loc    : constant Source_Ptr := Sloc (N);
 334
 335       begin
 336          if Present (Call) then
 337             declare
 338                Excep_Internal : constant Node_Id :=
 339                                  Make_Defining_Identifier
 340                                   (Loc, New_Internal_Name ('V'));
 341                Export_Pragma  : Node_Id;
 342                Excep_Alias    : Node_Id;
 343                Excep_Object   : Node_Id;
 344                Excep_Image : String_Id;
 345                Exdata      : List_Id;
 346                Lang1       : Node_Id;
 347                Lang2       : Node_Id;
 348                Lang3       : Node_Id;
 349                Code        : Node_Id;
 350
 351             begin
 352                if Present (Interface_Name (Id)) then
 353                   Excep_Image := Strval (Interface_Name (Id));
 354                else
 355                   Get_Name_String (Chars (Id));
 356                   Set_All_Upper_Case;
 357                   Excep_Image := String_From_Name_Buffer;
 358                end if;
 359
 360                Exdata := Component_Associations (Expression (Parent (Id)));
 361
 362                if Is_VMS_Exception (Id) then
 363                   Lang1 := Next (First (Exdata));
 364                   Lang2 := Next (Lang1);
 365                   Lang3 := Next (Lang2);
 366
 367                   Rewrite (Expression (Lang1),
 368                     Make_Character_Literal (Loc,
 369                       Chars => Name_uV,
 370                       Char_Literal_Value => Get_Char_Code ('V')));
 371                   Analyze (Expression (Lang1));
 372
 373                   Rewrite (Expression (Lang2),
 374                     Make_Character_Literal (Loc,
 375                       Chars => Name_uM,
 376                       Char_Literal_Value => Get_Char_Code ('M')));
 377                   Analyze (Expression (Lang2));
 378
 379                   Rewrite (Expression (Lang3),
 380                     Make_Character_Literal (Loc,
 381                       Chars => Name_uS,
 382                       Char_Literal_Value => Get_Char_Code ('S')));
 383                   Analyze (Expression (Lang3));
 384
 385                   if Exception_Code (Id) /= No_Uint then
 386                      Code :=
 387                        Make_Integer_Literal (Loc,
 388                          Intval => Exception_Code (Id));
 389
 390                      Excep_Object :=
 391                        Make_Object_Declaration (Loc,
 392                          Defining_Identifier => Excep_Internal,
 393                          Object_Definition   =>
 394                            New_Reference_To (Standard_Integer, Loc));
 395
 396                      Insert_Action (N, Excep_Object);
 397                      Analyze (Excep_Object);
 398
 399                      Start_String;
 400                      Store_String_Int
 401                        (UI_To_Int (Exception_Code (Id)) / 8 * 8);
 402
 403                      Excep_Alias :=
 404                        Make_Pragma
 405                          (Loc,
 406                           Name_Linker_Alias,
 407                           New_List
 408                             (Make_Pragma_Argument_Association
 409                                (Sloc => Loc,
 410                                 Expression =>
 411                                   New_Reference_To (Excep_Internal, Loc)),
 412
 413                              Make_Pragma_Argument_Association
 414                                (Sloc => Loc,
 415                                 Expression =>
 416                                   Make_String_Literal
 417                                     (Sloc => Loc,
 418                                      Strval => End_String))));
 419
 420                      Insert_Action (N, Excep_Alias);
 421                      Analyze (Excep_Alias);
 422
 423                      Export_Pragma :=
 424                        Make_Pragma
 425                          (Loc,
 426                           Name_Export,
 427                           New_List
 428                             (Make_Pragma_Argument_Association
 429                                (Sloc => Loc,
 430                                 Expression => Make_Identifier (Loc, Name_C)),
 431
 432                              Make_Pragma_Argument_Association
 433                                (Sloc => Loc,
 434                                 Expression =>
 435                                   New_Reference_To (Excep_Internal, Loc)),
 436
 437                              Make_Pragma_Argument_Association
 438                                (Sloc => Loc,
 439                                 Expression =>
 440                                   Make_String_Literal
 441                                     (Sloc => Loc,
 442                                      Strval => Excep_Image)),
 443
 444                              Make_Pragma_Argument_Association
 445                                (Sloc => Loc,
 446                                 Expression =>
 447                                   Make_String_Literal
 448                                     (Sloc => Loc,
 449                                      Strval => Excep_Image))));
 450
 451                      Insert_Action (N, Export_Pragma);
 452                      Analyze (Export_Pragma);
 453
 454                   else
 455                      Code :=
 456                         Unchecked_Convert_To (Standard_Integer,
 457                           Make_Function_Call (Loc,
 458                             Name =>
 459                               New_Reference_To (RTE (RE_Import_Value), Loc),
 460                             Parameter_Associations => New_List
 461                               (Make_String_Literal (Loc,
 462                                 Strval => Excep_Image))));
 463                   end if;
 464
 465                   Rewrite (Call,
 466                     Make_Procedure_Call_Statement (Loc,
 467                       Name => New_Reference_To
 468                                 (RTE (RE_Register_VMS_Exception), Loc),
 469                       Parameter_Associations => New_List (Code)));
 470
 471                   Analyze_And_Resolve (Code, Standard_Integer);
 472                   Analyze (Call);
 473                end if;
 474
 475                if not Present (Interface_Name (Id)) then
 476                   Set_Interface_Name (Id,
 477                      Make_String_Literal
 478                        (Sloc => Loc,
 479                         Strval => Excep_Image));
 480                end if;
 481             end;
 482          end if;
 483       end;
 484    end Expand_Pragma_Import_Export_Exception;
 485
 486    ------------------------------------
 487    -- Expand_Pragma_Inspection_Point --
 488    ------------------------------------
 489
 490    --  If no argument is given, then we supply a default argument list that
 491    --  includes all objects declared at the source level in all subprograms
 492    --  that enclose the inspection point pragma.
 493
 494    procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
 495       Loc : constant Source_Ptr := Sloc (N);
 496       A     : List_Id;
 497       Assoc : Node_Id;
 498       S     : Entity_Id;
 499       E     : Entity_Id;
 500
 501    begin
 502       if No (Pragma_Argument_Associations (N)) then
 503          A := New_List;
 504          S := Current_Scope;
 505
 506          while S /= Standard_Standard loop
 507             E := First_Entity (S);
 508             while Present (E) loop
 509                if Comes_From_Source (E)
 510                  and then Is_Object (E)
 511                  and then not Is_Entry_Formal (E)
 512                  and then Ekind (E) /= E_Component
 513                  and then Ekind (E) /= E_Discriminant
 514                  and then Ekind (E) /= E_Generic_In_Parameter
 515                  and then Ekind (E) /= E_Generic_In_Out_Parameter
 516                then
 517                   Append_To (A,
 518                     Make_Pragma_Argument_Association (Loc,
 519                       Expression => New_Occurrence_Of (E, Loc)));
 520                end if;
 521
 522                Next_Entity (E);
 523             end loop;
 524
 525             S := Scope (S);
 526          end loop;
 527
 528          Set_Pragma_Argument_Associations (N, A);
 529       end if;
 530
 531       --  Expand the arguments of the pragma. Expanding an entity reference
 532       --  is a noop, except in a protected operation, where a reference may
 533       --  have to be transformed into a reference to the corresponding prival.
 534       --  Are there other pragmas that may require this ???
 535
 536       Assoc := First (Pragma_Argument_Associations (N));
 537
 538       while Present (Assoc) loop
 539          Expand (Expression (Assoc));
 540          Next (Assoc);
 541       end loop;
 542    end Expand_Pragma_Inspection_Point;
 543
 544    --------------------------------------
 545    -- Expand_Pragma_Interrupt_Priority --
 546    --------------------------------------
 547
 548    --  Supply default argument if none exists (System.Interrupt_Priority'Last)
 549
 550    procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
 551       Loc : constant Source_Ptr := Sloc (N);
 552
 553    begin
 554       if No (Pragma_Argument_Associations (N)) then
 555          Set_Pragma_Argument_Associations (N, New_List (
 556            Make_Pragma_Argument_Association (Loc,
 557              Expression =>
 558                Make_Attribute_Reference (Loc,
 559                  Prefix =>
 560                    New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
 561                  Attribute_Name => Name_Last))));
 562       end if;
 563    end Expand_Pragma_Interrupt_Priority;
 564
 565 end Exp_Prag;