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