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-2003 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 (14) 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 :=
 441          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          Set_Is_Overriding_Operation (Subp);
 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   : constant 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 TSS_Name_Type :=
 628                         (TSS_Deep_Initialize,
 629                          TSS_Deep_Adjust,
 630                          TSS_Deep_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
 636             --  its 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
 639             --  it when front end zero-cost tables are 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_Exceptions 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    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
 804                --  If the untagged type has no discriminants, and the full
 805                --  view is constrained, there will be a spurious mismatch
 806                --  of subtypes on the controlling arguments, because the tagged
 807                --  type is the internal base type introduced in the derivation.
 808                --  Use the original type to verify conformance, rather than the
 809                --  base type.
 810
 811                if not Comes_From_Source (Tagged_Type)
 812                  and then Has_Discriminants (Tagged_Type)
 813                then
 814                   declare
 815                      Formal : Entity_Id;
 816                   begin
 817                      Formal := First_Formal (Old_Subp);
 818                      while Present (Formal) loop
 819                         if Tagged_Type = Base_Type (Etype (Formal)) then
 820                            Tagged_Type := Etype (Formal);
 821                         end if;
 822
 823                         Next_Formal (Formal);
 824                      end loop;
 825                   end;
 826
 827                   if Tagged_Type = Base_Type (Etype (Old_Subp)) then
 828                      Tagged_Type := Etype (Old_Subp);
 829                   end if;
 830                end if;
 831
 832                Check_Controlling_Formals (Tagged_Type, Old_Subp);
 833                Set_Is_Dispatching_Operation (Old_Subp, True);
 834                Set_DT_Position (Old_Subp, No_Uint);
 835             end if;
 836
 837             --  If the old subprogram is an explicit renaming of some other
 838             --  entity, it is not overridden by the inherited subprogram.
 839             --  Otherwise, update its alias and other attributes.
 840
 841             if Present (Alias (Old_Subp))
 842               and then Nkind (Unit_Declaration_Node (Old_Subp))
 843                 /= N_Subprogram_Renaming_Declaration
 844             then
 845                Set_Alias (Old_Subp, Alias (Subp));
 846
 847                --  The derived subprogram should inherit the abstractness
 848
 849                --  of the parent subprogram (except in the case of a function
 850                --  returning the type). This sets the abstractness properly
 851                --  for cases where a private extension may have inherited
 852                --  an abstract operation, but the full type is derived from
 853                --  a descendant type and inherits a nonabstract version.
 854
 855                if Etype (Subp) /= Tagged_Type then
 856                   Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
 857                end if;
 858             end if;
 859          end if;
 860       end if;
 861    end Check_Operation_From_Private_View;
 862
 863    --------------------------
 864    -- Find_Controlling_Arg --
 865    --------------------------
 866
 867    function Find_Controlling_Arg (N : Node_Id) return Node_Id is
 868       Orig_Node : constant Node_Id := Original_Node (N);
 869       Typ       : Entity_Id;
 870
 871    begin
 872       if Nkind (Orig_Node) = N_Qualified_Expression then
 873          return Find_Controlling_Arg (Expression (Orig_Node));
 874       end if;
 875
 876       --  Dispatching on result case
 877
 878       if Nkind (Orig_Node) = N_Function_Call
 879         and then Present (Controlling_Argument (Orig_Node))
 880         and then Has_Controlling_Result (Entity (Name (Orig_Node)))
 881       then
 882          return Controlling_Argument (Orig_Node);
 883
 884       --  Normal case
 885
 886       elsif Is_Controlling_Actual (N)
 887         or else
 888          (Nkind (Parent (N)) = N_Qualified_Expression
 889            and then Is_Controlling_Actual (Parent (N)))
 890       then
 891          Typ := Etype (N);
 892
 893          if Is_Access_Type (Typ) then
 894             --  In the case of an Access attribute, use the type of
 895             --  the prefix, since in the case of an actual for an
 896             --  access parameter, the attribute's type may be of a
 897             --  specific designated type, even though the prefix
 898             --  type is class-wide.
 899
 900             if Nkind (N) = N_Attribute_Reference then
 901                Typ := Etype (Prefix (N));
 902
 903             --  An allocator is dispatching if the type of qualified
 904             --  expression is class_wide, in which case this is the
 905             --  controlling type.
 906
 907             elsif Nkind (Orig_Node) = N_Allocator
 908                and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
 909             then
 910                Typ := Etype (Expression (Orig_Node));
 911
 912             else
 913                Typ := Designated_Type (Typ);
 914             end if;
 915          end if;
 916
 917          if Is_Class_Wide_Type (Typ)
 918            or else
 919              (Nkind (Parent (N)) = N_Qualified_Expression
 920                and then Is_Access_Type (Etype (N))
 921                and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
 922          then
 923             return N;
 924          end if;
 925       end if;
 926
 927       return Empty;
 928    end Find_Controlling_Arg;
 929
 930    ---------------------------
 931    -- Find_Dispatching_Type --
 932    ---------------------------
 933
 934    function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
 935       Formal    : Entity_Id;
 936       Ctrl_Type : Entity_Id;
 937
 938    begin
 939       if Present (DTC_Entity (Subp)) then
 940          return Scope (DTC_Entity (Subp));
 941
 942       else
 943          Formal := First_Formal (Subp);
 944          while Present (Formal) loop
 945             Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
 946
 947             if Present (Ctrl_Type) then
 948                return Ctrl_Type;
 949             end if;
 950
 951             Next_Formal (Formal);
 952          end loop;
 953
 954       --  The subprogram may also be dispatching on result
 955
 956          if Present (Etype (Subp)) then
 957             Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
 958
 959             if Present (Ctrl_Type) then
 960                return Ctrl_Type;
 961             end if;
 962          end if;
 963       end if;
 964
 965       return Empty;
 966    end Find_Dispatching_Type;
 967
 968    ---------------------------
 969    -- Is_Dynamically_Tagged --
 970    ---------------------------
 971
 972    function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
 973    begin
 974       return Find_Controlling_Arg (N) /= Empty;
 975    end Is_Dynamically_Tagged;
 976
 977    --------------------------
 978    -- Is_Tag_Indeterminate --
 979    --------------------------
 980
 981    function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
 982       Nam       : Entity_Id;
 983       Actual    : Node_Id;
 984       Orig_Node : constant Node_Id := Original_Node (N);
 985
 986    begin
 987       if Nkind (Orig_Node) = N_Function_Call
 988         and then Is_Entity_Name (Name (Orig_Node))
 989       then
 990          Nam := Entity (Name (Orig_Node));
 991
 992          if not Has_Controlling_Result (Nam) then
 993             return False;
 994
 995          --  An explicit dereference means that the call has already been
 996          --  expanded and there is no tag to propagate.
 997
 998          elsif Nkind (N) = N_Explicit_Dereference then
 999             return False;
1000
1001          --  If there are no actuals, the call is tag-indeterminate
1002
1003          elsif No (Parameter_Associations (Orig_Node)) then
1004             return True;
1005
1006          else
1007             Actual := First_Actual (Orig_Node);
1008
1009             while Present (Actual) loop
1010                if Is_Controlling_Actual (Actual)
1011                  and then not Is_Tag_Indeterminate (Actual)
1012                then
1013                   return False; -- one operand is dispatching
1014                end if;
1015
1016                Next_Actual (Actual);
1017             end loop;
1018
1019             return True;
1020
1021          end if;
1022
1023       elsif Nkind (Orig_Node) = N_Qualified_Expression then
1024          return Is_Tag_Indeterminate (Expression (Orig_Node));
1025
1026       else
1027          return False;
1028       end if;
1029    end Is_Tag_Indeterminate;
1030
1031    ------------------------------------
1032    -- Override_Dispatching_Operation --
1033    ------------------------------------
1034
1035    procedure Override_Dispatching_Operation
1036      (Tagged_Type : Entity_Id;
1037       Prev_Op     : Entity_Id;
1038       New_Op      : Entity_Id)
1039    is
1040       Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
1041
1042    begin
1043       --  Patch the primitive operation list
1044
1045       while Present (Op_Elmt)
1046         and then Node (Op_Elmt) /= Prev_Op
1047       loop
1048          Next_Elmt (Op_Elmt);
1049       end loop;
1050
1051       --  If there is no previous operation to override, the type declaration
1052       --  was malformed, and an error must have been emitted already.
1053
1054       if No (Op_Elmt) then
1055          return;
1056       end if;
1057
1058       Replace_Elmt (Op_Elmt, New_Op);
1059
1060       if (not Is_Package (Current_Scope))
1061         or else not In_Private_Part (Current_Scope)
1062       then
1063          --  Not a private primitive
1064
1065          null;
1066
1067       else pragma Assert (Is_Inherited_Operation (Prev_Op));
1068
1069          --  Make the overriding operation into an alias of the implicit one.
1070          --  In this fashion a call from outside ends up calling the new
1071          --  body even if non-dispatching, and a call from inside calls the
1072          --  overriding operation because it hides the implicit one.
1073          --  To indicate that the body of Prev_Op is never called, set its
1074          --  dispatch table entity to Empty.
1075
1076          Set_Alias (Prev_Op, New_Op);
1077          Set_DTC_Entity (Prev_Op, Empty);
1078          return;
1079       end if;
1080    end Override_Dispatching_Operation;
1081
1082    -------------------
1083    -- Propagate_Tag --
1084    -------------------
1085
1086    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
1087       Call_Node : Node_Id;
1088       Arg       : Node_Id;
1089
1090    begin
1091       if Nkind (Actual) = N_Function_Call then
1092          Call_Node := Actual;
1093
1094       elsif Nkind (Actual) = N_Identifier
1095         and then Nkind (Original_Node (Actual)) = N_Function_Call
1096       then
1097          --  Call rewritten as object declaration when stack-checking
1098          --  is enabled. Propagate tag to expression in declaration, which
1099          --  is original call.
1100
1101          Call_Node := Expression (Parent (Entity (Actual)));
1102
1103       --  Only other possibility is parenthesized or qualified expression
1104
1105       else
1106          Call_Node := Expression (Actual);
1107       end if;
1108
1109       --  Do not set the Controlling_Argument if already set. This happens
1110       --  in the special case of _Input (see Exp_Attr, case Input).
1111
1112       if No (Controlling_Argument (Call_Node)) then
1113          Set_Controlling_Argument (Call_Node, Control);
1114       end if;
1115
1116       Arg := First_Actual (Call_Node);
1117
1118       while Present (Arg) loop
1119          if Is_Tag_Indeterminate (Arg) then
1120             Propagate_Tag (Control,  Arg);
1121          end if;
1122
1123          Next_Actual (Arg);
1124       end loop;
1125
1126       --  Expansion of dispatching calls is suppressed when Java_VM, because
1127       --  the JVM back end directly handles the generation of dispatching
1128       --  calls and would have to undo any expansion to an indirect call.
1129
1130       if not Java_VM then
1131          Expand_Dispatch_Call (Call_Node);
1132       end if;
1133    end Propagate_Tag;
1134
1135 end Sem_Disp;