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