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-2016, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Expander; use Expander;
  32 with Exp_Atag; use Exp_Atag;
  33 with Exp_Ch4;  use Exp_Ch4;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Ch11; use Exp_Ch11;
  36 with Exp_Code; use Exp_Code;
  37 with Exp_Fixd; use Exp_Fixd;
  38 with Exp_Util; use Exp_Util;
  39 with Freeze;   use Freeze;
  40 with Inline;   use Inline;
  41 with Nmake;    use Nmake;
  42 with Nlists;   use Nlists;
  43 with Opt;      use Opt;
  44 with Restrict; use Restrict;
  45 with Rident;   use Rident;
  46 with Rtsfind;  use Rtsfind;
  47 with Sem;      use Sem;
  48 with Sem_Aux;  use Sem_Aux;
  49 with Sem_Eval; use Sem_Eval;
  50 with Sem_Res;  use Sem_Res;
  51 with Sem_Type; use Sem_Type;
  52 with Sem_Util; use Sem_Util;
  53 with Sinfo;    use Sinfo;
  54 with Sinput;   use Sinput;
  55 with Snames;   use Snames;
  56 with Stand;    use Stand;
  57 with Tbuild;   use Tbuild;
  58 with Uintp;    use Uintp;
  59 with Urealp;   use Urealp;
  60
  61 package body Exp_Intr is
  62
  63    -----------------------
  64    -- Local Subprograms --
  65    -----------------------
  66
  67    procedure Expand_Binary_Operator_Call (N : Node_Id);
  68    --  Expand a call to an intrinsic arithmetic operator when the operand
  69    --  types or sizes are not identical.
  70
  71    procedure Expand_Is_Negative (N : Node_Id);
  72    --  Expand a call to the intrinsic Is_Negative function
  73
  74    procedure Expand_Dispatching_Constructor_Call (N : Node_Id);
  75    --  Expand a call to an instantiation of Generic_Dispatching_Constructor
  76    --  into a dispatching call to the actual subprogram associated with the
  77    --  Constructor formal subprogram, passing it the Parameters actual of
  78    --  the call to the instantiation and dispatching based on call's Tag
  79    --  parameter.
  80
  81    procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);
  82    --  Expand a call to Exception_Information/Message/Name. The first
  83    --  parameter, N, is the node for the function call, and Ent is the
  84    --  entity for the corresponding routine in the Ada.Exceptions package.
  85
  86    procedure Expand_Import_Call (N : Node_Id);
  87    --  Expand a call to Import_Address/Longest_Integer/Value. The parameter
  88    --  N is the node for the function call.
  89
  90    procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
  91    --  Expand an intrinsic shift operation, N and E are from the call to
  92    --  Expand_Intrinsic_Call (call node and subprogram spec entity) and
  93    --  K is the kind for the shift node
  94
  95    procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
  96    --  Expand a call to an instantiation of Unchecked_Conversion into a node
  97    --  N_Unchecked_Type_Conversion.
  98
  99    procedure Expand_Unc_Deallocation (N : Node_Id);
 100    --  Expand a call to an instantiation of Unchecked_Deallocation into a node
 101    --  N_Free_Statement and appropriate context.
 102
 103    procedure Expand_To_Address (N : Node_Id);
 104    procedure Expand_To_Pointer (N : Node_Id);
 105    --  Expand a call to corresponding function, declared in an instance of
 106    --  System.Address_To_Access_Conversions.
 107
 108    procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
 109    --  Rewrite the node as the appropriate string literal or positive
 110    --  constant. Nam is the name of one of the intrinsics declared in
 111    --  GNAT.Source_Info; see g-souinf.ads for documentation of these
 112    --  intrinsics.
 113
 114    procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id);
 115    --  Recursive procedure to construct string for qualified name of enclosing
 116    --  program unit. The qualification stops at an enclosing scope has no
 117    --  source name (block or loop). If entity is a subprogram instance, skip
 118    --  enclosing wrapper package. The name is appended to Buf.
 119
 120    ---------------------
 121    -- Add_Source_Info --
 122    ---------------------
 123
 124    procedure Add_Source_Info
 125      (Buf : in out Bounded_String;
 126       Loc : Source_Ptr;
 127       Nam : Name_Id)
 128    is
 129    begin
 130       case Nam is
 131          when Name_Line =>
 132             Append (Buf, Nat (Get_Logical_Line_Number (Loc)));
 133
 134          when Name_File =>
 135             Append_Decoded (Buf, Reference_Name (Get_Source_File_Index (Loc)));
 136
 137          when Name_Source_Location =>
 138             Build_Location_String (Buf, Loc);
 139
 140          when Name_Enclosing_Entity =>
 141
 142             --  Skip enclosing blocks to reach enclosing unit
 143
 144             declare
 145                Ent : Entity_Id := Current_Scope;
 146             begin
 147                while Present (Ent) loop
 148                   exit when not Ekind_In (Ent, E_Block, E_Loop);
 149                   Ent := Scope (Ent);
 150                end loop;
 151
 152                --  Ent now points to the relevant defining entity
 153
 154                Append_Entity_Name (Buf, Ent);
 155             end;
 156
 157          when Name_Compilation_ISO_Date =>
 158             Append (Buf, Opt.Compilation_Time (1 .. 10));
 159
 160          when Name_Compilation_Date =>
 161             declare
 162                subtype S13 is String (1 .. 3);
 163                Months : constant array (1 .. 12) of S13 :=
 164                           ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
 165                            "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
 166
 167                M1 : constant Character := Opt.Compilation_Time (6);
 168                M2 : constant Character := Opt.Compilation_Time (7);
 169
 170                MM : constant Natural range 1 .. 12 :=
 171                       (Character'Pos (M1) - Character'Pos ('0')) * 10 +
 172                       (Character'Pos (M2) - Character'Pos ('0'));
 173
 174             begin
 175                --  Reformat ISO date into MMM DD YYYY (__DATE__) format
 176
 177                Append (Buf, Months (MM));
 178                Append (Buf, ' ');
 179                Append (Buf, Opt.Compilation_Time (9 .. 10));
 180                Append (Buf, ' ');
 181                Append (Buf, Opt.Compilation_Time (1 .. 4));
 182             end;
 183
 184          when Name_Compilation_Time =>
 185             Append (Buf, Opt.Compilation_Time (12 .. 19));
 186
 187          when others =>
 188             raise Program_Error;
 189       end case;
 190    end Add_Source_Info;
 191
 192    -----------------------
 193    -- Append_Entity_Name --
 194    -----------------------
 195
 196    procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
 197       Temp : Bounded_String;
 198
 199       procedure Inner (E : Entity_Id);
 200       --  Inner recursive routine, keep outer routine nonrecursive to ease
 201       --  debugging when we get strange results from this routine.
 202
 203       -----------
 204       -- Inner --
 205       -----------
 206
 207       procedure Inner (E : Entity_Id) is
 208       begin
 209          --  If entity has an internal name, skip by it, and print its scope.
 210          --  Note that we strip a final R from the name before the test; this
 211          --  is needed for some cases of instantiations.
 212
 213          declare
 214             E_Name : Bounded_String;
 215
 216          begin
 217             Append (E_Name, Chars (E));
 218
 219             if E_Name.Chars (E_Name.Length) = 'R' then
 220                E_Name.Length := E_Name.Length - 1;
 221             end if;
 222
 223             if Is_Internal_Name (E_Name) then
 224                Inner (Scope (E));
 225                return;
 226             end if;
 227          end;
 228
 229          --  Just print entity name if its scope is at the outer level
 230
 231          if Scope (E) = Standard_Standard then
 232             null;
 233
 234          --  If scope comes from source, write scope and entity
 235
 236          elsif Comes_From_Source (Scope (E)) then
 237             Append_Entity_Name (Temp, Scope (E));
 238             Append (Temp, '.');
 239
 240          --  If in wrapper package skip past it
 241
 242          elsif Is_Wrapper_Package (Scope (E)) then
 243             Append_Entity_Name (Temp, Scope (Scope (E)));
 244             Append (Temp, '.');
 245
 246          --  Otherwise nothing to output (happens in unnamed block statements)
 247
 248          else
 249             null;
 250          end if;
 251
 252          --  Output the name
 253
 254          declare
 255             E_Name : Bounded_String;
 256
 257          begin
 258             Append_Unqualified_Decoded (E_Name, Chars (E));
 259
 260             --  Remove trailing upper-case letters from the name (useful for
 261             --  dealing with some cases of internal names generated in the case
 262             --  of references from within a generic).
 263
 264             while E_Name.Length > 1
 265               and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
 266             loop
 267                E_Name.Length := E_Name.Length - 1;
 268             end loop;
 269
 270             --  Adjust casing appropriately (gets name from source if possible)
 271
 272             Adjust_Name_Case (E_Name, Sloc (E));
 273             Append (Temp, E_Name);
 274          end;
 275       end Inner;
 276
 277    --  Start of processing for Append_Entity_Name
 278
 279    begin
 280       Inner (E);
 281       Append (Buf, Temp);
 282    end Append_Entity_Name;
 283
 284    ---------------------------------
 285    -- Expand_Binary_Operator_Call --
 286    ---------------------------------
 287
 288    procedure Expand_Binary_Operator_Call (N : Node_Id) is
 289       T1  : constant Entity_Id := Underlying_Type (Etype (Left_Opnd  (N)));
 290       T2  : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N)));
 291       TR  : constant Entity_Id := Etype (N);
 292       T3  : Entity_Id;
 293       Res : Node_Id;
 294
 295       Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2));
 296       --  Maximum of operand sizes
 297
 298    begin
 299       --  Nothing to do if the operands have the same modular type
 300
 301       if Base_Type (T1) = Base_Type (T2)
 302         and then Is_Modular_Integer_Type (T1)
 303       then
 304          return;
 305       end if;
 306
 307       --  Use Unsigned_32 for sizes of 32 or below, else Unsigned_64
 308
 309       if Siz > 32 then
 310          T3 := RTE (RE_Unsigned_64);
 311       else
 312          T3 := RTE (RE_Unsigned_32);
 313       end if;
 314
 315       --  Copy operator node, and reset type and entity fields, for
 316       --  subsequent reanalysis.
 317
 318       Res := New_Copy (N);
 319       Set_Etype (Res, T3);
 320
 321       case Nkind (N) is
 322          when N_Op_And => Set_Entity (Res, Standard_Op_And);
 323          when N_Op_Or  => Set_Entity (Res, Standard_Op_Or);
 324          when N_Op_Xor => Set_Entity (Res, Standard_Op_Xor);
 325          when others   => raise Program_Error;
 326       end case;
 327
 328       --  Convert operands to large enough intermediate type
 329
 330       Set_Left_Opnd (Res,
 331         Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N))));
 332       Set_Right_Opnd (Res,
 333         Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N))));
 334
 335       --  Analyze and resolve result formed by conversion to target type
 336
 337       Rewrite (N, Unchecked_Convert_To (TR, Res));
 338       Analyze_And_Resolve (N, TR);
 339    end Expand_Binary_Operator_Call;
 340
 341    -----------------------------------------
 342    -- Expand_Dispatching_Constructor_Call --
 343    -----------------------------------------
 344
 345    --  Transform a call to an instantiation of Generic_Dispatching_Constructor
 346    --  of the form:
 347
 348    --     GDC_Instance (The_Tag, Parameters'Access)
 349
 350    --  to a class-wide conversion of a dispatching call to the actual
 351    --  associated with the formal subprogram Construct, designating The_Tag
 352    --  as the controlling tag of the call:
 353
 354    --     T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag
 355
 356    --  which will eventually be expanded to the following:
 357
 358    --     T'Class (The_Tag.all (Construct'Actual'Index).all (Params))
 359
 360    --  A class-wide membership test is also generated, preceding the call, to
 361    --  ensure that the controlling tag denotes a type in T'Class.
 362
 363    procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is
 364       Loc        : constant Source_Ptr := Sloc (N);
 365       Tag_Arg    : constant Node_Id    := First_Actual (N);
 366       Param_Arg  : constant Node_Id    := Next_Actual (Tag_Arg);
 367       Subp_Decl  : constant Node_Id    := Parent (Parent (Entity (Name (N))));
 368       Inst_Pkg   : constant Node_Id    := Parent (Subp_Decl);
 369       Act_Rename : Node_Id;
 370       Act_Constr : Entity_Id;
 371       Iface_Tag  : Node_Id := Empty;
 372       Cnstr_Call : Node_Id;
 373       Result_Typ : Entity_Id;
 374
 375    begin
 376       --  Remove side effects from tag argument early, before rewriting
 377       --  the dispatching constructor call, as Remove_Side_Effects relies
 378       --  on Tag_Arg's Parent link properly attached to the tree (once the
 379       --  call is rewritten, the Parent is inconsistent as it points to the
 380       --  rewritten node, which is not the syntactic parent of the Tag_Arg
 381       --  anymore).
 382
 383       Remove_Side_Effects (Tag_Arg);
 384
 385       --  Check that we have a proper tag
 386
 387       Insert_Action (N,
 388         Make_Implicit_If_Statement (N,
 389           Condition       => Make_Op_Eq (Loc,
 390             Left_Opnd  => New_Copy_Tree (Tag_Arg),
 391             Right_Opnd => New_Occurrence_Of (RTE (RE_No_Tag), Loc)),
 392
 393           Then_Statements => New_List (
 394             Make_Raise_Statement (Loc,
 395               New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
 396
 397       --  Check that it is not the tag of an abstract type
 398
 399       Insert_Action (N,
 400         Make_Implicit_If_Statement (N,
 401           Condition       => Make_Function_Call (Loc,
 402              Name                   =>
 403                New_Occurrence_Of (RTE (RE_Type_Is_Abstract), Loc),
 404              Parameter_Associations => New_List (New_Copy_Tree (Tag_Arg))),
 405
 406           Then_Statements => New_List (
 407             Make_Raise_Statement (Loc,
 408               New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
 409
 410       --  The subprogram is the third actual in the instantiation, and is
 411       --  retrieved from the corresponding renaming declaration. However,
 412       --  freeze nodes may appear before, so we retrieve the declaration
 413       --  with an explicit loop.
 414
 415       Act_Rename := First (Visible_Declarations (Inst_Pkg));
 416       while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop
 417          Next (Act_Rename);
 418       end loop;
 419
 420       Act_Constr := Entity (Name (Act_Rename));
 421       Result_Typ := Class_Wide_Type (Etype (Act_Constr));
 422
 423       --  Check that the accessibility level of the tag is no deeper than that
 424       --  of the constructor function.
 425
 426       Insert_Action (N,
 427         Make_Implicit_If_Statement (N,
 428           Condition       =>
 429             Make_Op_Gt (Loc,
 430               Left_Opnd  =>
 431                 Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)),
 432               Right_Opnd =>
 433                 Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))),
 434
 435           Then_Statements => New_List (
 436             Make_Raise_Statement (Loc,
 437               New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
 438
 439       if Is_Interface (Etype (Act_Constr)) then
 440
 441          --  If the result type is not known to be a parent of Tag_Arg then we
 442          --  need to locate the tag of the secondary dispatch table.
 443
 444          if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
 445                              Use_Full_View => True)
 446            and then Tagged_Type_Expansion
 447          then
 448             --  Obtain the reference to the Ada.Tags service before generating
 449             --  the Object_Declaration node to ensure that if this service is
 450             --  not available in the runtime then we generate a clear error.
 451
 452             declare
 453                Fname : constant Node_Id :=
 454                          New_Occurrence_Of (RTE (RE_Secondary_Tag), Loc);
 455
 456             begin
 457                pragma Assert (not Is_Interface (Etype (Tag_Arg)));
 458
 459                --  The tag is the first entry in the dispatch table of the
 460                --  return type of the constructor.
 461
 462                Iface_Tag :=
 463                  Make_Object_Declaration (Loc,
 464                    Defining_Identifier => Make_Temporary (Loc, 'V'),
 465                    Object_Definition   =>
 466                      New_Occurrence_Of (RTE (RE_Tag), Loc),
 467                    Expression          =>
 468                      Make_Function_Call (Loc,
 469                        Name                   => Fname,
 470                        Parameter_Associations => New_List (
 471                          Relocate_Node (Tag_Arg),
 472                          New_Occurrence_Of
 473                            (Node (First_Elmt
 474                                     (Access_Disp_Table (Etype (Act_Constr)))),
 475                             Loc))));
 476                Insert_Action (N, Iface_Tag);
 477             end;
 478          end if;
 479       end if;
 480
 481       --  Create the call to the actual Constructor function
 482
 483       Cnstr_Call :=
 484         Make_Function_Call (Loc,
 485           Name                   => New_Occurrence_Of (Act_Constr, Loc),
 486           Parameter_Associations => New_List (Relocate_Node (Param_Arg)));
 487
 488       --  Establish its controlling tag from the tag passed to the instance
 489       --  The tag may be given by a function call, in which case a temporary
 490       --  should be generated now, to prevent out-of-order insertions during
 491       --  the expansion of that call when stack-checking is enabled.
 492
 493       if Present (Iface_Tag) then
 494          Set_Controlling_Argument (Cnstr_Call,
 495            New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc));
 496       else
 497          Set_Controlling_Argument (Cnstr_Call,
 498            Relocate_Node (Tag_Arg));
 499       end if;
 500
 501       --  Rewrite and analyze the call to the instance as a class-wide
 502       --  conversion of the call to the actual constructor.
 503
 504       Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
 505
 506       --  Do not generate a run-time check on the built object if tag
 507       --  checks are suppressed for the result type or tagged type expansion
 508       --  is disabled.
 509
 510       if Tag_Checks_Suppressed (Etype (Result_Typ))
 511         or else not Tagged_Type_Expansion
 512       then
 513          null;
 514
 515       --  Generate a class-wide membership test to ensure that the call's tag
 516       --  argument denotes a type within the class. We must keep separate the
 517       --  case in which the Result_Type of the constructor function is a tagged
 518       --  type from the case in which it is an abstract interface because the
 519       --  run-time subprogram required to check these cases differ (and have
 520       --  one difference in their parameters profile).
 521
 522       --  Call CW_Membership if the Result_Type is a tagged type to look for
 523       --  the tag in the table of ancestor tags.
 524
 525       elsif not Is_Interface (Result_Typ) then
 526          declare
 527             Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg);
 528             CW_Test_Node : Node_Id;
 529
 530          begin
 531             Build_CW_Membership (Loc,
 532               Obj_Tag_Node => Obj_Tag_Node,
 533               Typ_Tag_Node =>
 534                 New_Occurrence_Of (
 535                    Node (First_Elmt (Access_Disp_Table (
 536                                        Root_Type (Result_Typ)))), Loc),
 537               Related_Nod => N,
 538               New_Node    => CW_Test_Node);
 539
 540             Insert_Action (N,
 541               Make_Implicit_If_Statement (N,
 542                 Condition =>
 543                   Make_Op_Not (Loc, CW_Test_Node),
 544                 Then_Statements =>
 545                   New_List (Make_Raise_Statement (Loc,
 546                               New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
 547          end;
 548
 549       --  Call IW_Membership test if the Result_Type is an abstract interface
 550       --  to look for the tag in the table of interface tags.
 551
 552       else
 553          Insert_Action (N,
 554            Make_Implicit_If_Statement (N,
 555              Condition =>
 556                Make_Op_Not (Loc,
 557                  Make_Function_Call (Loc,
 558                     Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
 559                     Parameter_Associations => New_List (
 560                       Make_Attribute_Reference (Loc,
 561                         Prefix         => New_Copy_Tree (Tag_Arg),
 562                         Attribute_Name => Name_Address),
 563
 564                       New_Occurrence_Of (
 565                         Node (First_Elmt (Access_Disp_Table (
 566                                             Root_Type (Result_Typ)))), Loc)))),
 567              Then_Statements =>
 568                New_List (
 569                  Make_Raise_Statement (Loc,
 570                    Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
 571       end if;
 572
 573       Analyze_And_Resolve (N, Etype (Act_Constr));
 574    end Expand_Dispatching_Constructor_Call;
 575
 576    ---------------------------
 577    -- Expand_Exception_Call --
 578    ---------------------------
 579
 580    --  If the function call is not within an exception handler, then the call
 581    --  is replaced by a null string. Otherwise the appropriate routine in
 582    --  Ada.Exceptions is called passing the choice parameter specification
 583    --  from the enclosing handler. If the enclosing handler lacks a choice
 584    --  parameter, then one is supplied.
 585
 586    procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is
 587       Loc : constant Source_Ptr := Sloc (N);
 588       P   : Node_Id;
 589       E   : Entity_Id;
 590
 591    begin
 592       --  Climb up parents to see if we are in exception handler
 593
 594       P := Parent (N);
 595       loop
 596          --  Case of not in exception handler, replace by null string
 597
 598          if No (P) then
 599             Rewrite (N,
 600               Make_String_Literal (Loc,
 601                 Strval => ""));
 602             exit;
 603
 604          --  Case of in exception handler
 605
 606          elsif Nkind (P) = N_Exception_Handler then
 607
 608             --  Handler cannot be used for a local raise, and furthermore, this
 609             --  is a violation of the No_Exception_Propagation restriction.
 610
 611             Set_Local_Raise_Not_OK (P);
 612             Check_Restriction (No_Exception_Propagation, N);
 613
 614             --  If no choice parameter present, then put one there. Note that
 615             --  we do not need to put it on the entity chain, since no one will
 616             --  be referencing it by normal visibility methods.
 617
 618             if No (Choice_Parameter (P)) then
 619                E := Make_Temporary (Loc, 'E');
 620                Set_Choice_Parameter (P, E);
 621                Set_Ekind (E, E_Variable);
 622                Set_Etype (E, RTE (RE_Exception_Occurrence));
 623                Set_Scope (E, Current_Scope);
 624             end if;
 625
 626             Rewrite (N,
 627               Make_Function_Call (Loc,
 628                 Name => New_Occurrence_Of (RTE (Ent), Loc),
 629                 Parameter_Associations => New_List (
 630                   New_Occurrence_Of (Choice_Parameter (P), Loc))));
 631             exit;
 632
 633          --  Keep climbing
 634
 635          else
 636             P := Parent (P);
 637          end if;
 638       end loop;
 639
 640       Analyze_And_Resolve (N, Standard_String);
 641    end Expand_Exception_Call;
 642
 643    ------------------------
 644    -- Expand_Import_Call --
 645    ------------------------
 646
 647    --  The function call must have a static string as its argument. We create
 648    --  a dummy variable which uses this string as the external name in an
 649    --  Import pragma. The result is then obtained as the address of this
 650    --  dummy variable, converted to the appropriate target type.
 651
 652    procedure Expand_Import_Call (N : Node_Id) is
 653       Loc : constant Source_Ptr := Sloc (N);
 654       Ent : constant Entity_Id  := Entity (Name (N));
 655       Str : constant Node_Id    := First_Actual (N);
 656       Dum : constant Entity_Id  := Make_Temporary (Loc, 'D');
 657
 658    begin
 659       Insert_Actions (N, New_List (
 660         Make_Object_Declaration (Loc,
 661           Defining_Identifier => Dum,
 662           Object_Definition   =>
 663             New_Occurrence_Of (Standard_Character, Loc)),
 664
 665         Make_Pragma (Loc,
 666           Chars                        => Name_Import,
 667           Pragma_Argument_Associations => New_List (
 668             Make_Pragma_Argument_Association (Loc,
 669               Expression => Make_Identifier (Loc, Name_Ada)),
 670
 671             Make_Pragma_Argument_Association (Loc,
 672               Expression => Make_Identifier (Loc, Chars (Dum))),
 673
 674             Make_Pragma_Argument_Association (Loc,
 675               Chars => Name_Link_Name,
 676               Expression => Relocate_Node (Str))))));
 677
 678       Rewrite (N,
 679         Unchecked_Convert_To (Etype (Ent),
 680           Make_Attribute_Reference (Loc,
 681             Prefix         => Make_Identifier (Loc, Chars (Dum)),
 682             Attribute_Name => Name_Address)));
 683
 684       Analyze_And_Resolve (N, Etype (Ent));
 685    end Expand_Import_Call;
 686
 687    ---------------------------
 688    -- Expand_Intrinsic_Call --
 689    ---------------------------
 690
 691    procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
 692       Nam : Name_Id;
 693
 694    begin
 695       --  If an external name is specified for the intrinsic, it is handled
 696       --  by the back-end: leave the call node unchanged for now.
 697
 698       if Present (Interface_Name (E)) then
 699          return;
 700       end if;
 701
 702       --  If the intrinsic subprogram is generic, gets its original name
 703
 704       if Present (Parent (E))
 705         and then Present (Generic_Parent (Parent (E)))
 706       then
 707          Nam := Chars (Generic_Parent (Parent (E)));
 708       else
 709          Nam := Chars (E);
 710       end if;
 711
 712       if Nam = Name_Asm then
 713          Expand_Asm_Call (N);
 714
 715       elsif Nam = Name_Divide then
 716          Expand_Decimal_Divide_Call (N);
 717
 718       elsif Nam = Name_Exception_Information then
 719          Expand_Exception_Call (N, RE_Exception_Information);
 720
 721       elsif Nam = Name_Exception_Message then
 722          Expand_Exception_Call (N, RE_Exception_Message);
 723
 724       elsif Nam = Name_Exception_Name then
 725          Expand_Exception_Call (N, RE_Exception_Name_Simple);
 726
 727       elsif Nam = Name_Generic_Dispatching_Constructor then
 728          Expand_Dispatching_Constructor_Call (N);
 729
 730       elsif Nam_In (Nam, Name_Import_Address,
 731                          Name_Import_Largest_Value,
 732                          Name_Import_Value)
 733       then
 734          Expand_Import_Call (N);
 735
 736       elsif Nam = Name_Is_Negative then
 737          Expand_Is_Negative (N);
 738
 739       elsif Nam = Name_Rotate_Left then
 740          Expand_Shift (N, E, N_Op_Rotate_Left);
 741
 742       elsif Nam = Name_Rotate_Right then
 743          Expand_Shift (N, E, N_Op_Rotate_Right);
 744
 745       elsif Nam = Name_Shift_Left then
 746          Expand_Shift (N, E, N_Op_Shift_Left);
 747
 748       elsif Nam = Name_Shift_Right then
 749          Expand_Shift (N, E, N_Op_Shift_Right);
 750
 751       elsif Nam = Name_Shift_Right_Arithmetic then
 752          Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
 753
 754       elsif Nam = Name_Unchecked_Conversion then
 755          Expand_Unc_Conversion (N, E);
 756
 757       elsif Nam = Name_Unchecked_Deallocation then
 758          Expand_Unc_Deallocation (N);
 759
 760       elsif Nam = Name_To_Address then
 761          Expand_To_Address (N);
 762
 763       elsif Nam = Name_To_Pointer then
 764          Expand_To_Pointer (N);
 765
 766       elsif Nam_In (Nam, Name_File,
 767                          Name_Line,
 768                          Name_Source_Location,
 769                          Name_Enclosing_Entity,
 770                          Name_Compilation_ISO_Date,
 771                          Name_Compilation_Date,
 772                          Name_Compilation_Time)
 773       then
 774          Expand_Source_Info (N, Nam);
 775
 776          --  If we have a renaming, expand the call to the original operation,
 777          --  which must itself be intrinsic, since renaming requires matching
 778          --  conventions and this has already been checked.
 779
 780       elsif Present (Alias (E)) then
 781          Expand_Intrinsic_Call (N, Alias (E));
 782
 783       elsif Nkind (N) in N_Binary_Op then
 784          Expand_Binary_Operator_Call (N);
 785
 786          --  The only other case is where an external name was specified, since
 787          --  this is the only way that an otherwise unrecognized name could
 788          --  escape the checking in Sem_Prag. Nothing needs to be done in such
 789          --  a case, since we pass such a call to the back end unchanged.
 790
 791       else
 792          null;
 793       end if;
 794    end Expand_Intrinsic_Call;
 795
 796    ------------------------
 797    -- Expand_Is_Negative --
 798    ------------------------
 799
 800    procedure Expand_Is_Negative (N : Node_Id) is
 801       Loc   : constant Source_Ptr := Sloc (N);
 802       Opnd  : constant Node_Id    := Relocate_Node (First_Actual (N));
 803
 804    begin
 805
 806       --  We replace the function call by the following expression
 807
 808       --    if Opnd < 0.0 then
 809       --       True
 810       --    else
 811       --       if Opnd > 0.0 then
 812       --          False;
 813       --       else
 814       --          Float_Unsigned!(Float (Opnd)) /= 0
 815       --       end if;
 816       --    end if;
 817
 818       Rewrite (N,
 819         Make_If_Expression (Loc,
 820           Expressions => New_List (
 821             Make_Op_Lt (Loc,
 822               Left_Opnd  => Duplicate_Subexpr (Opnd),
 823               Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
 824
 825             New_Occurrence_Of (Standard_True, Loc),
 826
 827             Make_If_Expression (Loc,
 828              Expressions => New_List (
 829                Make_Op_Gt (Loc,
 830                  Left_Opnd  => Duplicate_Subexpr_No_Checks (Opnd),
 831                  Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
 832
 833                New_Occurrence_Of (Standard_False, Loc),
 834
 835                 Make_Op_Ne (Loc,
 836                   Left_Opnd =>
 837                     Unchecked_Convert_To
 838                       (RTE (RE_Float_Unsigned),
 839                        Convert_To
 840                          (Standard_Float,
 841                           Duplicate_Subexpr_No_Checks (Opnd))),
 842                   Right_Opnd =>
 843                     Make_Integer_Literal (Loc, 0)))))));
 844
 845       Analyze_And_Resolve (N, Standard_Boolean);
 846    end Expand_Is_Negative;
 847
 848    ------------------
 849    -- Expand_Shift --
 850    ------------------
 851
 852    --  This procedure is used to convert a call to a shift function to the
 853    --  corresponding operator node. This conversion is not done by the usual
 854    --  circuit for converting calls to operator functions (e.g. "+"(1,2)) to
 855    --  operator nodes, because shifts are not predefined operators.
 856
 857    --  As a result, whenever a shift is used in the source program, it will
 858    --  remain as a call until converted by this routine to the operator node
 859    --  form which the back end is expecting to see.
 860
 861    --  Note: it is possible for the expander to generate shift operator nodes
 862    --  directly, which will be analyzed in the normal manner by calling Analyze
 863    --  and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
 864
 865    procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
 866       Entyp : constant Entity_Id  := Etype (E);
 867       Left  : constant Node_Id    := First_Actual (N);
 868       Loc   : constant Source_Ptr := Sloc (N);
 869       Right : constant Node_Id    := Next_Actual (Left);
 870       Ltyp  : constant Node_Id    := Etype (Left);
 871       Rtyp  : constant Node_Id    := Etype (Right);
 872       Typ   : constant Entity_Id  := Etype (N);
 873       Snode : Node_Id;
 874
 875    begin
 876       Snode := New_Node (K, Loc);
 877       Set_Right_Opnd (Snode, Relocate_Node (Right));
 878       Set_Chars      (Snode, Chars (E));
 879       Set_Etype      (Snode, Base_Type (Entyp));
 880       Set_Entity     (Snode, E);
 881
 882       if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
 883         and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)
 884       then
 885          Set_Shift_Count_OK (Snode, True);
 886       end if;
 887
 888       if Typ = Entyp then
 889
 890          --  Note that we don't call Analyze and Resolve on this node, because
 891          --  it already got analyzed and resolved when it was a function call.
 892
 893          Set_Left_Opnd (Snode, Relocate_Node (Left));
 894          Rewrite (N, Snode);
 895          Set_Analyzed (N);
 896
 897          --  However, we do call the expander, so that the expansion for
 898          --  rotates and shift_right_arithmetic happens if Modify_Tree_For_C
 899          --  is set.
 900
 901          if Expander_Active then
 902             Expand (N);
 903          end if;
 904
 905       else
 906          --  If the context type is not the type of the operator, it is an
 907          --  inherited operator for a derived type. Wrap the node in a
 908          --  conversion so that it is type-consistent for possible further
 909          --  expansion (e.g. within a lock-free protected type).
 910
 911          Set_Left_Opnd (Snode,
 912            Unchecked_Convert_To (Base_Type (Entyp), Relocate_Node (Left)));
 913          Rewrite (N, Unchecked_Convert_To (Typ, Snode));
 914
 915          --  Analyze and resolve result formed by conversion to target type
 916
 917          Analyze_And_Resolve (N, Typ);
 918       end if;
 919    end Expand_Shift;
 920
 921    ------------------------
 922    -- Expand_Source_Info --
 923    ------------------------
 924
 925    procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
 926       Loc : constant Source_Ptr := Sloc (N);
 927    begin
 928       --  Integer cases
 929
 930       if Nam = Name_Line then
 931          Rewrite (N,
 932            Make_Integer_Literal (Loc,
 933              Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));
 934          Analyze_And_Resolve (N, Standard_Positive);
 935
 936       --  String cases
 937
 938       else
 939          declare
 940             Buf : Bounded_String;
 941          begin
 942             Add_Source_Info (Buf, Loc, Nam);
 943             Rewrite (N, Make_String_Literal (Loc, Strval => +Buf));
 944             Analyze_And_Resolve (N, Standard_String);
 945          end;
 946       end if;
 947
 948       Set_Is_Static_Expression (N);
 949    end Expand_Source_Info;
 950
 951    ---------------------------
 952    -- Expand_Unc_Conversion --
 953    ---------------------------
 954
 955    procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
 956       Func : constant Entity_Id  := Entity (Name (N));
 957       Conv : Node_Id;
 958       Ftyp : Entity_Id;
 959       Ttyp : Entity_Id;
 960
 961    begin
 962       --  Rewrite as unchecked conversion node. Note that we must convert
 963       --  the operand to the formal type of the input parameter of the
 964       --  function, so that the resulting N_Unchecked_Type_Conversion
 965       --  call indicates the correct types for Gigi.
 966
 967       --  Right now, we only do this if a scalar type is involved. It is
 968       --  not clear if it is needed in other cases. If we do attempt to
 969       --  do the conversion unconditionally, it crashes 3411-018. To be
 970       --  investigated further ???
 971
 972       Conv := Relocate_Node (First_Actual (N));
 973       Ftyp := Etype (First_Formal (Func));
 974
 975       if Is_Scalar_Type (Ftyp) then
 976          Conv := Convert_To (Ftyp, Conv);
 977          Set_Parent (Conv, N);
 978          Analyze_And_Resolve (Conv);
 979       end if;
 980
 981       --  The instantiation of Unchecked_Conversion creates a wrapper package,
 982       --  and the target type is declared as a subtype of the actual. Recover
 983       --  the actual, which is the subtype indic. in the subtype declaration
 984       --  for the target type. This is semantically correct, and avoids
 985       --  anomalies with access subtypes. For entities, leave type as is.
 986
 987       --  We do the analysis here, because we do not want the compiler
 988       --  to try to optimize or otherwise reorganize the unchecked
 989       --  conversion node.
 990
 991       Ttyp := Etype (E);
 992
 993       if Is_Entity_Name (Conv) then
 994          null;
 995
 996       elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then
 997          Ttyp := Entity (Subtype_Indication (Parent (Etype (E))));
 998
 999       elsif Is_Itype (Ttyp) then
1000          Ttyp :=
1001            Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp)));
1002       else
1003          raise Program_Error;
1004       end if;
1005
1006       Rewrite (N, Unchecked_Convert_To (Ttyp, Conv));
1007       Set_Etype (N, Ttyp);
1008       Set_Analyzed (N);
1009
1010       if Nkind (N) = N_Unchecked_Type_Conversion then
1011          Expand_N_Unchecked_Type_Conversion (N);
1012       end if;
1013    end Expand_Unc_Conversion;
1014
1015    -----------------------------
1016    -- Expand_Unc_Deallocation --
1017    -----------------------------
1018
1019    procedure Expand_Unc_Deallocation (N : Node_Id) is
1020       Arg       : constant Node_Id    := First_Actual (N);
1021       Loc       : constant Source_Ptr := Sloc (N);
1022       Typ       : constant Entity_Id  := Etype (Arg);
1023       Desig_Typ : constant Entity_Id  := Designated_Type (Typ);
1024       Needs_Fin : constant Boolean    := Needs_Finalization (Desig_Typ);
1025       Root_Typ  : constant Entity_Id  := Underlying_Type (Root_Type (Typ));
1026       Pool      : constant Entity_Id  := Associated_Storage_Pool (Root_Typ);
1027       Stmts     : constant List_Id    := New_List;
1028
1029       Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N);
1030       --  This captures whether we know the argument to be non-null so that
1031       --  we can avoid the test. The reason that we need to capture this is
1032       --  that we analyze some generated statements before properly attaching
1033       --  them to the tree, and that can disturb current value settings.
1034
1035       Exceptions_OK : constant Boolean :=
1036                         not Restriction_Active (No_Exception_Propagation);
1037
1038       Abrt_Blk    : Node_Id := Empty;
1039       Abrt_Blk_Id : Entity_Id;
1040       Abrt_HSS    : Node_Id;
1041       AUD         : Entity_Id;
1042       Fin_Blk     : Node_Id;
1043       Fin_Call    : Node_Id;
1044       Fin_Data    : Finalization_Exception_Data;
1045       Free_Arg    : Node_Id;
1046       Free_Nod    : Node_Id;
1047       Gen_Code    : Node_Id;
1048       Obj_Ref     : Node_Id;
1049
1050    begin
1051       --  Nothing to do if we know the argument is null
1052
1053       if Known_Null (N) then
1054          return;
1055       end if;
1056
1057       --  Processing for pointer to controlled types. Generate:
1058
1059       --    Abrt   : constant Boolean := ...;
1060       --    Ex     : Exception_Occurrence;
1061       --    Raised : Boolean := False;
1062
1063       --    begin
1064       --       Abort_Defer;
1065
1066       --       begin
1067       --          [Deep_]Finalize (Obj_Ref);
1068
1069       --       exception
1070       --          when others =>
1071       --             if not Raised then
1072       --                Raised := True;
1073       --                Save_Occurrence (Ex, Get_Current_Excep.all.all);
1074       --       end;
1075       --    at end
1076       --       Abort_Undefer_Direct;
1077       --    end;
1078
1079       --  Depending on whether exception propagation is enabled and/or aborts
1080       --  are allowed, the generated code may lack block statements.
1081
1082       if Needs_Fin then
1083          Obj_Ref :=
1084            Make_Explicit_Dereference (Loc,
1085              Prefix => Duplicate_Subexpr_No_Checks (Arg));
1086
1087          --  If the designated type is tagged, the finalization call must
1088          --  dispatch because the designated type may not be the actual type
1089          --  of the object. If the type is synchronized, the deallocation
1090          --  applies to the corresponding record type.
1091
1092          if Is_Tagged_Type (Desig_Typ) then
1093             if Is_Concurrent_Type (Desig_Typ) then
1094                Obj_Ref :=
1095                  Unchecked_Convert_To
1096                    (Class_Wide_Type (Corresponding_Record_Type (Desig_Typ)),
1097                       Obj_Ref);
1098
1099             elsif not Is_Class_Wide_Type (Desig_Typ) then
1100                Obj_Ref :=
1101                  Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref);
1102             end if;
1103
1104          --  Otherwise the designated type is untagged. Set the type of the
1105          --  dereference explicitly to force a conversion when needed given
1106          --  that [Deep_]Finalize may be inherited from a parent type.
1107
1108          else
1109             Set_Etype (Obj_Ref, Desig_Typ);
1110          end if;
1111
1112          --  Generate:
1113          --    [Deep_]Finalize (Obj_Ref);
1114
1115          Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
1116
1117          --  Generate:
1118          --    Abrt   : constant Boolean := ...;
1119          --    Ex     : Exception_Occurrence;
1120          --    Raised : Boolean := False;
1121
1122          --    begin
1123          --       <Fin_Call>
1124
1125          --    exception
1126          --       when others =>
1127          --          if not Raised then
1128          --             Raised := True;
1129          --             Save_Occurrence (Ex, Get_Current_Excep.all.all);
1130          --    end;
1131
1132          if Exceptions_OK then
1133             Build_Object_Declarations (Fin_Data, Stmts, Loc);
1134
1135             Fin_Blk :=
1136               Make_Block_Statement (Loc,
1137                 Handled_Statement_Sequence =>
1138                   Make_Handled_Sequence_Of_Statements (Loc,
1139                     Statements         => New_List (Fin_Call),
1140                     Exception_Handlers => New_List (
1141                       Build_Exception_Handler (Fin_Data))));
1142
1143          --  Otherwise exception propagation is not allowed
1144
1145          else
1146             Fin_Blk := Fin_Call;
1147          end if;
1148
1149          --  The finalization action must be protected by an abort defer and
1150          --  undefer pair when aborts are allowed. Generate:
1151
1152          --    begin
1153          --       Abort_Defer;
1154          --       <Fin_Blk>
1155          --    at end
1156          --       Abort_Undefer_Direct;
1157          --    end;
1158
1159          if Abort_Allowed then
1160             AUD := RTE (RE_Abort_Undefer_Direct);
1161
1162             Abrt_HSS :=
1163               Make_Handled_Sequence_Of_Statements (Loc,
1164                 Statements  => New_List (
1165                   Build_Runtime_Call (Loc, RE_Abort_Defer),
1166                   Fin_Blk),
1167                 At_End_Proc => New_Occurrence_Of (AUD, Loc));
1168
1169             Abrt_Blk :=
1170               Make_Block_Statement (Loc,
1171                 Handled_Statement_Sequence => Abrt_HSS);
1172
1173             Add_Block_Identifier  (Abrt_Blk, Abrt_Blk_Id);
1174             Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
1175
1176             --  Present the Abort_Undefer_Direct function to the backend so
1177             --  that it can inline the call to the function.
1178
1179             Add_Inlined_Body (AUD, N);
1180
1181          --  Otherwise aborts are not allowed
1182
1183          else
1184             Abrt_Blk := Fin_Blk;
1185          end if;
1186
1187          Append_To (Stmts, Abrt_Blk);
1188       end if;
1189
1190       --  For a task type, call Free_Task before freeing the ATCB. We used to
1191       --  detect the case of Abort followed by a Free here, because the Free
1192       --  wouldn't actually free if it happens before the aborted task actually
1193       --  terminates. The warning was removed, because Free now works properly
1194       --  (the task will be freed once it terminates).
1195
1196       if Is_Task_Type (Desig_Typ) then
1197          Append_To (Stmts,
1198            Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
1199
1200       --  For composite types that contain tasks, recurse over the structure
1201       --  to build the selectors for the task subcomponents.
1202
1203       elsif Has_Task (Desig_Typ) then
1204          if Is_Array_Type (Desig_Typ) then
1205             Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ));
1206
1207          elsif Is_Record_Type (Desig_Typ) then
1208             Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ));
1209          end if;
1210       end if;
1211
1212       --  Same for simple protected types. Eventually call Finalize_Protection
1213       --  before freeing the PO for each protected component.
1214
1215       if Is_Simple_Protected_Type (Desig_Typ) then
1216          Append_To (Stmts,
1217            Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg)));
1218
1219       elsif Has_Simple_Protected_Object (Desig_Typ) then
1220          if Is_Array_Type (Desig_Typ) then
1221             Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ));
1222
1223          elsif Is_Record_Type (Desig_Typ) then
1224             Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ));
1225          end if;
1226       end if;
1227
1228       --  Normal processing for non-controlled types. The argument to free is
1229       --  a renaming rather than a constant to ensure that the original context
1230       --  is always set to null after the deallocation takes place.
1231
1232       Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True);
1233       Free_Nod := Make_Free_Statement (Loc, Empty);
1234       Append_To (Stmts, Free_Nod);
1235       Set_Storage_Pool (Free_Nod, Pool);
1236
1237       --  Attach to tree before analysis of generated subtypes below
1238
1239       Set_Parent (Stmts, Parent (N));
1240
1241       --  Deal with storage pool
1242
1243       if Present (Pool) then
1244
1245          --  Freeing the secondary stack is meaningless
1246
1247          if Is_RTE (Pool, RE_SS_Pool) then
1248             null;
1249
1250          --  If the pool object is of a simple storage pool type, then attempt
1251          --  to locate the type's Deallocate procedure, if any, and set the
1252          --  free operation's procedure to call. If the type doesn't have a
1253          --  Deallocate (which is allowed), then the actual will simply be set
1254          --  to null.
1255
1256          elsif Present
1257                  (Get_Rep_Pragma (Etype (Pool), Name_Simple_Storage_Pool_Type))
1258          then
1259             declare
1260                Pool_Typ : constant Entity_Id := Base_Type (Etype (Pool));
1261                Dealloc  : Entity_Id;
1262
1263             begin
1264                Dealloc := Get_Name_Entity_Id (Name_Deallocate);
1265                while Present (Dealloc) loop
1266                   if Scope (Dealloc) = Scope (Pool_Typ)
1267                     and then Present (First_Formal (Dealloc))
1268                     and then Etype (First_Formal (Dealloc)) = Pool_Typ
1269                   then
1270                      Set_Procedure_To_Call (Free_Nod, Dealloc);
1271                      exit;
1272                   else
1273                      Dealloc := Homonym (Dealloc);
1274                   end if;
1275                end loop;
1276             end;
1277
1278          --  Case of a class-wide pool type: make a dispatching call to
1279          --  Deallocate through the class-wide Deallocate_Any.
1280
1281          elsif Is_Class_Wide_Type (Etype (Pool)) then
1282             Set_Procedure_To_Call (Free_Nod, RTE (RE_Deallocate_Any));
1283
1284          --  Case of a specific pool type: make a statically bound call
1285
1286          else
1287             Set_Procedure_To_Call
1288               (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate));
1289          end if;
1290       end if;
1291
1292       if Present (Procedure_To_Call (Free_Nod)) then
1293
1294          --  For all cases of a Deallocate call, the back-end needs to be able
1295          --  to compute the size of the object being freed. This may require
1296          --  some adjustments for objects of dynamic size.
1297          --
1298          --  If the type is class wide, we generate an implicit type with the
1299          --  right dynamic size, so that the deallocate call gets the right
1300          --  size parameter computed by GIGI. Same for an access to
1301          --  unconstrained packed array.
1302
1303          if Is_Class_Wide_Type (Desig_Typ)
1304            or else
1305             (Is_Array_Type (Desig_Typ)
1306               and then not Is_Constrained (Desig_Typ)
1307               and then Is_Packed (Desig_Typ))
1308          then
1309             declare
1310                Deref    : constant Node_Id :=
1311                             Make_Explicit_Dereference (Loc,
1312                               Duplicate_Subexpr_No_Checks (Arg));
1313                D_Subtyp : Node_Id;
1314                D_Type   : Entity_Id;
1315
1316             begin
1317                --  Perform minor decoration as it is needed by the side effect
1318                --  removal mechanism.
1319
1320                Set_Etype  (Deref, Desig_Typ);
1321                Set_Parent (Deref, Free_Nod);
1322                D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_Typ);
1323
1324                if Nkind (D_Subtyp) in N_Has_Entity then
1325                   D_Type := Entity (D_Subtyp);
1326
1327                else
1328                   D_Type := Make_Temporary (Loc, 'A');
1329                   Insert_Action (Deref,
1330                     Make_Subtype_Declaration (Loc,
1331                       Defining_Identifier => D_Type,
1332                       Subtype_Indication  => D_Subtyp));
1333                end if;
1334
1335                --  Force freezing at the point of the dereference. For the
1336                --  class wide case, this avoids having the subtype frozen
1337                --  before the equivalent type.
1338
1339                Freeze_Itype (D_Type, Deref);
1340
1341                Set_Actual_Designated_Subtype (Free_Nod, D_Type);
1342             end;
1343          end if;
1344       end if;
1345
1346       --  Ada 2005 (AI-251): In case of abstract interface type we must
1347       --  displace the pointer to reference the base of the object to
1348       --  deallocate its memory, unless we're targetting a VM, in which case
1349       --  no special processing is required.
1350
1351       --  Generate:
1352       --    free (Base_Address (Obj_Ptr))
1353
1354       if Is_Interface (Directly_Designated_Type (Typ))
1355         and then Tagged_Type_Expansion
1356       then
1357          Set_Expression (Free_Nod,
1358            Unchecked_Convert_To (Typ,
1359              Make_Function_Call (Loc,
1360                Name                   =>
1361                  New_Occurrence_Of (RTE (RE_Base_Address), Loc),
1362                Parameter_Associations => New_List (
1363                  Unchecked_Convert_To (RTE (RE_Address), Free_Arg)))));
1364
1365       --  Generate:
1366       --    free (Obj_Ptr)
1367
1368       else
1369          Set_Expression (Free_Nod, Free_Arg);
1370       end if;
1371
1372       --  Only remaining step is to set result to null, or generate a raise of
1373       --  Constraint_Error if the target object is "not null".
1374
1375       if Can_Never_Be_Null (Etype (Arg)) then
1376          Append_To (Stmts,
1377            Make_Raise_Constraint_Error (Loc,
1378              Reason => CE_Access_Check_Failed));
1379
1380       else
1381          declare
1382             Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg);
1383          begin
1384             Set_Assignment_OK (Lhs);
1385             Append_To (Stmts,
1386               Make_Assignment_Statement (Loc,
1387                 Name       => Lhs,
1388                 Expression => Make_Null (Loc)));
1389          end;
1390       end if;
1391
1392       --  Generate a test of whether any earlier finalization raised an
1393       --  exception, and in that case raise Program_Error with the previous
1394       --  exception occurrence.
1395
1396       --  Generate:
1397       --    if Raised and then not Abrt then
1398       --       raise Program_Error;                  --  for restricted RTS
1399       --         <or>
1400       --       Raise_From_Controlled_Operation (E);  --  all other cases
1401       --    end if;
1402
1403       if Needs_Fin and then Exceptions_OK then
1404          Append_To (Stmts, Build_Raise_Statement (Fin_Data));
1405       end if;
1406
1407       --  If we know the argument is non-null, then make a block statement
1408       --  that contains the required statements, no need for a test.
1409
1410       if Arg_Known_Non_Null then
1411          Gen_Code :=
1412            Make_Block_Statement (Loc,
1413              Handled_Statement_Sequence =>
1414                Make_Handled_Sequence_Of_Statements (Loc,
1415              Statements => Stmts));
1416
1417       --  If the argument may be null, wrap the statements inside an IF that
1418       --  does an explicit test to exclude the null case.
1419
1420       else
1421          Gen_Code :=
1422            Make_Implicit_If_Statement (N,
1423              Condition       =>
1424                Make_Op_Ne (Loc,
1425                  Left_Opnd  => Duplicate_Subexpr (Arg),
1426                  Right_Opnd => Make_Null (Loc)),
1427              Then_Statements => Stmts);
1428       end if;
1429
1430       --  Rewrite the call
1431
1432       Rewrite (N, Gen_Code);
1433       Analyze (N);
1434    end Expand_Unc_Deallocation;
1435
1436    -----------------------
1437    -- Expand_To_Address --
1438    -----------------------
1439
1440    procedure Expand_To_Address (N : Node_Id) is
1441       Loc : constant Source_Ptr := Sloc (N);
1442       Arg : constant Node_Id := First_Actual (N);
1443       Obj : Node_Id;
1444
1445    begin
1446       Remove_Side_Effects (Arg);
1447
1448       Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
1449
1450       Rewrite (N,
1451         Make_If_Expression (Loc,
1452           Expressions => New_List (
1453             Make_Op_Eq (Loc,
1454               Left_Opnd => New_Copy_Tree (Arg),
1455               Right_Opnd => Make_Null (Loc)),
1456             New_Occurrence_Of (RTE (RE_Null_Address), Loc),
1457             Make_Attribute_Reference (Loc,
1458               Prefix         => Obj,
1459               Attribute_Name => Name_Address))));
1460
1461       Analyze_And_Resolve (N, RTE (RE_Address));
1462    end Expand_To_Address;
1463
1464    -----------------------
1465    -- Expand_To_Pointer --
1466    -----------------------
1467
1468    procedure Expand_To_Pointer (N : Node_Id) is
1469       Arg : constant Node_Id := First_Actual (N);
1470
1471    begin
1472       Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
1473       Analyze (N);
1474    end Expand_To_Pointer;
1475
1476 end Exp_Intr;