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