gcc/ada/exp_intr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ I N T R                              --
   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 Einfo;    use Einfo;
  29 with Errout;   use Errout;
  30 with Exp_Ch4;  use Exp_Ch4;
  31 with Exp_Ch7;  use Exp_Ch7;
  32 with Exp_Ch11; use Exp_Ch11;
  33 with Exp_Code; use Exp_Code;
  34 with Exp_Fixd; use Exp_Fixd;
  35 with Exp_Util; use Exp_Util;
  36 with Itypes;   use Itypes;
  37 with Namet;    use Namet;
  38 with Nmake;    use Nmake;
  39 with Nlists;   use Nlists;
  40 with Restrict; use Restrict;
  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 Stand;    use Stand;
  50 with Stringt;  use Stringt;
  51 with Tbuild;   use Tbuild;
  52 with Uintp;    use Uintp;
  53 with Urealp;   use Urealp;
  54
  55 package body Exp_Intr is
  56
  57    -----------------------
  58    -- Local Subprograms --
  59    -----------------------
  60
  61    procedure Expand_Is_Negative (N : Node_Id);
  62    --  Expand a call to the intrinsic Is_Negative function
  63
  64    procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);
  65    --  Expand a call to Exception_Information/Message/Name. The first
  66    --  parameter, N, is the node for the function call, and Ent is the
  67    --  entity for the corresponding routine in the Ada.Exceptions package.
  68
  69    procedure Expand_Import_Call (N : Node_Id);
  70    --  Expand a call to Import_Address/Longest_Integer/Value. The parameter
  71    --  N is the node for the function call.
  72
  73    procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
  74    --  Expand an intrinsic shift operation, N and E are from the call to
  75    --  Expand_Instrinsic_Call (call node and subprogram spec entity) and
  76    --  K is the kind for the shift node
  77
  78    procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
  79    --  Expand a call to an instantiation of Unchecked_Convertion into a node
  80    --  N_Unchecked_Type_Conversion.
  81
  82    procedure Expand_Unc_Deallocation (N : Node_Id);
  83    --  Expand a call to an instantiation of Unchecked_Deallocation into a node
  84    --  N_Free_Statement and appropriate context.
  85
  86    procedure Expand_To_Address (N : Node_Id);
  87    procedure Expand_To_Pointer (N : Node_Id);
  88    --  Expand a call to corresponding function, declared in an instance of
  89    --  System.Addess_To_Access_Conversions.
  90
  91    procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
  92    --  Rewrite the node by the appropriate string or positive constant.
  93    --  Nam can be one of the following:
  94    --    Name_File             - expand string that is the name of source file
  95    --    Name_Line             - expand integer line number
  96    --    Name_Source_Location  - expand string of form file:line
  97    --    Name_Enclosing_Entity - expand string  with name of enclosing entity
  98
  99    ---------------------------
 100    -- Expand_Exception_Call --
 101    ---------------------------
 102
 103    --  If the function call is not within an exception handler, then the
 104    --  call is replaced by a null string. Otherwise the appropriate routine
 105    --  in Ada.Exceptions is called passing the choice parameter specification
 106    --  from the enclosing handler. If the enclosing handler lacks a choice
 107    --  parameter, then one is supplied.
 108
 109    procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is
 110       Loc : constant Source_Ptr := Sloc (N);
 111       P   : Node_Id;
 112       E   : Entity_Id;
 113       S   : String_Id;
 114
 115    begin
 116       --  Climb up parents to see if we are in exception handler
 117
 118       P := Parent (N);
 119       loop
 120          --  Case of not in exception handler
 121
 122          if No (P) then
 123             Start_String;
 124             S := End_String;
 125             Rewrite (N,
 126               Make_String_Literal (Loc,
 127                 Strval => S));
 128             exit;
 129
 130          --  Case of in exception handler
 131
 132          elsif Nkind (P) = N_Exception_Handler then
 133             if No (Choice_Parameter (P)) then
 134
 135                --  If no choice parameter present, then put one there. Note
 136                --  that we do not need to put it on the entity chain, since
 137                --  no one will be referencing it by normal visibility methods.
 138
 139                E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
 140                Set_Choice_Parameter (P, E);
 141                Set_Ekind (E, E_Variable);
 142                Set_Etype (E, RTE (RE_Exception_Occurrence));
 143                Set_Scope (E, Current_Scope);
 144             end if;
 145
 146             Rewrite (N,
 147               Make_Function_Call (Loc,
 148                 Name => New_Occurrence_Of (RTE (Ent), Loc),
 149                 Parameter_Associations => New_List (
 150                   New_Occurrence_Of (Choice_Parameter (P), Loc))));
 151             exit;
 152
 153          --  Keep climbing!
 154
 155          else
 156             P := Parent (P);
 157          end if;
 158       end loop;
 159
 160       Analyze_And_Resolve (N, Standard_String);
 161    end Expand_Exception_Call;
 162
 163    ------------------------
 164    -- Expand_Import_Call --
 165    ------------------------
 166
 167    --  The function call must have a static string as its argument. We create
 168    --  a dummy variable which uses this string as the external name in an
 169    --  Import pragma. The result is then obtained as the address of this
 170    --  dummy variable, converted to the appropriate target type.
 171
 172    procedure Expand_Import_Call (N : Node_Id) is
 173       Loc : constant Source_Ptr := Sloc (N);
 174       Ent : constant Entity_Id  := Entity (Name (N));
 175       Str : constant Node_Id    := First_Actual (N);
 176       Dum : Entity_Id;
 177
 178    begin
 179       Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
 180
 181       Insert_Actions (N, New_List (
 182         Make_Object_Declaration (Loc,
 183           Defining_Identifier => Dum,
 184           Object_Definition   =>
 185             New_Occurrence_Of (Standard_Character, Loc)),
 186
 187         Make_Pragma (Loc,
 188           Chars => Name_Import,
 189           Pragma_Argument_Associations => New_List (
 190             Make_Pragma_Argument_Association (Loc,
 191               Expression => Make_Identifier (Loc, Name_Ada)),
 192
 193             Make_Pragma_Argument_Association (Loc,
 194               Expression => Make_Identifier (Loc, Chars (Dum))),
 195
 196             Make_Pragma_Argument_Association (Loc,
 197               Chars => Name_Link_Name,
 198               Expression => Relocate_Node (Str))))));
 199
 200       Rewrite (N,
 201         Unchecked_Convert_To (Etype (Ent),
 202           Make_Attribute_Reference (Loc,
 203             Attribute_Name => Name_Address,
 204             Prefix => Make_Identifier (Loc, Chars (Dum)))));
 205
 206       Analyze_And_Resolve (N, Etype (Ent));
 207    end Expand_Import_Call;
 208
 209    ---------------------------
 210    -- Expand_Intrinsic_Call --
 211    ---------------------------
 212
 213    procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
 214       Nam : Name_Id;
 215
 216    begin
 217       --  If the intrinsic subprogram is generic, gets its original name.
 218
 219       if Present (Parent (E))
 220         and then Present (Generic_Parent (Parent (E)))
 221       then
 222          Nam := Chars (Generic_Parent (Parent (E)));
 223       else
 224          Nam := Chars (E);
 225       end if;
 226
 227       if Nam = Name_Asm then
 228          Expand_Asm_Call (N);
 229
 230       elsif Nam = Name_Divide then
 231          Expand_Decimal_Divide_Call (N);
 232
 233       elsif Nam = Name_Exception_Information then
 234          Expand_Exception_Call (N, RE_Exception_Information);
 235
 236       elsif Nam = Name_Exception_Message then
 237          Expand_Exception_Call (N, RE_Exception_Message);
 238
 239       elsif Nam = Name_Exception_Name then
 240          Expand_Exception_Call (N, RE_Exception_Name_Simple);
 241
 242       elsif Nam = Name_Import_Address
 243               or else
 244             Nam = Name_Import_Largest_Value
 245               or else
 246             Nam = Name_Import_Value
 247       then
 248          Expand_Import_Call (N);
 249
 250       elsif Nam = Name_Is_Negative then
 251          Expand_Is_Negative (N);
 252
 253       elsif Nam = Name_Rotate_Left then
 254          Expand_Shift (N, E, N_Op_Rotate_Left);
 255
 256       elsif Nam = Name_Rotate_Right then
 257          Expand_Shift (N, E, N_Op_Rotate_Right);
 258
 259       elsif Nam = Name_Shift_Left then
 260          Expand_Shift (N, E, N_Op_Shift_Left);
 261
 262       elsif Nam = Name_Shift_Right then
 263          Expand_Shift (N, E, N_Op_Shift_Right);
 264
 265       elsif Nam = Name_Shift_Right_Arithmetic then
 266          Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
 267
 268       elsif Nam = Name_Unchecked_Conversion then
 269          Expand_Unc_Conversion (N, E);
 270
 271       elsif Nam = Name_Unchecked_Deallocation then
 272          Expand_Unc_Deallocation (N);
 273
 274       elsif Nam = Name_To_Address then
 275          Expand_To_Address (N);
 276
 277       elsif Nam = Name_To_Pointer then
 278          Expand_To_Pointer (N);
 279
 280       elsif Nam = Name_File
 281         or else Nam = Name_Line
 282         or else Nam = Name_Source_Location
 283         or else Nam = Name_Enclosing_Entity
 284       then
 285          Expand_Source_Info (N, Nam);
 286
 287       else
 288          --  Only other possibility is a renaming, in which case we expand
 289          --  the call to the original operation (which must be intrinsic).
 290
 291          pragma Assert (Present (Alias (E)));
 292          Expand_Intrinsic_Call (N,  Alias (E));
 293       end if;
 294    end Expand_Intrinsic_Call;
 295
 296    ------------------------
 297    -- Expand_Is_Negative --
 298    ------------------------
 299
 300    procedure Expand_Is_Negative (N : Node_Id) is
 301       Loc   : constant Source_Ptr := Sloc (N);
 302       Opnd  : constant Node_Id    := Relocate_Node (First_Actual (N));
 303
 304    begin
 305
 306       --  We replace the function call by the following expression
 307
 308       --    if Opnd < 0.0 then
 309       --       True
 310       --    else
 311       --       if Opnd > 0.0 then
 312       --          False;
 313       --       else
 314       --          Float_Unsigned!(Float (Opnd)) /= 0
 315       --       end if;
 316       --    end if;
 317
 318       Rewrite (N,
 319         Make_Conditional_Expression (Loc,
 320           Expressions => New_List (
 321             Make_Op_Lt (Loc,
 322               Left_Opnd  => Duplicate_Subexpr (Opnd),
 323               Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
 324
 325             New_Occurrence_Of (Standard_True, Loc),
 326
 327             Make_Conditional_Expression (Loc,
 328              Expressions => New_List (
 329                Make_Op_Gt (Loc,
 330                  Left_Opnd  => Duplicate_Subexpr_No_Checks (Opnd),
 331                  Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
 332
 333                New_Occurrence_Of (Standard_False, Loc),
 334
 335                 Make_Op_Ne (Loc,
 336                   Left_Opnd =>
 337                     Unchecked_Convert_To
 338                       (RTE (RE_Float_Unsigned),
 339                        Convert_To
 340                          (Standard_Float,
 341                           Duplicate_Subexpr_No_Checks (Opnd))),
 342                   Right_Opnd =>
 343                     Make_Integer_Literal (Loc, 0)))))));
 344
 345       Analyze_And_Resolve (N, Standard_Boolean);
 346    end Expand_Is_Negative;
 347
 348    ------------------
 349    -- Expand_Shift --
 350    ------------------
 351
 352    --  This procedure is used to convert a call to a shift function to the
 353    --  corresponding operator node. This conversion is not done by the usual
 354    --  circuit for converting calls to operator functions (e.g. "+"(1,2)) to
 355    --  operator nodes, because shifts are not predefined operators.
 356
 357    --  As a result, whenever a shift is used in the source program, it will
 358    --  remain as a call until converted by this routine to the operator node
 359    --  form which Gigi is expecting to see.
 360
 361    --  Note: it is possible for the expander to generate shift operator nodes
 362    --  directly, which will be analyzed in the normal manner by calling Analyze
 363    --  and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
 364
 365    procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
 366       Loc   : constant Source_Ptr := Sloc (N);
 367       Typ   : constant Entity_Id  := Etype (N);
 368       Left  : constant Node_Id    := First_Actual (N);
 369       Right : constant Node_Id    := Next_Actual (Left);
 370       Ltyp  : constant Node_Id    := Etype (Left);
 371       Rtyp  : constant Node_Id    := Etype (Right);
 372       Snode : Node_Id;
 373
 374    begin
 375       Snode := New_Node (K, Loc);
 376       Set_Left_Opnd  (Snode, Relocate_Node (Left));
 377       Set_Right_Opnd (Snode, Relocate_Node (Right));
 378       Set_Chars      (Snode, Chars (E));
 379       Set_Etype      (Snode, Base_Type (Typ));
 380       Set_Entity     (Snode, E);
 381
 382       if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
 383         and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)
 384       then
 385          Set_Shift_Count_OK (Snode, True);
 386       end if;
 387
 388       --  Do the rewrite. Note that we don't call Analyze and Resolve on
 389       --  this node, because it already got analyzed and resolved when
 390       --  it was a function call!
 391
 392       Rewrite (N, Snode);
 393       Set_Analyzed (N);
 394    end Expand_Shift;
 395
 396    ------------------------
 397    -- Expand_Source_Info --
 398    ------------------------
 399
 400    procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
 401       Loc : constant Source_Ptr := Sloc (N);
 402       Ent : Entity_Id;
 403
 404    begin
 405       --  Integer cases
 406
 407       if Nam = Name_Line then
 408          Rewrite (N,
 409            Make_Integer_Literal (Loc,
 410              Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));
 411          Analyze_And_Resolve (N, Standard_Positive);
 412
 413       --  String cases
 414
 415       else
 416          case Nam is
 417             when Name_File =>
 418                Get_Decoded_Name_String
 419                  (Reference_Name (Get_Source_File_Index (Loc)));
 420
 421             when Name_Source_Location =>
 422                Build_Location_String (Loc);
 423
 424             when Name_Enclosing_Entity =>
 425                Name_Len := 0;
 426
 427                Ent := Current_Scope;
 428
 429                --  Skip enclosing blocks to reach enclosing unit.
 430
 431                while Present (Ent) loop
 432                   exit when Ekind (Ent) /= E_Block
 433                     and then Ekind (Ent) /= E_Loop;
 434                   Ent := Scope (Ent);
 435                end loop;
 436
 437                --  Ent now points to the relevant defining entity
 438
 439                declare
 440                   SDef : Source_Ptr := Sloc (Ent);
 441                   TDef : Source_Buffer_Ptr;
 442
 443                begin
 444                   TDef := Source_Text (Get_Source_File_Index (SDef));
 445                   Name_Len := 0;
 446
 447                   while TDef (SDef) in '0' .. '9'
 448                     or else TDef (SDef) >= 'A'
 449                     or else TDef (SDef) = ASCII.ESC
 450                   loop
 451                      Add_Char_To_Name_Buffer (TDef (SDef));
 452                      SDef := SDef + 1;
 453                   end loop;
 454                end;
 455
 456             when others =>
 457                raise Program_Error;
 458          end case;
 459
 460          Rewrite (N,
 461            Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
 462          Analyze_And_Resolve (N, Standard_String);
 463       end if;
 464
 465       Set_Is_Static_Expression (N);
 466    end Expand_Source_Info;
 467
 468    ---------------------------
 469    -- Expand_Unc_Conversion --
 470    ---------------------------
 471
 472    procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
 473       Func : constant Entity_Id  := Entity (Name (N));
 474       Conv : Node_Id;
 475       Ftyp : Entity_Id;
 476
 477    begin
 478       --  Rewrite as unchecked conversion node. Note that we must convert
 479       --  the operand to the formal type of the input parameter of the
 480       --  function, so that the resulting N_Unchecked_Type_Conversion
 481       --  call indicates the correct types for Gigi.
 482
 483       --  Right now, we only do this if a scalar type is involved. It is
 484       --  not clear if it is needed in other cases. If we do attempt to
 485       --  do the conversion unconditionally, it crashes 3411-018. To be
 486       --  investigated further ???
 487
 488       Conv := Relocate_Node (First_Actual (N));
 489       Ftyp := Etype (First_Formal (Func));
 490
 491       if Is_Scalar_Type (Ftyp) then
 492          Conv := Convert_To (Ftyp, Conv);
 493          Set_Parent (Conv, N);
 494          Analyze_And_Resolve (Conv);
 495       end if;
 496
 497       --  We do the analysis here, because we do not want the compiler
 498       --  to try to optimize or otherwise reorganize the unchecked
 499       --  conversion node.
 500
 501       Rewrite (N, Unchecked_Convert_To (Etype (E), Conv));
 502       Set_Etype (N, Etype (E));
 503       Set_Analyzed (N);
 504
 505       if Nkind (N) = N_Unchecked_Type_Conversion then
 506          Expand_N_Unchecked_Type_Conversion (N);
 507       end if;
 508    end Expand_Unc_Conversion;
 509
 510    -----------------------------
 511    -- Expand_Unc_Deallocation --
 512    -----------------------------
 513
 514    --  Generate the following Code :
 515
 516    --    if Arg /= null then
 517    --     <Finalize_Call> (.., T'Class(Arg.all), ..);  -- for controlled types
 518    --       Free (Arg);
 519    --       Arg := Null;
 520    --    end if;
 521
 522    --  For a task, we also generate a call to Free_Task to ensure that the
 523    --  task itself is freed if it is terminated, ditto for a simple protected
 524    --  object, with a call to Finalize_Protection. For composite types that
 525    --  have tasks or simple protected objects as components, we traverse the
 526    --  structures to find and terminate those components.
 527
 528    procedure Expand_Unc_Deallocation (N : Node_Id) is
 529       Loc   : constant Source_Ptr := Sloc (N);
 530       Arg   : constant Node_Id    := First_Actual (N);
 531       Typ   : constant Entity_Id  := Etype (Arg);
 532       Stmts : constant List_Id    := New_List;
 533       Rtyp  : constant Entity_Id  := Underlying_Type (Root_Type (Typ));
 534       Pool  : constant Entity_Id  := Associated_Storage_Pool (Rtyp);
 535
 536       Desig_T   : constant Entity_Id  := Designated_Type (Typ);
 537       Gen_Code  : Node_Id;
 538       Free_Node : Node_Id;
 539       Deref     : Node_Id;
 540       Free_Arg  : Node_Id;
 541       Free_Cod  : List_Id;
 542       Blk       : Node_Id;
 543
 544    begin
 545       if No_Pool_Assigned (Rtyp) then
 546          Error_Msg_N ("?deallocation from empty storage pool", N);
 547       end if;
 548
 549       if Controlled_Type (Desig_T) then
 550          Deref :=
 551            Make_Explicit_Dereference (Loc,
 552              Prefix => Duplicate_Subexpr_No_Checks (Arg));
 553
 554          --  If the type is tagged, then we must force dispatching on the
 555          --  finalization call because the designated type may not be the
 556          --  actual type of the object
 557
 558          if Is_Tagged_Type (Desig_T)
 559            and then not Is_Class_Wide_Type (Desig_T)
 560          then
 561             Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref);
 562          end if;
 563
 564          Free_Cod :=
 565            Make_Final_Call
 566             (Ref         => Deref,
 567              Typ         => Desig_T,
 568              With_Detach => New_Reference_To (Standard_True, Loc));
 569
 570          if Abort_Allowed then
 571             Prepend_To (Free_Cod,
 572               Build_Runtime_Call (Loc, RE_Abort_Defer));
 573
 574             Blk :=
 575               Make_Block_Statement (Loc, Handled_Statement_Sequence =>
 576                 Make_Handled_Sequence_Of_Statements (Loc,
 577                   Statements  => Free_Cod,
 578                   At_End_Proc =>
 579                     New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)));
 580
 581             --  We now expand the exception (at end) handler. We set a
 582             --  temporary parent pointer since we have not attached Blk
 583             --  to the tree yet.
 584
 585             Set_Parent (Blk, N);
 586             Analyze (Blk);
 587             Expand_At_End_Handler
 588               (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
 589             Append (Blk, Stmts);
 590
 591          else
 592             Append_List_To (Stmts, Free_Cod);
 593          end if;
 594       end if;
 595
 596       --  For a task type, call Free_Task before freeing the ATCB
 597
 598       if Is_Task_Type (Desig_T) then
 599          declare
 600             Stat : Node_Id := Prev (N);
 601             Nam1 : Node_Id;
 602             Nam2 : Node_Id;
 603
 604          begin
 605             --  An Abort followed by a Free will not do what the user
 606             --  expects, because the abort is not immediate. This is
 607             --  worth a friendly warning.
 608
 609             while Present (Stat)
 610               and then not Comes_From_Source (Original_Node (Stat))
 611             loop
 612                Prev (Stat);
 613             end loop;
 614
 615             if Present (Stat)
 616               and then Nkind (Original_Node (Stat)) = N_Abort_Statement
 617             then
 618                Stat := Original_Node (Stat);
 619                Nam1 := First (Names (Stat));
 620                Nam2 := Original_Node (First (Parameter_Associations (N)));
 621
 622                if Nkind (Nam1) = N_Explicit_Dereference
 623                  and then Is_Entity_Name (Prefix (Nam1))
 624                  and then Is_Entity_Name (Nam2)
 625                  and then Entity (Prefix (Nam1)) = Entity (Nam2)
 626                then
 627                   Error_Msg_N ("Abort may take time to complete?", N);
 628                   Error_Msg_N ("\deallocation might have no effect?", N);
 629                   Error_Msg_N ("\safer to wait for termination.?", N);
 630                end if;
 631             end if;
 632          end;
 633
 634          Append_To
 635            (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
 636
 637       --  For composite types that contain tasks, recurse over the structure
 638       --  to build the selectors for the task subcomponents.
 639
 640       elsif Has_Task (Desig_T) then
 641          if Is_Record_Type (Desig_T) then
 642             Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
 643
 644          elsif Is_Array_Type (Desig_T) then
 645             Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
 646          end if;
 647       end if;
 648
 649       --  Same for simple protected types. Eventually call Finalize_Protection
 650       --  before freeing the PO for each protected component.
 651
 652       if Is_Simple_Protected_Type (Desig_T) then
 653          Append_To (Stmts,
 654            Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg)));
 655
 656       elsif Has_Simple_Protected_Object (Desig_T) then
 657          if Is_Record_Type (Desig_T) then
 658             Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
 659          elsif Is_Array_Type (Desig_T) then
 660             Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
 661          end if;
 662       end if;
 663
 664       --  Normal processing for non-controlled types
 665
 666       Free_Arg := Duplicate_Subexpr_No_Checks (Arg);
 667       Free_Node := Make_Free_Statement (Loc, Empty);
 668       Append_To (Stmts, Free_Node);
 669       Set_Storage_Pool (Free_Node, Pool);
 670
 671       --  Make implicit if statement. We omit this if we are the then part
 672       --  of a test of the form:
 673
 674       --    if not (Arg = null) then
 675
 676       --  i.e. if the test is explicit in the source. Arg must be a simple
 677       --  identifier for the purposes of this special test. Note that the
 678       --  use of /= in the source is always transformed into the above form.
 679
 680       declare
 681          Test_Needed : Boolean := True;
 682          P           : constant Node_Id := Parent (N);
 683          C           : Node_Id;
 684
 685       begin
 686          if Nkind (Arg) = N_Identifier
 687            and then Nkind (P) =  N_If_Statement
 688            and then First (Then_Statements (P)) = N
 689          then
 690             if Nkind (Condition (P)) = N_Op_Not then
 691                C := Right_Opnd (Condition (P));
 692
 693                if Nkind (C) = N_Op_Eq
 694                  and then Nkind (Left_Opnd (C)) = N_Identifier
 695                  and then Chars (Arg) = Chars (Left_Opnd (C))
 696                  and then Nkind (Right_Opnd (C)) = N_Null
 697                then
 698                   Test_Needed := False;
 699                end if;
 700             end if;
 701          end if;
 702
 703          --  Generate If_Statement if needed
 704
 705          if Test_Needed then
 706             Gen_Code :=
 707               Make_Implicit_If_Statement (N,
 708                 Condition =>
 709                   Make_Op_Ne (Loc,
 710                     Left_Opnd  => Duplicate_Subexpr (Arg),
 711                     Right_Opnd => Make_Null (Loc)),
 712                 Then_Statements => Stmts);
 713
 714          else
 715             Gen_Code :=
 716               Make_Block_Statement (Loc,
 717                 Handled_Statement_Sequence =>
 718                   Make_Handled_Sequence_Of_Statements (Loc,
 719                     Statements => Stmts));
 720          end if;
 721       end;
 722
 723       --  Deal with storage pool
 724
 725       if Present (Pool) then
 726
 727          --  Freeing the secondary stack is meaningless
 728
 729          if Is_RTE (Pool, RE_SS_Pool) then
 730             null;
 731
 732          elsif Is_Class_Wide_Type (Etype (Pool)) then
 733             Set_Procedure_To_Call (Free_Node,
 734               RTE (RE_Deallocate_Any));
 735          else
 736             Set_Procedure_To_Call (Free_Node,
 737               Find_Prim_Op (Etype (Pool), Name_Deallocate));
 738
 739             --  If the type is class wide, we generate an implicit type
 740             --  with the right dynamic size, so that the deallocate call
 741             --  gets the right size parameter computed by gigi
 742
 743             if Is_Class_Wide_Type (Desig_T) then
 744                declare
 745                   Acc_Type : constant Entity_Id :=
 746                                Create_Itype (E_Access_Type, N);
 747                   Deref    : constant Node_Id :=
 748                                Make_Explicit_Dereference (Loc,
 749                                  Duplicate_Subexpr_No_Checks (Arg));
 750
 751                begin
 752                   Set_Etype  (Deref, Typ);
 753                   Set_Parent (Deref, Free_Node);
 754
 755                   Set_Etype     (Acc_Type, Acc_Type);
 756                   Set_Size_Info (Acc_Type, Typ);
 757                   Set_Directly_Designated_Type
 758                                 (Acc_Type, Entity (Make_Subtype_From_Expr
 759                                                     (Deref, Desig_T)));
 760
 761                   Free_Arg := Unchecked_Convert_To (Acc_Type, Free_Arg);
 762                end;
 763             end if;
 764          end if;
 765       end if;
 766
 767       Set_Expression (Free_Node, Free_Arg);
 768
 769       declare
 770          Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg);
 771
 772       begin
 773          Set_Assignment_OK (Lhs);
 774          Append_To (Stmts,
 775            Make_Assignment_Statement (Loc,
 776              Name       => Lhs,
 777              Expression => Make_Null (Loc)));
 778       end;
 779
 780       Rewrite (N, Gen_Code);
 781       Analyze (N);
 782    end Expand_Unc_Deallocation;
 783
 784    -----------------------
 785    -- Expand_To_Address --
 786    -----------------------
 787
 788    procedure Expand_To_Address (N : Node_Id) is
 789       Loc : constant Source_Ptr := Sloc (N);
 790       Arg : constant Node_Id := First_Actual (N);
 791       Obj : Node_Id;
 792
 793    begin
 794       Remove_Side_Effects (Arg);
 795
 796       Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
 797
 798       Rewrite (N,
 799         Make_Conditional_Expression (Loc,
 800           Expressions => New_List (
 801             Make_Op_Eq (Loc,
 802               Left_Opnd => New_Copy_Tree (Arg),
 803               Right_Opnd => Make_Null (Loc)),
 804             New_Occurrence_Of (RTE (RE_Null_Address), Loc),
 805             Make_Attribute_Reference (Loc,
 806               Attribute_Name => Name_Address,
 807               Prefix => Obj))));
 808
 809       Analyze_And_Resolve (N, RTE (RE_Address));
 810    end Expand_To_Address;
 811
 812    -----------------------
 813    -- Expand_To_Pointer --
 814    -----------------------
 815
 816    procedure Expand_To_Pointer (N : Node_Id) is
 817       Arg : constant Node_Id := First_Actual (N);
 818
 819    begin
 820       Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
 821       Analyze (N);
 822    end Expand_To_Pointer;
 823
 824 end Exp_Intr;