gcc/ada/sem_disp.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ D I S P                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004 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 Debug;    use Debug;
  29 with Elists;   use Elists;
  30 with Einfo;    use Einfo;
  31 with Exp_Disp; use Exp_Disp;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Tss;  use Exp_Tss;
  34 with Errout;   use Errout;
  35 with Hostparm; use Hostparm;
  36 with Nlists;   use Nlists;
  37 with Opt;      use Opt;
  38 with Output;   use Output;
  39 with Sem;      use Sem;
  40 with Sem_Ch6;  use Sem_Ch6;
  41 with Sem_Eval; use Sem_Eval;
  42 with Sem_Util; use Sem_Util;
  43 with Snames;   use Snames;
  44 with Stand;    use Stand;
  45 with Sinfo;    use Sinfo;
  46 with Uintp;    use Uintp;
  47
  48 package body Sem_Disp is
  49
  50    -----------------------
  51    -- Local Subprograms --
  52    -----------------------
  53
  54    procedure Override_Dispatching_Operation
  55      (Tagged_Type : Entity_Id;
  56       Prev_Op     : Entity_Id;
  57       New_Op      : Entity_Id);
  58    --  Replace an implicit dispatching operation with an explicit one.
  59    --  Prev_Op is an inherited primitive operation which is overridden
  60    --  by the explicit declaration of New_Op.
  61
  62    procedure Add_Dispatching_Operation
  63      (Tagged_Type : Entity_Id;
  64       New_Op      : Entity_Id);
  65    --  Add New_Op in the list of primitive operations of Tagged_Type
  66
  67    function Check_Controlling_Type
  68      (T    : Entity_Id;
  69       Subp : Entity_Id)
  70       return Entity_Id;
  71       --  T is the type of a formal parameter of subp. Returns the tagged
  72       --  if the parameter can be a controlling argument, empty otherwise
  73
  74    --------------------------------
  75    --  Add_Dispatching_Operation --
  76    --------------------------------
  77
  78    procedure Add_Dispatching_Operation
  79      (Tagged_Type : Entity_Id;
  80       New_Op      : Entity_Id)
  81    is
  82       List : constant Elist_Id := Primitive_Operations (Tagged_Type);
  83
  84    begin
  85       Append_Elmt (New_Op, List);
  86    end Add_Dispatching_Operation;
  87
  88    -------------------------------
  89    -- Check_Controlling_Formals --
  90    -------------------------------
  91
  92    procedure Check_Controlling_Formals
  93      (Typ  : Entity_Id;
  94       Subp : Entity_Id)
  95    is
  96       Formal    : Entity_Id;
  97       Ctrl_Type : Entity_Id;
  98       Remote    : constant Boolean :=
  99                     Is_Remote_Types (Current_Scope)
 100                       and then Comes_From_Source (Subp)
 101                       and then Scope (Typ) = Current_Scope;
 102
 103    begin
 104       Formal := First_Formal (Subp);
 105
 106       while Present (Formal) loop
 107          Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
 108
 109          if Present (Ctrl_Type) then
 110             if Ctrl_Type = Typ then
 111                Set_Is_Controlling_Formal (Formal);
 112
 113                --  Check that the parameter's nominal subtype statically
 114                --  matches the first subtype.
 115
 116                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
 117                   if not Subtypes_Statically_Match
 118                            (Typ, Designated_Type (Etype (Formal)))
 119                   then
 120                      Error_Msg_N
 121                        ("parameter subtype does not match controlling type",
 122                         Formal);
 123                   end if;
 124
 125                elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
 126                   Error_Msg_N
 127                     ("parameter subtype does not match controlling type",
 128                      Formal);
 129                end if;
 130
 131                if Present (Default_Value (Formal)) then
 132                   if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
 133                      Error_Msg_N
 134                        ("default not allowed for controlling access parameter",
 135                         Default_Value (Formal));
 136
 137                   elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
 138                      Error_Msg_N
 139                        ("default expression must be a tag indeterminate" &
 140                         " function call", Default_Value (Formal));
 141                   end if;
 142                end if;
 143
 144             elsif Comes_From_Source (Subp) then
 145                Error_Msg_N
 146                  ("operation can be dispatching in only one type", Subp);
 147             end if;
 148
 149          --  Verify that the restriction in E.2.2 (14) is obeyed
 150
 151          elsif Remote
 152            and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
 153          then
 154             Error_Msg_N
 155               ("Access parameter of a remote subprogram must be controlling",
 156                 Formal);
 157          end if;
 158
 159          Next_Formal (Formal);
 160       end loop;
 161
 162       if Present (Etype (Subp)) then
 163          Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
 164
 165          if Present (Ctrl_Type) then
 166             if Ctrl_Type = Typ then
 167                Set_Has_Controlling_Result (Subp);
 168
 169                --  Check that the result subtype statically matches
 170                --  the first subtype.
 171
 172                if not Subtypes_Statically_Match (Typ, Etype (Subp)) then
 173                   Error_Msg_N
 174                     ("result subtype does not match controlling type", Subp);
 175                end if;
 176
 177             elsif Comes_From_Source (Subp) then
 178                Error_Msg_N
 179                  ("operation can be dispatching in only one type", Subp);
 180             end if;
 181
 182          --  The following check is clearly required, although the RM says
 183          --  nothing about return types. If the return type is a limited
 184          --  class-wide type declared in the current scope, there is no way
 185          --  to declare stream procedures for it, so the return cannot be
 186          --  marshalled.
 187
 188          elsif Remote
 189            and then Is_Limited_Type (Typ)
 190            and then Etype (Subp) = Class_Wide_Type (Typ)
 191          then
 192             Error_Msg_N ("return type has no stream attributes", Subp);
 193          end if;
 194       end if;
 195    end Check_Controlling_Formals;
 196
 197    ----------------------------
 198    -- Check_Controlling_Type --
 199    ----------------------------
 200
 201    function Check_Controlling_Type
 202      (T    : Entity_Id;
 203       Subp : Entity_Id)
 204       return Entity_Id
 205    is
 206       Tagged_Type : Entity_Id := Empty;
 207
 208    begin
 209       if Is_Tagged_Type (T) then
 210          if Is_First_Subtype (T) then
 211             Tagged_Type := T;
 212          else
 213             Tagged_Type := Base_Type (T);
 214          end if;
 215
 216       elsif Ekind (T) = E_Anonymous_Access_Type
 217         and then Is_Tagged_Type (Designated_Type (T))
 218         and then Ekind (Designated_Type (T)) /= E_Incomplete_Type
 219       then
 220          if Is_First_Subtype (Designated_Type (T)) then
 221             Tagged_Type := Designated_Type (T);
 222          else
 223             Tagged_Type := Base_Type (Designated_Type (T));
 224          end if;
 225       end if;
 226
 227       if No (Tagged_Type)
 228         or else Is_Class_Wide_Type (Tagged_Type)
 229       then
 230          return Empty;
 231
 232       --  The dispatching type and the primitive operation must be defined
 233       --  in the same scope except for internal operations.
 234
 235       elsif (Scope (Subp) = Scope (Tagged_Type)
 236               or else Is_Internal (Subp))
 237         and then
 238             (not Is_Generic_Type (Tagged_Type)
 239               or else not Comes_From_Source (Subp))
 240       then
 241          return Tagged_Type;
 242
 243       else
 244          return Empty;
 245       end if;
 246    end Check_Controlling_Type;
 247
 248    ----------------------------
 249    -- Check_Dispatching_Call --
 250    ----------------------------
 251
 252    procedure Check_Dispatching_Call (N : Node_Id) is
 253       Actual  : Node_Id;
 254       Control : Node_Id := Empty;
 255       Func    : Entity_Id;
 256
 257       procedure Check_Dispatching_Context;
 258       --  If the call is tag-indeterminate and the entity being called is
 259       --  abstract, verify that the context is a call that will eventually
 260       --  provide a tag for dispatching, or has provided one already.
 261
 262       -------------------------------
 263       -- Check_Dispatching_Context --
 264       -------------------------------
 265
 266       procedure Check_Dispatching_Context is
 267          Func : constant Entity_Id := Entity (Name (N));
 268          Par  : Node_Id;
 269
 270       begin
 271          if Is_Abstract (Func)
 272            and then No (Controlling_Argument (N))
 273          then
 274             if Present (Alias (Func))
 275               and then not Is_Abstract (Alias (Func))
 276               and then No (DTC_Entity (Func))
 277             then
 278                --  Private overriding of inherited abstract operation,
 279                --  call is legal.
 280
 281                Set_Entity (Name (N), Alias (Func));
 282                return;
 283
 284             else
 285                Par := Parent (N);
 286
 287                while Present (Par) loop
 288
 289                   if (Nkind (Par) = N_Function_Call            or else
 290                       Nkind (Par) = N_Procedure_Call_Statement or else
 291                       Nkind (Par) = N_Assignment_Statement     or else
 292                       Nkind (Par) = N_Op_Eq                    or else
 293                       Nkind (Par) = N_Op_Ne)
 294                     and then Is_Tagged_Type (Etype (Func))
 295                   then
 296                      return;
 297
 298                   elsif Nkind (Par) = N_Qualified_Expression
 299                     or else Nkind (Par) = N_Unchecked_Type_Conversion
 300                   then
 301                      Par := Parent (Par);
 302
 303                   else
 304                      Error_Msg_N
 305                        ("call to abstract function must be dispatching", N);
 306                      return;
 307                   end if;
 308                end loop;
 309             end if;
 310          end if;
 311       end Check_Dispatching_Context;
 312
 313    --  Start of processing for Check_Dispatching_Call
 314
 315    begin
 316       --  Find a controlling argument, if any
 317
 318       if Present (Parameter_Associations (N)) then
 319          Actual := First_Actual (N);
 320
 321          while Present (Actual) loop
 322             Control := Find_Controlling_Arg (Actual);
 323             exit when Present (Control);
 324             Next_Actual (Actual);
 325          end loop;
 326
 327          if Present (Control) then
 328
 329             --  Verify that no controlling arguments are statically tagged
 330
 331             if Debug_Flag_E then
 332                Write_Str ("Found Dispatching call");
 333                Write_Int (Int (N));
 334                Write_Eol;
 335             end if;
 336
 337             Actual := First_Actual (N);
 338
 339             while Present (Actual) loop
 340                if Actual /= Control then
 341
 342                   if not Is_Controlling_Actual (Actual) then
 343                      null; -- can be anything
 344
 345                   elsif Is_Dynamically_Tagged (Actual) then
 346                      null; --  valid parameter
 347
 348                   elsif Is_Tag_Indeterminate (Actual) then
 349
 350                      --  The tag is inherited from the enclosing call (the
 351                      --  node we are currently analyzing). Explicitly expand
 352                      --  the actual, since the previous call to Expand
 353                      --  (from Resolve_Call) had no way of knowing about
 354                      --  the required dispatching.
 355
 356                      Propagate_Tag (Control, Actual);
 357
 358                   else
 359                      Error_Msg_N
 360                        ("controlling argument is not dynamically tagged",
 361                         Actual);
 362                      return;
 363                   end if;
 364                end if;
 365
 366                Next_Actual (Actual);
 367             end loop;
 368
 369             --  Mark call as a dispatching call
 370
 371             Set_Controlling_Argument (N, Control);
 372
 373          else
 374             --  The call is not dispatching, check that there isn't any
 375             --  tag indeterminate abstract call left
 376
 377             Actual := First_Actual (N);
 378
 379             while Present (Actual) loop
 380                if Is_Tag_Indeterminate (Actual) then
 381
 382                   --  Function call case
 383
 384                   if Nkind (Original_Node (Actual)) = N_Function_Call then
 385                      Func := Entity (Name (Original_Node (Actual)));
 386
 387                   --  Only other possibility is a qualified expression whose
 388                   --  consituent expression is itself a call.
 389
 390                   else
 391                      Func :=
 392                        Entity (Name
 393                          (Original_Node
 394                            (Expression (Original_Node (Actual)))));
 395                   end if;
 396
 397                   if Is_Abstract (Func) then
 398                      Error_Msg_N (
 399                        "call to abstract function must be dispatching", N);
 400                   end if;
 401                end if;
 402
 403                Next_Actual (Actual);
 404             end loop;
 405
 406             Check_Dispatching_Context;
 407          end if;
 408
 409       else
 410          --  If dispatching on result, the enclosing call, if any, will
 411          --  determine the controlling argument. Otherwise this is the
 412          --  primitive operation of the root type.
 413
 414          Check_Dispatching_Context;
 415       end if;
 416    end Check_Dispatching_Call;
 417
 418    ---------------------------------
 419    -- Check_Dispatching_Operation --
 420    ---------------------------------
 421
 422    procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
 423       Tagged_Type            : Entity_Id;
 424       Has_Dispatching_Parent : Boolean := False;
 425       Body_Is_Last_Primitive : Boolean := False;
 426
 427       function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
 428       --  Check whether T is derived from a visibly controlled type.
 429       --  This is true if the root type is declared in Ada.Finalization.
 430       --  If T is derived instead from a private type whose full view
 431       --  is controlled, an explicit Initialize/Adjust/Finalize subprogram
 432       --  does not override the inherited one.
 433
 434       ---------------------------
 435       -- Is_Visibly_Controlled --
 436       ---------------------------
 437
 438       function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
 439          Root : constant Entity_Id := Root_Type (T);
 440       begin
 441          return Chars (Scope (Root)) = Name_Finalization
 442            and then Chars (Scope (Scope (Root))) = Name_Ada
 443            and then Scope (Scope (Scope (Root))) = Standard_Standard;
 444       end Is_Visibly_Controlled;
 445
 446    --  Start of processing for Check_Dispatching_Operation
 447
 448    begin
 449       if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
 450          return;
 451       end if;
 452
 453       Set_Is_Dispatching_Operation (Subp, False);
 454       Tagged_Type := Find_Dispatching_Type (Subp);
 455
 456       --  If Subp is derived from a dispatching operation then it should
 457       --  always be treated as dispatching. In this case various checks
 458       --  below will be bypassed. Makes sure that late declarations for
 459       --  inherited private subprograms are treated as dispatching, even
 460       --  if the associated tagged type is already frozen.
 461
 462       Has_Dispatching_Parent :=
 463          Present (Alias (Subp))
 464            and then Is_Dispatching_Operation (Alias (Subp));
 465
 466       if No (Tagged_Type) then
 467          return;
 468
 469       --  The subprograms build internally after the freezing point (such as
 470       --  the Init procedure) are not primitives
 471
 472       elsif Is_Frozen (Tagged_Type)
 473         and then not Comes_From_Source (Subp)
 474         and then not Has_Dispatching_Parent
 475       then
 476          return;
 477
 478       --  The operation may be a child unit, whose scope is the defining
 479       --  package, but which is not a primitive operation of the type.
 480
 481       elsif Is_Child_Unit (Subp) then
 482          return;
 483
 484       --  If the subprogram is not defined in a package spec, the only case
 485       --  where it can be a dispatching op is when it overrides an operation
 486       --  before the freezing point of the type.
 487
 488       elsif ((not Is_Package (Scope (Subp)))
 489               or else In_Package_Body (Scope (Subp)))
 490         and then not Has_Dispatching_Parent
 491       then
 492          if not Comes_From_Source (Subp)
 493            or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
 494          then
 495             null;
 496
 497          --  If the type is already frozen, the overriding is not allowed
 498          --  except when Old_Subp is not a dispatching operation (which
 499          --  can occur when Old_Subp was inherited by an untagged type).
 500          --  However, a body with no previous spec freezes the type "after"
 501          --  its declaration, and therefore is a legal overriding (unless
 502          --  the type has already been frozen). Only the first such body
 503          --  is legal.
 504
 505          elsif Present (Old_Subp)
 506            and then Is_Dispatching_Operation (Old_Subp)
 507          then
 508             if Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
 509               and then Comes_From_Source (Subp)
 510             then
 511                declare
 512                   Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
 513                   Decl_Item : Node_Id          := Next (Parent (Tagged_Type));
 514
 515                begin
 516                   --  ??? The checks here for whether the type has been
 517                   --  frozen prior to the new body are not complete. It's
 518                   --  not simple to check frozenness at this point since
 519                   --  the body has already caused the type to be prematurely
 520                   --  frozen in Analyze_Declarations, but we're forced to
 521                   --  recheck this here because of the odd rule interpretation
 522                   --  that allows the overriding if the type wasn't frozen
 523                   --  prior to the body. The freezing action should probably
 524                   --  be delayed until after the spec is seen, but that's
 525                   --  a tricky change to the delicate freezing code.
 526
 527                   --  Look at each declaration following the type up
 528                   --  until the new subprogram body. If any of the
 529                   --  declarations is a body then the type has been
 530                   --  frozen already so the overriding primitive is
 531                   --  illegal.
 532
 533                   while Present (Decl_Item)
 534                     and then (Decl_Item /= Subp_Body)
 535                   loop
 536                      if Comes_From_Source (Decl_Item)
 537                        and then (Nkind (Decl_Item) in N_Proper_Body
 538                                   or else Nkind (Decl_Item) in N_Body_Stub)
 539                      then
 540                         Error_Msg_N ("overriding of& is too late!", Subp);
 541                         Error_Msg_N
 542                           ("\spec should appear immediately after the type!",
 543                            Subp);
 544                         exit;
 545                      end if;
 546
 547                      Next (Decl_Item);
 548                   end loop;
 549
 550                   --  If the subprogram doesn't follow in the list of
 551                   --  declarations including the type then the type
 552                   --  has definitely been frozen already and the body
 553                   --  is illegal.
 554
 555                   if not Present (Decl_Item) then
 556                      Error_Msg_N ("overriding of& is too late!", Subp);
 557                      Error_Msg_N
 558                        ("\spec should appear immediately after the type!",
 559                         Subp);
 560
 561                   elsif Is_Frozen (Subp) then
 562
 563                      --  The subprogram body declares a primitive operation.
 564                      --  if the subprogram is already frozen, we must update
 565                      --  its dispatching information explicitly here. The
 566                      --  information is taken from the overridden subprogram.
 567
 568                      Body_Is_Last_Primitive := True;
 569
 570                      if Present (DTC_Entity (Old_Subp)) then
 571                         Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
 572                         Set_DT_Position (Subp, DT_Position (Old_Subp));
 573                         Insert_After (
 574                           Subp_Body, Fill_DT_Entry (Sloc (Subp_Body), Subp));
 575                      end if;
 576                   end if;
 577                end;
 578
 579             else
 580                Error_Msg_N ("overriding of& is too late!", Subp);
 581                Error_Msg_N
 582                  ("\subprogram spec should appear immediately after the type!",
 583                   Subp);
 584             end if;
 585
 586          --  If the type is not frozen yet and we are not in the overridding
 587          --  case it looks suspiciously like an attempt to define a primitive
 588          --  operation.
 589
 590          elsif not Is_Frozen (Tagged_Type) then
 591             Error_Msg_N
 592               ("?not dispatching (must be defined in a package spec)", Subp);
 593             return;
 594
 595          --  When the type is frozen, it is legitimate to define a new
 596          --  non-primitive operation.
 597
 598          else
 599             return;
 600          end if;
 601
 602       --  Now, we are sure that the scope is a package spec. If the subprogram
 603       --  is declared after the freezing point ot the type that's an error
 604
 605       elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
 606          Error_Msg_N ("this primitive operation is declared too late", Subp);
 607          Error_Msg_NE
 608            ("?no primitive operations for& after this line",
 609             Freeze_Node (Tagged_Type),
 610             Tagged_Type);
 611          return;
 612       end if;
 613
 614       Check_Controlling_Formals (Tagged_Type, Subp);
 615
 616       --  Now it should be a correct primitive operation, put it in the list
 617
 618       if Present (Old_Subp) then
 619          Check_Subtype_Conformant (Subp, Old_Subp);
 620          if (Chars (Subp) = Name_Initialize
 621            or else Chars (Subp) = Name_Adjust
 622            or else Chars (Subp) = Name_Finalize)
 623            and then Is_Controlled (Tagged_Type)
 624            and then not Is_Visibly_Controlled (Tagged_Type)
 625          then
 626             Set_Is_Overriding_Operation (Subp, False);
 627             Error_Msg_NE
 628               ("operation does not override inherited&?", Subp, Subp);
 629          else
 630             Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
 631             Set_Is_Overriding_Operation (Subp);
 632          end if;
 633       else
 634          Add_Dispatching_Operation (Tagged_Type, Subp);
 635       end if;
 636
 637       Set_Is_Dispatching_Operation (Subp, True);
 638
 639       if not Body_Is_Last_Primitive then
 640          Set_DT_Position (Subp, No_Uint);
 641
 642       elsif Has_Controlled_Component (Tagged_Type)
 643         and then
 644          (Chars (Subp) = Name_Initialize
 645            or else Chars (Subp) = Name_Adjust
 646            or else Chars (Subp) = Name_Finalize)
 647       then
 648          declare
 649             F_Node   : constant Node_Id := Freeze_Node (Tagged_Type);
 650             Decl     : Node_Id;
 651             Old_P    : Entity_Id;
 652             Old_Bod  : Node_Id;
 653             Old_Spec : Entity_Id;
 654
 655             C_Names : constant array (1 .. 3) of Name_Id :=
 656                         (Name_Initialize,
 657                          Name_Adjust,
 658                          Name_Finalize);
 659
 660             D_Names : constant array (1 .. 3) of TSS_Name_Type :=
 661                         (TSS_Deep_Initialize,
 662                          TSS_Deep_Adjust,
 663                          TSS_Deep_Finalize);
 664
 665          begin
 666             --  Remove previous controlled function, which was constructed
 667             --  and analyzed when the type was frozen. This requires
 668             --  removing the body of the redefined primitive, as well as
 669             --  its specification if needed (there is no spec created for
 670             --  Deep_Initialize, see exp_ch3.adb). We must also dismantle
 671             --  the exception information that may have been generated for
 672             --  it when front end zero-cost tables are enabled.
 673
 674             for J in D_Names'Range loop
 675                Old_P := TSS (Tagged_Type, D_Names (J));
 676
 677                if Present (Old_P)
 678                 and then Chars (Subp) = C_Names (J)
 679                then
 680                   Old_Bod := Unit_Declaration_Node (Old_P);
 681                   Remove (Old_Bod);
 682                   Set_Is_Eliminated (Old_P);
 683                   Set_Scope (Old_P,  Scope (Current_Scope));
 684
 685                   if Nkind (Old_Bod) = N_Subprogram_Body
 686                     and then Present (Corresponding_Spec (Old_Bod))
 687                   then
 688                      Old_Spec := Corresponding_Spec (Old_Bod);
 689                      Set_Has_Completion             (Old_Spec, False);
 690
 691                      if Exception_Mechanism = Front_End_ZCX_Exceptions then
 692                         Set_Has_Subprogram_Descriptor (Old_Spec, False);
 693                         Set_Handler_Records           (Old_Spec, No_List);
 694                         Set_Is_Eliminated             (Old_Spec);
 695                      end if;
 696                   end if;
 697
 698                end if;
 699             end loop;
 700
 701             Build_Late_Proc (Tagged_Type, Chars (Subp));
 702
 703             --  The new operation is added to the actions of the freeze
 704             --  node for the type, but this node has already been analyzed,
 705             --  so we must retrieve and analyze explicitly the one new body,
 706
 707             if Present (F_Node)
 708               and then Present (Actions (F_Node))
 709             then
 710                Decl := Last (Actions (F_Node));
 711                Analyze (Decl);
 712             end if;
 713          end;
 714       end if;
 715    end Check_Dispatching_Operation;
 716
 717    ------------------------------------------
 718    -- Check_Operation_From_Incomplete_Type --
 719    ------------------------------------------
 720
 721    procedure Check_Operation_From_Incomplete_Type
 722      (Subp : Entity_Id;
 723       Typ  : Entity_Id)
 724    is
 725       Full       : constant Entity_Id := Full_View (Typ);
 726       Parent_Typ : constant Entity_Id := Etype (Full);
 727       Old_Prim   : constant Elist_Id  := Primitive_Operations (Parent_Typ);
 728       New_Prim   : constant Elist_Id  := Primitive_Operations (Full);
 729       Op1, Op2   : Elmt_Id;
 730       Prev       : Elmt_Id := No_Elmt;
 731
 732       function Derives_From (Proc : Entity_Id) return Boolean;
 733       --  Check that Subp has the signature of an operation derived from Proc.
 734       --  Subp has an access parameter that designates Typ.
 735
 736       ------------------
 737       -- Derives_From --
 738       ------------------
 739
 740       function Derives_From (Proc : Entity_Id) return Boolean is
 741          F1, F2 : Entity_Id;
 742
 743       begin
 744          if Chars (Proc) /= Chars (Subp) then
 745             return False;
 746          end if;
 747
 748          F1 := First_Formal (Proc);
 749          F2 := First_Formal (Subp);
 750
 751          while Present (F1) and then Present (F2) loop
 752
 753             if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
 754
 755                if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
 756                   return False;
 757
 758                elsif Designated_Type (Etype (F1)) = Parent_Typ
 759                  and then Designated_Type (Etype (F2)) /= Full
 760                then
 761                   return False;
 762                end if;
 763
 764             elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
 765                return False;
 766
 767             elsif Etype (F1) /= Etype (F2) then
 768                return False;
 769             end if;
 770
 771             Next_Formal (F1);
 772             Next_Formal (F2);
 773          end loop;
 774
 775          return No (F1) and then No (F2);
 776       end Derives_From;
 777
 778    --  Start of processing for Check_Operation_From_Incomplete_Type
 779
 780    begin
 781       --  The operation may override an inherited one, or may be a new one
 782       --  altogether. The inherited operation will have been hidden by the
 783       --  current one at the point of the type derivation, so it does not
 784       --  appear in the list of primitive operations of the type. We have to
 785       --  find the proper place of insertion in the list of primitive opera-
 786       --  tions by iterating over the list for the parent type.
 787
 788       Op1 := First_Elmt (Old_Prim);
 789       Op2 := First_Elmt (New_Prim);
 790
 791       while Present (Op1) and then Present (Op2) loop
 792
 793          if Derives_From (Node (Op1)) then
 794
 795             if No (Prev) then
 796                Prepend_Elmt (Subp, New_Prim);
 797             else
 798                Insert_Elmt_After (Subp, Prev);
 799             end if;
 800
 801             return;
 802          end if;
 803
 804          Prev := Op2;
 805          Next_Elmt (Op1);
 806          Next_Elmt (Op2);
 807       end loop;
 808
 809       --  Operation is a new primitive
 810
 811       Append_Elmt (Subp, New_Prim);
 812    end Check_Operation_From_Incomplete_Type;
 813
 814    ---------------------------------------
 815    -- Check_Operation_From_Private_View --
 816    ---------------------------------------
 817
 818    procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
 819       Tagged_Type : Entity_Id;
 820
 821    begin
 822       if Is_Dispatching_Operation (Alias (Subp)) then
 823          Set_Scope (Subp, Current_Scope);
 824          Tagged_Type := Find_Dispatching_Type (Subp);
 825
 826          if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
 827             Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
 828
 829             --  If Old_Subp isn't already marked as dispatching then
 830             --  this is the case of an operation of an untagged private
 831             --  type fulfilled by a tagged type that overrides an
 832             --  inherited dispatching operation, so we set the necessary
 833             --  dispatching attributes here.
 834
 835             if not Is_Dispatching_Operation (Old_Subp) then
 836
 837                --  If the untagged type has no discriminants, and the full
 838                --  view is constrained, there will be a spurious mismatch
 839                --  of subtypes on the controlling arguments, because the tagged
 840                --  type is the internal base type introduced in the derivation.
 841                --  Use the original type to verify conformance, rather than the
 842                --  base type.
 843
 844                if not Comes_From_Source (Tagged_Type)
 845                  and then Has_Discriminants (Tagged_Type)
 846                then
 847                   declare
 848                      Formal : Entity_Id;
 849                   begin
 850                      Formal := First_Formal (Old_Subp);
 851                      while Present (Formal) loop
 852                         if Tagged_Type = Base_Type (Etype (Formal)) then
 853                            Tagged_Type := Etype (Formal);
 854                         end if;
 855
 856                         Next_Formal (Formal);
 857                      end loop;
 858                   end;
 859
 860                   if Tagged_Type = Base_Type (Etype (Old_Subp)) then
 861                      Tagged_Type := Etype (Old_Subp);
 862                   end if;
 863                end if;
 864
 865                Check_Controlling_Formals (Tagged_Type, Old_Subp);
 866                Set_Is_Dispatching_Operation (Old_Subp, True);
 867                Set_DT_Position (Old_Subp, No_Uint);
 868             end if;
 869
 870             --  If the old subprogram is an explicit renaming of some other
 871             --  entity, it is not overridden by the inherited subprogram.
 872             --  Otherwise, update its alias and other attributes.
 873
 874             if Present (Alias (Old_Subp))
 875               and then Nkind (Unit_Declaration_Node (Old_Subp))
 876                 /= N_Subprogram_Renaming_Declaration
 877             then
 878                Set_Alias (Old_Subp, Alias (Subp));
 879
 880                --  The derived subprogram should inherit the abstractness
 881
 882                --  of the parent subprogram (except in the case of a function
 883                --  returning the type). This sets the abstractness properly
 884                --  for cases where a private extension may have inherited
 885                --  an abstract operation, but the full type is derived from
 886                --  a descendant type and inherits a nonabstract version.
 887
 888                if Etype (Subp) /= Tagged_Type then
 889                   Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
 890                end if;
 891             end if;
 892          end if;
 893       end if;
 894    end Check_Operation_From_Private_View;
 895
 896    --------------------------
 897    -- Find_Controlling_Arg --
 898    --------------------------
 899
 900    function Find_Controlling_Arg (N : Node_Id) return Node_Id is
 901       Orig_Node : constant Node_Id := Original_Node (N);
 902       Typ       : Entity_Id;
 903
 904    begin
 905       if Nkind (Orig_Node) = N_Qualified_Expression then
 906          return Find_Controlling_Arg (Expression (Orig_Node));
 907       end if;
 908
 909       --  Dispatching on result case
 910
 911       if Nkind (Orig_Node) = N_Function_Call
 912         and then Present (Controlling_Argument (Orig_Node))
 913         and then Has_Controlling_Result (Entity (Name (Orig_Node)))
 914       then
 915          return Controlling_Argument (Orig_Node);
 916
 917       --  Normal case
 918
 919       elsif Is_Controlling_Actual (N)
 920         or else
 921          (Nkind (Parent (N)) = N_Qualified_Expression
 922            and then Is_Controlling_Actual (Parent (N)))
 923       then
 924          Typ := Etype (N);
 925
 926          if Is_Access_Type (Typ) then
 927             --  In the case of an Access attribute, use the type of
 928             --  the prefix, since in the case of an actual for an
 929             --  access parameter, the attribute's type may be of a
 930             --  specific designated type, even though the prefix
 931             --  type is class-wide.
 932
 933             if Nkind (N) = N_Attribute_Reference then
 934                Typ := Etype (Prefix (N));
 935
 936             --  An allocator is dispatching if the type of qualified
 937             --  expression is class_wide, in which case this is the
 938             --  controlling type.
 939
 940             elsif Nkind (Orig_Node) = N_Allocator
 941                and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
 942             then
 943                Typ := Etype (Expression (Orig_Node));
 944
 945             else
 946                Typ := Designated_Type (Typ);
 947             end if;
 948          end if;
 949
 950          if Is_Class_Wide_Type (Typ)
 951            or else
 952              (Nkind (Parent (N)) = N_Qualified_Expression
 953                and then Is_Access_Type (Etype (N))
 954                and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
 955          then
 956             return N;
 957          end if;
 958       end if;
 959
 960       return Empty;
 961    end Find_Controlling_Arg;
 962
 963    ---------------------------
 964    -- Find_Dispatching_Type --
 965    ---------------------------
 966
 967    function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
 968       Formal    : Entity_Id;
 969       Ctrl_Type : Entity_Id;
 970
 971    begin
 972       if Present (DTC_Entity (Subp)) then
 973          return Scope (DTC_Entity (Subp));
 974
 975       else
 976          Formal := First_Formal (Subp);
 977          while Present (Formal) loop
 978             Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
 979
 980             if Present (Ctrl_Type) then
 981                return Ctrl_Type;
 982             end if;
 983
 984             Next_Formal (Formal);
 985          end loop;
 986
 987       --  The subprogram may also be dispatching on result
 988
 989          if Present (Etype (Subp)) then
 990             Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
 991
 992             if Present (Ctrl_Type) then
 993                return Ctrl_Type;
 994             end if;
 995          end if;
 996       end if;
 997
 998       return Empty;
 999    end Find_Dispatching_Type;
1000
1001    ---------------------------
1002    -- Is_Dynamically_Tagged --
1003    ---------------------------
1004
1005    function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
1006    begin
1007       return Find_Controlling_Arg (N) /= Empty;
1008    end Is_Dynamically_Tagged;
1009
1010    --------------------------
1011    -- Is_Tag_Indeterminate --
1012    --------------------------
1013
1014    function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
1015       Nam       : Entity_Id;
1016       Actual    : Node_Id;
1017       Orig_Node : constant Node_Id := Original_Node (N);
1018
1019    begin
1020       if Nkind (Orig_Node) = N_Function_Call
1021         and then Is_Entity_Name (Name (Orig_Node))
1022       then
1023          Nam := Entity (Name (Orig_Node));
1024
1025          if not Has_Controlling_Result (Nam) then
1026             return False;
1027
1028          --  An explicit dereference means that the call has already been
1029          --  expanded and there is no tag to propagate.
1030
1031          elsif Nkind (N) = N_Explicit_Dereference then
1032             return False;
1033
1034          --  If there are no actuals, the call is tag-indeterminate
1035
1036          elsif No (Parameter_Associations (Orig_Node)) then
1037             return True;
1038
1039          else
1040             Actual := First_Actual (Orig_Node);
1041
1042             while Present (Actual) loop
1043                if Is_Controlling_Actual (Actual)
1044                  and then not Is_Tag_Indeterminate (Actual)
1045                then
1046                   return False; -- one operand is dispatching
1047                end if;
1048
1049                Next_Actual (Actual);
1050             end loop;
1051
1052             return True;
1053
1054          end if;
1055
1056       elsif Nkind (Orig_Node) = N_Qualified_Expression then
1057          return Is_Tag_Indeterminate (Expression (Orig_Node));
1058
1059       else
1060          return False;
1061       end if;
1062    end Is_Tag_Indeterminate;
1063
1064    ------------------------------------
1065    -- Override_Dispatching_Operation --
1066    ------------------------------------
1067
1068    procedure Override_Dispatching_Operation
1069      (Tagged_Type : Entity_Id;
1070       Prev_Op     : Entity_Id;
1071       New_Op      : Entity_Id)
1072    is
1073       Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
1074
1075    begin
1076       --  Patch the primitive operation list
1077
1078       while Present (Op_Elmt)
1079         and then Node (Op_Elmt) /= Prev_Op
1080       loop
1081          Next_Elmt (Op_Elmt);
1082       end loop;
1083
1084       --  If there is no previous operation to override, the type declaration
1085       --  was malformed, and an error must have been emitted already.
1086
1087       if No (Op_Elmt) then
1088          return;
1089       end if;
1090
1091       Replace_Elmt (Op_Elmt, New_Op);
1092
1093       if (not Is_Package (Current_Scope))
1094         or else not In_Private_Part (Current_Scope)
1095       then
1096          --  Not a private primitive
1097
1098          null;
1099
1100       else pragma Assert (Is_Inherited_Operation (Prev_Op));
1101
1102          --  Make the overriding operation into an alias of the implicit one.
1103          --  In this fashion a call from outside ends up calling the new
1104          --  body even if non-dispatching, and a call from inside calls the
1105          --  overriding operation because it hides the implicit one.
1106          --  To indicate that the body of Prev_Op is never called, set its
1107          --  dispatch table entity to Empty.
1108
1109          Set_Alias (Prev_Op, New_Op);
1110          Set_DTC_Entity (Prev_Op, Empty);
1111          return;
1112       end if;
1113    end Override_Dispatching_Operation;
1114
1115    -------------------
1116    -- Propagate_Tag --
1117    -------------------
1118
1119    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
1120       Call_Node : Node_Id;
1121       Arg       : Node_Id;
1122
1123    begin
1124       if Nkind (Actual) = N_Function_Call then
1125          Call_Node := Actual;
1126
1127       elsif Nkind (Actual) = N_Identifier
1128         and then Nkind (Original_Node (Actual)) = N_Function_Call
1129       then
1130          --  Call rewritten as object declaration when stack-checking
1131          --  is enabled. Propagate tag to expression in declaration, which
1132          --  is original call.
1133
1134          Call_Node := Expression (Parent (Entity (Actual)));
1135
1136       --  Only other possibility is parenthesized or qualified expression
1137
1138       else
1139          Call_Node := Expression (Actual);
1140       end if;
1141
1142       --  Do not set the Controlling_Argument if already set. This happens
1143       --  in the special case of _Input (see Exp_Attr, case Input).
1144
1145       if No (Controlling_Argument (Call_Node)) then
1146          Set_Controlling_Argument (Call_Node, Control);
1147       end if;
1148
1149       Arg := First_Actual (Call_Node);
1150
1151       while Present (Arg) loop
1152          if Is_Tag_Indeterminate (Arg) then
1153             Propagate_Tag (Control,  Arg);
1154          end if;
1155
1156          Next_Actual (Arg);
1157       end loop;
1158
1159       --  Expansion of dispatching calls is suppressed when Java_VM, because
1160       --  the JVM back end directly handles the generation of dispatching
1161       --  calls and would have to undo any expansion to an indirect call.
1162
1163       if not Java_VM then
1164          Expand_Dispatch_Call (Call_Node);
1165       end if;
1166    end Propagate_Tag;
1167
1168 end Sem_Disp;