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