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 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Debug;    use Debug;
  30 with Elists;   use Elists;
  31 with Einfo;    use Einfo;
  32 with Exp_Disp; use Exp_Disp;
  33 with Exp_Ch7;  use Exp_Ch7;
  34 with Exp_Tss;  use Exp_Tss;
  35 with Errout;   use Errout;
  36 with Hostparm; use Hostparm;
  37 with Nlists;   use Nlists;
  38 with Opt;      use Opt;
  39 with Output;   use Output;
  40 with Sem;      use Sem;
  41 with Sem_Ch6;  use Sem_Ch6;
  42 with Sem_Eval; use Sem_Eval;
  43 with Sem_Util; use Sem_Util;
  44 with Snames;   use Snames;
  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 (1) 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    begin
 428       if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
 429          return;
 430       end if;
 431
 432       Set_Is_Dispatching_Operation (Subp, False);
 433       Tagged_Type := Find_Dispatching_Type (Subp);
 434
 435       --  If Subp is derived from a dispatching operation then it should
 436       --  always be treated as dispatching. In this case various checks
 437       --  below will be bypassed. Makes sure that late declarations for
 438       --  inherited private subprograms are treated as dispatching, even
 439       --  if the associated tagged type is already frozen.
 440
 441       Has_Dispatching_Parent := Present (Alias (Subp))
 442         and then Is_Dispatching_Operation (Alias (Subp));
 443
 444       if No (Tagged_Type) then
 445          return;
 446
 447       --  The subprograms build internally after the freezing point (such as
 448       --  the Init procedure) are not primitives
 449
 450       elsif Is_Frozen (Tagged_Type)
 451         and then not Comes_From_Source (Subp)
 452         and then not Has_Dispatching_Parent
 453       then
 454          return;
 455
 456       --  The operation may be a child unit, whose scope is the defining
 457       --  package, but which is not a primitive operation of the type.
 458
 459       elsif Is_Child_Unit (Subp) then
 460          return;
 461
 462       --  If the subprogram is not defined in a package spec, the only case
 463       --  where it can be a dispatching op is when it overrides an operation
 464       --  before the freezing point of the type.
 465
 466       elsif ((not Is_Package (Scope (Subp)))
 467               or else In_Package_Body (Scope (Subp)))
 468         and then not Has_Dispatching_Parent
 469       then
 470          if not Comes_From_Source (Subp)
 471            or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
 472          then
 473             null;
 474
 475          --  If the type is already frozen, the overriding is not allowed
 476          --  except when Old_Subp is not a dispatching operation (which
 477          --  can occur when Old_Subp was inherited by an untagged type).
 478          --  However, a body with no previous spec freezes the type "after"
 479          --  its declaration, and therefore is a legal overriding (unless
 480          --  the type has already been frozen). Only the first such body
 481          --  is legal.
 482
 483          elsif Present (Old_Subp)
 484            and then Is_Dispatching_Operation (Old_Subp)
 485          then
 486             if Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
 487               and then Comes_From_Source (Subp)
 488             then
 489                declare
 490                   Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
 491                   Decl_Item : Node_Id := Next (Parent (Tagged_Type));
 492
 493                begin
 494                   --  ??? The checks here for whether the type has been
 495                   --  frozen prior to the new body are not complete. It's
 496                   --  not simple to check frozenness at this point since
 497                   --  the body has already caused the type to be prematurely
 498                   --  frozen in Analyze_Declarations, but we're forced to
 499                   --  recheck this here because of the odd rule interpretation
 500                   --  that allows the overriding if the type wasn't frozen
 501                   --  prior to the body. The freezing action should probably
 502                   --  be delayed until after the spec is seen, but that's
 503                   --  a tricky change to the delicate freezing code.
 504
 505                   --  Look at each declaration following the type up
 506                   --  until the new subprogram body. If any of the
 507                   --  declarations is a body then the type has been
 508                   --  frozen already so the overriding primitive is
 509                   --  illegal.
 510
 511                   while Present (Decl_Item)
 512                     and then (Decl_Item /= Subp_Body)
 513                   loop
 514                      if Comes_From_Source (Decl_Item)
 515                        and then (Nkind (Decl_Item) in N_Proper_Body
 516                                   or else Nkind (Decl_Item) in N_Body_Stub)
 517                      then
 518                         Error_Msg_N ("overriding of& is too late!", Subp);
 519                         Error_Msg_N
 520                           ("\spec should appear immediately after the type!",
 521                            Subp);
 522                         exit;
 523                      end if;
 524
 525                      Next (Decl_Item);
 526                   end loop;
 527
 528                   --  If the subprogram doesn't follow in the list of
 529                   --  declarations including the type then the type
 530                   --  has definitely been frozen already and the body
 531                   --  is illegal.
 532
 533                   if not Present (Decl_Item) then
 534                      Error_Msg_N ("overriding of& is too late!", Subp);
 535                      Error_Msg_N
 536                        ("\spec should appear immediately after the type!",
 537                         Subp);
 538
 539                   elsif Is_Frozen (Subp) then
 540
 541                      --  the subprogram body declares a primitive operation.
 542                      --  if the subprogram is already frozen, we must update
 543                      --  its dispatching information explicitly here. The
 544                      --  information is taken from the overridden subprogram.
 545
 546                      Body_Is_Last_Primitive := True;
 547
 548                      if Present (DTC_Entity (Old_Subp)) then
 549                         Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
 550                         Set_DT_Position (Subp, DT_Position (Old_Subp));
 551                         Insert_After (
 552                           Subp_Body, Fill_DT_Entry (Sloc (Subp_Body), Subp));
 553                      end if;
 554                   end if;
 555                end;
 556
 557             else
 558                Error_Msg_N ("overriding of& is too late!", Subp);
 559                Error_Msg_N
 560                  ("\subprogram spec should appear immediately after the type!",
 561                   Subp);
 562             end if;
 563
 564          --  If the type is not frozen yet and we are not in the overridding
 565          --  case it looks suspiciously like an attempt to define a primitive
 566          --  operation.
 567
 568          elsif not Is_Frozen (Tagged_Type) then
 569             Error_Msg_N
 570               ("?not dispatching (must be defined in a package spec)", Subp);
 571             return;
 572
 573          --  When the type is frozen, it is legitimate to define a new
 574          --  non-primitive operation.
 575
 576          else
 577             return;
 578          end if;
 579
 580       --  Now, we are sure that the scope is a package spec. If the subprogram
 581       --  is declared after the freezing point ot the type that's an error
 582
 583       elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
 584          Error_Msg_N ("this primitive operation is declared too late", Subp);
 585          Error_Msg_NE
 586            ("?no primitive operations for& after this line",
 587             Freeze_Node (Tagged_Type),
 588             Tagged_Type);
 589          return;
 590       end if;
 591
 592       Check_Controlling_Formals (Tagged_Type, Subp);
 593
 594       --  Now it should be a correct primitive operation, put it in the list
 595
 596       if Present (Old_Subp) then
 597          Check_Subtype_Conformant (Subp, Old_Subp);
 598          Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
 599
 600       else
 601          Add_Dispatching_Operation (Tagged_Type, Subp);
 602       end if;
 603
 604       Set_Is_Dispatching_Operation (Subp, True);
 605
 606       if not Body_Is_Last_Primitive then
 607          Set_DT_Position (Subp, No_Uint);
 608
 609       elsif Has_Controlled_Component (Tagged_Type)
 610         and then
 611          (Chars (Subp) = Name_Initialize
 612            or else Chars (Subp) = Name_Adjust
 613            or else Chars (Subp) = Name_Finalize)
 614       then
 615          declare
 616             F_Node   : Node_Id := Freeze_Node (Tagged_Type);
 617             Decl     : Node_Id;
 618             Old_P    : Entity_Id;
 619             Old_Bod  : Node_Id;
 620             Old_Spec : Entity_Id;
 621
 622             C_Names : constant array (1 .. 3) of Name_Id :=
 623                         (Name_Initialize,
 624                          Name_Adjust,
 625                          Name_Finalize);
 626
 627             D_Names : constant array (1 .. 3) of Name_Id :=
 628                         (Name_uDeep_Initialize,
 629                          Name_uDeep_Adjust,
 630                          Name_uDeep_Finalize);
 631
 632          begin
 633             --  Remove previous controlled function, which was constructed
 634             --  and analyzed when the type was frozen. This requires
 635             --  removing the body of the redefined primitive, as well as its
 636             --  specification if needed (there is no spec created for
 637             --  Deep_Initialize, see exp_ch3.adb). We must also dismantle
 638             --  the exception information that may have been generated for it
 639             --  when zero-cost is enabled.
 640
 641             for J in D_Names'Range loop
 642                Old_P := TSS (Tagged_Type, D_Names (J));
 643
 644                if Present (Old_P)
 645                 and then Chars (Subp) = C_Names (J)
 646                then
 647                   Old_Bod := Unit_Declaration_Node (Old_P);
 648                   Remove (Old_Bod);
 649                   Set_Is_Eliminated (Old_P);
 650                   Set_Scope (Old_P,  Scope (Current_Scope));
 651
 652                   if Nkind (Old_Bod) = N_Subprogram_Body
 653                     and then Present (Corresponding_Spec (Old_Bod))
 654                   then
 655                      Old_Spec := Corresponding_Spec (Old_Bod);
 656                      Set_Has_Completion             (Old_Spec, False);
 657
 658                      if Exception_Mechanism = Front_End_ZCX then
 659                         Set_Has_Subprogram_Descriptor (Old_Spec, False);
 660                         Set_Handler_Records           (Old_Spec, No_List);
 661                         Set_Is_Eliminated             (Old_Spec);
 662                      end if;
 663                   end if;
 664
 665                end if;
 666             end loop;
 667
 668             Build_Late_Proc (Tagged_Type, Chars (Subp));
 669
 670             --  The new operation is added to the actions of the freeze
 671             --  node for the type, but this node has already been analyzed,
 672             --  so we must retrieve and analyze explicitly the one new body,
 673
 674             if Present (F_Node)
 675               and then Present (Actions (F_Node))
 676             then
 677                Decl := Last (Actions (F_Node));
 678                Analyze (Decl);
 679             end if;
 680          end;
 681       end if;
 682    end Check_Dispatching_Operation;
 683
 684    ------------------------------------------
 685    -- Check_Operation_From_Incomplete_Type --
 686    ------------------------------------------
 687
 688    procedure Check_Operation_From_Incomplete_Type
 689      (Subp : Entity_Id;
 690       Typ  : Entity_Id)
 691    is
 692       Full       : constant Entity_Id := Full_View (Typ);
 693       Parent_Typ : constant Entity_Id := Etype (Full);
 694       Old_Prim   : constant Elist_Id  := Primitive_Operations (Parent_Typ);
 695       New_Prim   : constant Elist_Id  := Primitive_Operations (Full);
 696       Op1, Op2   : Elmt_Id;
 697       Prev       : Elmt_Id := No_Elmt;
 698
 699       function Derives_From (Proc : Entity_Id) return Boolean;
 700       --  Check that Subp has the signature of an operation derived from Proc.
 701       --  Subp has an access parameter that designates Typ.
 702
 703       ------------------
 704       -- Derives_From --
 705       ------------------
 706
 707       function Derives_From (Proc : Entity_Id) return Boolean is
 708          F1, F2 : Entity_Id;
 709
 710       begin
 711          if Chars (Proc) /= Chars (Subp) then
 712             return False;
 713          end if;
 714
 715          F1 := First_Formal (Proc);
 716          F2 := First_Formal (Subp);
 717
 718          while Present (F1) and then Present (F2) loop
 719
 720             if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
 721
 722                if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
 723                   return False;
 724
 725                elsif Designated_Type (Etype (F1)) = Parent_Typ
 726                  and then Designated_Type (Etype (F2)) /= Full
 727                then
 728                   return False;
 729                end if;
 730
 731             elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
 732                return False;
 733
 734             elsif Etype (F1) /= Etype (F2) then
 735                return False;
 736             end if;
 737
 738             Next_Formal (F1);
 739             Next_Formal (F2);
 740          end loop;
 741
 742          return No (F1) and then No (F2);
 743       end Derives_From;
 744
 745    --  Start of processing for Check_Operation_From_Incomplete_Type
 746
 747    begin
 748       --  The operation may override an inherited one, or may be a new one
 749       --  altogether. The inherited operation will have been hidden by the
 750       --  current one at the point of the type derivation, so it does not
 751       --  appear in the list of primitive operations of the type. We have to
 752       --  find the proper place of insertion in the list of primitive opera-
 753       --  tions by iterating over the list for the parent type.
 754
 755       Op1 := First_Elmt (Old_Prim);
 756       Op2 := First_Elmt (New_Prim);
 757
 758       while Present (Op1) and then Present (Op2) loop
 759
 760          if Derives_From (Node (Op1)) then
 761
 762             if No (Prev) then
 763                Prepend_Elmt (Subp, New_Prim);
 764             else
 765                Insert_Elmt_After (Subp, Prev);
 766             end if;
 767
 768             return;
 769          end if;
 770
 771          Prev := Op2;
 772          Next_Elmt (Op1);
 773          Next_Elmt (Op2);
 774       end loop;
 775
 776       --  Operation is a new primitive.
 777
 778       Append_Elmt (Subp, New_Prim);
 779
 780    end Check_Operation_From_Incomplete_Type;
 781
 782    ---------------------------------------
 783    -- Check_Operation_From_Private_View --
 784    ---------------------------------------
 785
 786    procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
 787       Tagged_Type : Entity_Id;
 788
 789    begin
 790       if Is_Dispatching_Operation (Alias (Subp)) then
 791          Set_Scope (Subp, Current_Scope);
 792          Tagged_Type := Find_Dispatching_Type (Subp);
 793
 794          if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
 795             Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
 796
 797             --  If Old_Subp isn't already marked as dispatching then
 798             --  this is the case of an operation of an untagged private
 799             --  type fulfilled by a tagged type that overrides an
 800             --  inherited dispatching operation, so we set the necessary
 801             --  dispatching attributes here.
 802
 803             if not Is_Dispatching_Operation (Old_Subp) then
 804                Check_Controlling_Formals (Tagged_Type, Old_Subp);
 805                Set_Is_Dispatching_Operation (Old_Subp, True);
 806                Set_DT_Position (Old_Subp, No_Uint);
 807             end if;
 808
 809             --  If the old subprogram is an explicit renaming of some other
 810             --  entity, it is not overridden by the inherited subprogram.
 811             --  Otherwise, update its alias and other attributes.
 812
 813             if Present (Alias (Old_Subp))
 814               and then Nkind (Unit_Declaration_Node (Old_Subp))
 815                 /= N_Subprogram_Renaming_Declaration
 816             then
 817                Set_Alias (Old_Subp, Alias (Subp));
 818
 819                --  The derived subprogram should inherit the abstractness
 820                --  of the parent subprogram (except in the case of a function
 821                --  returning the type). This sets the abstractness properly
 822                --  for cases where a private extension may have inherited
 823                --  an abstract operation, but the full type is derived from
 824                --  a descendant type and inherits a nonabstract version.
 825
 826                if Etype (Subp) /= Tagged_Type then
 827                   Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
 828                end if;
 829             end if;
 830          end if;
 831       end if;
 832    end Check_Operation_From_Private_View;
 833
 834    --------------------------
 835    -- Find_Controlling_Arg --
 836    --------------------------
 837
 838    function Find_Controlling_Arg (N : Node_Id) return Node_Id is
 839       Orig_Node : constant Node_Id := Original_Node (N);
 840       Typ       : Entity_Id;
 841
 842    begin
 843       if Nkind (Orig_Node) = N_Qualified_Expression then
 844          return Find_Controlling_Arg (Expression (Orig_Node));
 845       end if;
 846
 847       --  Dispatching on result case
 848
 849       if Nkind (Orig_Node) = N_Function_Call
 850         and then Present (Controlling_Argument (Orig_Node))
 851         and then Has_Controlling_Result (Entity (Name (Orig_Node)))
 852       then
 853          return Controlling_Argument (Orig_Node);
 854
 855       --  Normal case
 856
 857       elsif Is_Controlling_Actual (N) then
 858          Typ := Etype (N);
 859
 860          if Is_Access_Type (Typ) then
 861             --  In the case of an Access attribute, use the type of
 862             --  the prefix, since in the case of an actual for an
 863             --  access parameter, the attribute's type may be of a
 864             --  specific designated type, even though the prefix
 865             --  type is class-wide.
 866
 867             if Nkind (N) = N_Attribute_Reference then
 868                Typ := Etype (Prefix (N));
 869
 870             --  An allocator is dispatching if the type of qualified
 871             --  expression is class_wide, in which case this is the
 872             --  controlling type.
 873
 874             elsif Nkind (Orig_Node) = N_Allocator
 875                and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
 876             then
 877                Typ := Etype (Expression (Orig_Node));
 878
 879             else
 880                Typ := Designated_Type (Typ);
 881             end if;
 882          end if;
 883
 884          if Is_Class_Wide_Type (Typ) then
 885             return N;
 886          end if;
 887       end if;
 888
 889       return Empty;
 890    end Find_Controlling_Arg;
 891
 892    ---------------------------
 893    -- Find_Dispatching_Type --
 894    ---------------------------
 895
 896    function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
 897       Formal    : Entity_Id;
 898       Ctrl_Type : Entity_Id;
 899
 900    begin
 901       if Present (DTC_Entity (Subp)) then
 902          return Scope (DTC_Entity (Subp));
 903
 904       else
 905          Formal := First_Formal (Subp);
 906          while Present (Formal) loop
 907             Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
 908
 909             if Present (Ctrl_Type) then
 910                return Ctrl_Type;
 911             end if;
 912
 913             Next_Formal (Formal);
 914          end loop;
 915
 916       --  The subprogram may also be dispatching on result
 917
 918          if Present (Etype (Subp)) then
 919             Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
 920
 921             if Present (Ctrl_Type) then
 922                return Ctrl_Type;
 923             end if;
 924          end if;
 925       end if;
 926
 927       return Empty;
 928    end Find_Dispatching_Type;
 929
 930    ---------------------------
 931    -- Is_Dynamically_Tagged --
 932    ---------------------------
 933
 934    function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
 935    begin
 936       return Find_Controlling_Arg (N) /= Empty;
 937    end Is_Dynamically_Tagged;
 938
 939    --------------------------
 940    -- Is_Tag_Indeterminate --
 941    --------------------------
 942
 943    function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
 944       Nam       : Entity_Id;
 945       Actual    : Node_Id;
 946       Orig_Node : constant Node_Id := Original_Node (N);
 947
 948    begin
 949       if Nkind (Orig_Node) = N_Function_Call
 950         and then Is_Entity_Name (Name (Orig_Node))
 951       then
 952          Nam := Entity (Name (Orig_Node));
 953
 954          if not Has_Controlling_Result (Nam) then
 955             return False;
 956
 957          --  If there are no actuals, the call is tag-indeterminate
 958
 959          elsif No (Parameter_Associations (Orig_Node)) then
 960             return True;
 961
 962          else
 963             Actual := First_Actual (Orig_Node);
 964
 965             while Present (Actual) loop
 966                if Is_Controlling_Actual (Actual)
 967                  and then not Is_Tag_Indeterminate (Actual)
 968                then
 969                   return False; -- one operand is dispatching
 970                end if;
 971
 972                Next_Actual (Actual);
 973             end loop;
 974
 975             return True;
 976
 977          end if;
 978
 979       elsif Nkind (Orig_Node) = N_Qualified_Expression then
 980          return Is_Tag_Indeterminate (Expression (Orig_Node));
 981
 982       else
 983          return False;
 984       end if;
 985    end Is_Tag_Indeterminate;
 986
 987    ------------------------------------
 988    -- Override_Dispatching_Operation --
 989    ------------------------------------
 990
 991    procedure Override_Dispatching_Operation
 992      (Tagged_Type : Entity_Id;
 993       Prev_Op     : Entity_Id;
 994       New_Op      : Entity_Id)
 995    is
 996       Op_Elmt   : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
 997
 998    begin
 999       --  Patch the primitive operation list
1000
1001       while Present (Op_Elmt)
1002         and then Node (Op_Elmt) /= Prev_Op
1003       loop
1004          Next_Elmt (Op_Elmt);
1005       end loop;
1006
1007       --  If there is no previous operation to override, the type declaration
1008       --  was malformed, and an error must have been emitted already.
1009
1010       if No (Op_Elmt) then
1011          return;
1012       end if;
1013
1014       Replace_Elmt (Op_Elmt, New_Op);
1015
1016       if (not Is_Package (Current_Scope))
1017         or else not In_Private_Part (Current_Scope)
1018       then
1019          --  Not a private primitive
1020
1021          null;
1022
1023       else pragma Assert (Is_Inherited_Operation (Prev_Op));
1024
1025          --  Make the overriding operation into an alias of the implicit one.
1026          --  In this fashion a call from outside ends up calling the new
1027          --  body even if non-dispatching, and a call from inside calls the
1028          --  overriding operation because it hides the implicit one.
1029          --  To indicate that the body of Prev_Op is never called, set its
1030          --  dispatch table entity to Empty.
1031
1032          Set_Alias (Prev_Op, New_Op);
1033          Set_DTC_Entity (Prev_Op, Empty);
1034          return;
1035       end if;
1036    end Override_Dispatching_Operation;
1037
1038    -------------------
1039    -- Propagate_Tag --
1040    -------------------
1041
1042    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
1043       Call_Node : Node_Id;
1044       Arg       : Node_Id;
1045
1046    begin
1047       if Nkind (Actual) = N_Function_Call then
1048          Call_Node := Actual;
1049
1050       elsif Nkind (Actual) = N_Identifier
1051         and then Nkind (Original_Node (Actual)) = N_Function_Call
1052       then
1053          --  Call rewritten as object declaration when stack-checking
1054          --  is enabled. Propagate tag to expression in declaration, which
1055          --  is original call.
1056
1057          Call_Node := Expression (Parent (Entity (Actual)));
1058
1059       --  Only other possibility is parenthesized or qualified expression
1060
1061       else
1062          Call_Node := Expression (Actual);
1063       end if;
1064
1065       --  Do not set the Controlling_Argument if already set. This happens
1066       --  in the special case of _Input (see Exp_Attr, case Input).
1067
1068       if No (Controlling_Argument (Call_Node)) then
1069          Set_Controlling_Argument (Call_Node, Control);
1070       end if;
1071
1072       Arg := First_Actual (Call_Node);
1073
1074       while Present (Arg) loop
1075          if Is_Tag_Indeterminate (Arg) then
1076             Propagate_Tag (Control,  Arg);
1077          end if;
1078
1079          Next_Actual (Arg);
1080       end loop;
1081
1082       --  Expansion of dispatching calls is suppressed when Java_VM, because
1083       --  the JVM back end directly handles the generation of dispatching
1084       --  calls and would have to undo any expansion to an indirect call.
1085
1086       if not Java_VM then
1087          Expand_Dispatch_Call (Call_Node);
1088       end if;
1089    end Propagate_Tag;
1090
1091 end Sem_Disp;