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