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 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Casing;   use Casing;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Exp_Ch11; use Exp_Ch11;
  33 with Exp_Tss;  use Exp_Tss;
  34 with Exp_Util; use Exp_Util;
  35 with Expander; use Expander;
  36 with Namet;    use Namet;
  37 with Nlists;   use Nlists;
  38 with Nmake;    use Nmake;
  39 with Opt;      use Opt;
  40 with Rtsfind;  use Rtsfind;
  41 with Sem;      use Sem;
  42 with Sem_Eval; use Sem_Eval;
  43 with Sem_Res;  use Sem_Res;
  44 with Sem_Util; use Sem_Util;
  45 with Sinfo;    use Sinfo;
  46 with Sinput;   use Sinput;
  47 with Snames;   use Snames;
  48 with Stringt;  use Stringt;
  49 with Stand;    use Stand;
  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          elsif Is_Access_Type (Typ) then
 299             Set_Expression (Parent (Def_Id), Empty);
 300          end if;
 301       end if;
 302    end Expand_Pragma_Import;
 303
 304    -------------------------------------------
 305    -- Expand_Pragma_Import_Export_Exception --
 306    -------------------------------------------
 307
 308    --  For a VMS exception fix up the language field with "VMS"
 309    --  instead of "Ada" (gigi needs this), create a constant that will be the
 310    --  value of the VMS condition code and stuff the Interface_Name field
 311    --  with the unexpanded name of the exception (if not already set).
 312    --  For a Ada exception, just stuff the Interface_Name field
 313    --  with the unexpanded name of the exception (if not already set).
 314
 315    procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
 316       Id     : constant Entity_Id := Entity (Expression (Arg1 (N)));
 317       Call   : constant Node_Id := Register_Exception_Call (Id);
 318       Loc    : constant Source_Ptr := Sloc (N);
 319    begin
 320       if Present (Call) then
 321          declare
 322             Excep_Internal : constant Node_Id :=
 323                               Make_Defining_Identifier
 324                                (Loc, New_Internal_Name ('V'));
 325             Export_Pragma  : Node_Id;
 326             Excep_Alias    : Node_Id;
 327             Excep_Object   : Node_Id;
 328             Excep_Image : String_Id;
 329             Exdata      : List_Id;
 330             Lang1       : Node_Id;
 331             Lang2       : Node_Id;
 332             Lang3       : Node_Id;
 333             Code        : Node_Id;
 334          begin
 335             if Present (Interface_Name (Id)) then
 336                Excep_Image := Strval (Interface_Name (Id));
 337             else
 338                Get_Name_String (Chars (Id));
 339                Set_All_Upper_Case;
 340                Excep_Image := String_From_Name_Buffer;
 341             end if;
 342
 343             Exdata := Component_Associations (Expression (Parent (Id)));
 344
 345             if Is_VMS_Exception (Id) then
 346
 347                Lang1 := Next (First (Exdata));
 348                Lang2 := Next (Lang1);
 349                Lang3 := Next (Lang2);
 350
 351                Rewrite (Expression (Lang1),
 352                  Make_Character_Literal (Loc, Name_uV, Get_Char_Code ('V')));
 353                Analyze (Expression (Lang1));
 354
 355                Rewrite (Expression (Lang2),
 356                  Make_Character_Literal (Loc, Name_uM, Get_Char_Code ('M')));
 357                Analyze (Expression (Lang2));
 358
 359                Rewrite (Expression (Lang3),
 360                  Make_Character_Literal (Loc, Name_uS, Get_Char_Code ('S')));
 361                Analyze (Expression (Lang3));
 362
 363                if Exception_Code (Id) /= No_Uint then
 364                   Code := Make_Integer_Literal (Loc, Exception_Code (Id));
 365
 366                   Excep_Object :=
 367                     Make_Object_Declaration (Loc,
 368                       Defining_Identifier => Excep_Internal,
 369                       Object_Definition   =>
 370                         New_Reference_To (Standard_Integer, Loc));
 371
 372                   Insert_Action (N, Excep_Object);
 373                   Analyze (Excep_Object);
 374
 375                   Start_String;
 376                   Store_String_Int (UI_To_Int (Exception_Code (Id)) / 8 * 8);
 377
 378                   Excep_Alias :=
 379                     Make_Pragma
 380                       (Loc,
 381                        Name_Linker_Alias,
 382                        New_List
 383                          (Make_Pragma_Argument_Association
 384                             (Sloc => Loc,
 385                              Expression =>
 386                                New_Reference_To (Excep_Internal, Loc)),
 387                           Make_Pragma_Argument_Association
 388                             (Sloc => Loc,
 389                              Expression =>
 390                                Make_String_Literal
 391                                  (Sloc => Loc,
 392                                   Strval => End_String))));
 393
 394                   Insert_Action (N, Excep_Alias);
 395                   Analyze (Excep_Alias);
 396
 397                   Export_Pragma :=
 398                     Make_Pragma
 399                       (Loc,
 400                        Name_Export,
 401                        New_List
 402                          (Make_Pragma_Argument_Association
 403                             (Sloc => Loc,
 404                              Expression => Make_Identifier (Loc, Name_C)),
 405                           Make_Pragma_Argument_Association
 406                             (Sloc => Loc,
 407                              Expression =>
 408                                New_Reference_To (Excep_Internal, Loc)),
 409                           Make_Pragma_Argument_Association
 410                             (Sloc => Loc,
 411                              Expression =>
 412                                Make_String_Literal
 413                                  (Sloc => Loc,
 414                                   Strval => Excep_Image)),
 415                           Make_Pragma_Argument_Association
 416                             (Sloc => Loc,
 417                              Expression =>
 418                                Make_String_Literal
 419                                  (Sloc => Loc,
 420                                   Strval => Excep_Image))));
 421
 422                   Insert_Action (N, Export_Pragma);
 423                   Analyze (Export_Pragma);
 424
 425                else
 426                   Code :=
 427                      Unchecked_Convert_To (Standard_Integer,
 428                        Make_Function_Call (Loc,
 429                          Name =>
 430                            New_Reference_To (RTE (RE_Import_Value), Loc),
 431                          Parameter_Associations => New_List
 432                            (Make_String_Literal (Loc,
 433                              Strval => Excep_Image))));
 434                end if;
 435
 436                Rewrite (Call,
 437                  Make_Procedure_Call_Statement (Loc,
 438                    Name => New_Reference_To
 439                              (RTE (RE_Register_VMS_Exception), Loc),
 440                    Parameter_Associations => New_List (Code)));
 441
 442                Analyze_And_Resolve (Code, Standard_Integer);
 443                Analyze (Call);
 444
 445             end if;
 446
 447             if not Present (Interface_Name (Id)) then
 448                Set_Interface_Name (Id,
 449                   Make_String_Literal
 450                     (Sloc => Loc,
 451                      Strval => Excep_Image));
 452             end if;
 453          end;
 454       end if;
 455    end Expand_Pragma_Import_Export_Exception;
 456
 457    ------------------------------------
 458    -- Expand_Pragma_Inspection_Point --
 459    ------------------------------------
 460
 461    --  If no argument is given, then we supply a default argument list that
 462    --  includes all objects declared at the source level in all subprograms
 463    --  that enclose the inspection point pragma.
 464
 465    procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
 466       Loc : constant Source_Ptr := Sloc (N);
 467       A     : List_Id;
 468       Assoc : Node_Id;
 469       S     : Entity_Id;
 470       E     : Entity_Id;
 471
 472    begin
 473       if No (Pragma_Argument_Associations (N)) then
 474          A := New_List;
 475          S := Current_Scope;
 476
 477          while S /= Standard_Standard loop
 478             E := First_Entity (S);
 479             while Present (E) loop
 480                if Comes_From_Source (E)
 481                  and then Is_Object (E)
 482                  and then not Is_Entry_Formal (E)
 483                  and then Ekind (E) /= E_Component
 484                  and then Ekind (E) /= E_Discriminant
 485                  and then Ekind (E) /= E_Generic_In_Parameter
 486                  and then Ekind (E) /= E_Generic_In_Out_Parameter
 487                then
 488                   Append_To (A,
 489                     Make_Pragma_Argument_Association (Loc,
 490                       Expression => New_Occurrence_Of (E, Loc)));
 491                end if;
 492
 493                Next_Entity (E);
 494             end loop;
 495
 496             S := Scope (S);
 497          end loop;
 498
 499          Set_Pragma_Argument_Associations (N, A);
 500       end if;
 501
 502       --  Expand the arguments of the pragma. Expanding an entity reference
 503       --  is a noop, except in a protected operation, where a reference may
 504       --  have to be transformed into a reference to the corresponding prival.
 505       --  Are there other pragmas that may require this ???
 506
 507       Assoc := First (Pragma_Argument_Associations (N));
 508
 509       while Present (Assoc) loop
 510          Expand (Expression (Assoc));
 511          Next (Assoc);
 512       end loop;
 513    end Expand_Pragma_Inspection_Point;
 514
 515    --------------------------------------
 516    -- Expand_Pragma_Interrupt_Priority --
 517    --------------------------------------
 518
 519    --  Supply default argument if none exists (System.Interrupt_Priority'Last)
 520
 521    procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
 522       Loc : constant Source_Ptr := Sloc (N);
 523
 524    begin
 525       if No (Pragma_Argument_Associations (N)) then
 526          Set_Pragma_Argument_Associations (N, New_List (
 527            Make_Pragma_Argument_Association (Loc,
 528              Expression =>
 529                Make_Attribute_Reference (Loc,
 530                  Prefix =>
 531                    New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
 532                  Attribute_Name => Name_Last))));
 533       end if;
 534    end Expand_Pragma_Interrupt_Priority;
 535
 536 end Exp_Prag;