gcc/ada/sem_ch4.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C H 4                               --
   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 Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Util; use Exp_Util;
  34 with Fname;    use Fname;
  35 with Itypes;   use Itypes;
  36 with Lib;      use Lib;
  37 with Lib.Xref; use Lib.Xref;
  38 with Namet;    use Namet;
  39 with Nlists;   use Nlists;
  40 with Nmake;    use Nmake;
  41 with Opt;      use Opt;
  42 with Output;   use Output;
  43 with Restrict; use Restrict;
  44 with Rident;   use Rident;
  45 with Sem;      use Sem;
  46 with Sem_Cat;  use Sem_Cat;
  47 with Sem_Ch3;  use Sem_Ch3;
  48 with Sem_Ch8;  use Sem_Ch8;
  49 with Sem_Dist; use Sem_Dist;
  50 with Sem_Eval; use Sem_Eval;
  51 with Sem_Res;  use Sem_Res;
  52 with Sem_Util; use Sem_Util;
  53 with Sem_Type; use Sem_Type;
  54 with Stand;    use Stand;
  55 with Sinfo;    use Sinfo;
  56 with Snames;   use Snames;
  57 with Tbuild;   use Tbuild;
  58
  59 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
  60
  61 package body Sem_Ch4 is
  62
  63    -----------------------
  64    -- Local Subprograms --
  65    -----------------------
  66
  67    procedure Analyze_Expression (N : Node_Id);
  68    --  For expressions that are not names, this is just a call to analyze.
  69    --  If the expression is a name, it may be a call to a parameterless
  70    --  function, and if so must be converted into an explicit call node
  71    --  and analyzed as such. This deproceduring must be done during the first
  72    --  pass of overload resolution, because otherwise a procedure call with
  73    --  overloaded actuals may fail to resolve. See 4327-001 for an example.
  74
  75    procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
  76    --  Analyze a call of the form "+"(x, y), etc. The prefix of the call
  77    --  is an operator name or an expanded name whose selector is an operator
  78    --  name, and one possible interpretation is as a predefined operator.
  79
  80    procedure Analyze_Overloaded_Selected_Component (N : Node_Id);
  81    --  If the prefix of a selected_component is overloaded, the proper
  82    --  interpretation that yields a record type with the proper selector
  83    --  name must be selected.
  84
  85    procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id);
  86    --  Procedure to analyze a user defined binary operator, which is resolved
  87    --  like a function, but instead of a list of actuals it is presented
  88    --  with the left and right operands of an operator node.
  89
  90    procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id);
  91    --  Procedure to analyze a user defined unary operator, which is resolved
  92    --  like a function, but instead of a list of actuals, it is presented with
  93    --  the operand of the operator node.
  94
  95    procedure Ambiguous_Operands (N : Node_Id);
  96    --  for equality, membership, and comparison operators with overloaded
  97    --  arguments, list possible interpretations.
  98
  99    procedure Analyze_One_Call
 100       (N       : Node_Id;
 101        Nam     : Entity_Id;
 102        Report  : Boolean;
 103        Success : out Boolean);
 104    --  Check one interpretation of an overloaded subprogram name for
 105    --  compatibility with the types of the actuals in a call. If there is a
 106    --  single interpretation which does not match, post error if Report is
 107    --  set to True.
 108    --
 109    --  Nam is the entity that provides the formals against which the actuals
 110    --  are checked. Nam is either the name of a subprogram, or the internal
 111    --  subprogram type constructed for an access_to_subprogram. If the actuals
 112    --  are compatible with Nam, then Nam is added to the list of candidate
 113    --  interpretations for N, and Success is set to True.
 114
 115    procedure Check_Misspelled_Selector
 116      (Prefix : Entity_Id;
 117       Sel    : Node_Id);
 118    --  Give possible misspelling diagnostic if Sel is likely to be
 119    --  a misspelling of one of the selectors of the Prefix.
 120    --  This is called by Analyze_Selected_Component after producing
 121    --  an invalid selector error message.
 122
 123    function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean;
 124    --  Verify that type T is declared in scope S. Used to find intepretations
 125    --  for operators given by expanded names. This is abstracted as a separate
 126    --  function to handle extensions to System, where S is System, but T is
 127    --  declared in the extension.
 128
 129    procedure Find_Arithmetic_Types
 130      (L, R  : Node_Id;
 131       Op_Id : Entity_Id;
 132       N     : Node_Id);
 133    --  L and R are the operands of an arithmetic operator. Find
 134    --  consistent pairs of interpretations for L and R that have a
 135    --  numeric type consistent with the semantics of the operator.
 136
 137    procedure Find_Comparison_Types
 138      (L, R  : Node_Id;
 139       Op_Id : Entity_Id;
 140       N     : Node_Id);
 141    --  L and R are operands of a comparison operator. Find consistent
 142    --  pairs of interpretations for L and R.
 143
 144    procedure Find_Concatenation_Types
 145      (L, R  : Node_Id;
 146       Op_Id : Entity_Id;
 147       N     : Node_Id);
 148    --  For the four varieties of concatenation
 149
 150    procedure Find_Equality_Types
 151      (L, R  : Node_Id;
 152       Op_Id : Entity_Id;
 153       N     : Node_Id);
 154    --  Ditto for equality operators
 155
 156    procedure Find_Boolean_Types
 157      (L, R  : Node_Id;
 158       Op_Id : Entity_Id;
 159       N     : Node_Id);
 160    --  Ditto for binary logical operations
 161
 162    procedure Find_Negation_Types
 163      (R     : Node_Id;
 164       Op_Id : Entity_Id;
 165       N     : Node_Id);
 166    --  Find consistent interpretation for operand of negation operator
 167
 168    procedure Find_Non_Universal_Interpretations
 169      (N     : Node_Id;
 170       R     : Node_Id;
 171       Op_Id : Entity_Id;
 172       T1    : Entity_Id);
 173    --  For equality and comparison operators, the result is always boolean,
 174    --  and the legality of the operation is determined from the visibility
 175    --  of the operand types. If one of the operands has a universal interpre-
 176    --  tation,  the legality check uses some compatible non-universal
 177    --  interpretation of the other operand. N can be an operator node, or
 178    --  a function call whose name is an operator designator.
 179
 180    procedure Find_Unary_Types
 181      (R     : Node_Id;
 182       Op_Id : Entity_Id;
 183       N     : Node_Id);
 184    --  Unary arithmetic types: plus, minus, abs
 185
 186    procedure Check_Arithmetic_Pair
 187      (T1, T2 : Entity_Id;
 188       Op_Id  : Entity_Id;
 189       N      : Node_Id);
 190    --  Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
 191    --  types for left and right operand. Determine whether they constitute
 192    --  a valid pair for the given operator, and record the corresponding
 193    --  interpretation of the operator node. The node N may be an operator
 194    --  node (the usual case) or a function call whose prefix is an operator
 195    --  designator. In  both cases Op_Id is the operator name itself.
 196
 197    procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
 198    --  Give detailed information on overloaded call where none of the
 199    --  interpretations match. N is the call node, Nam the designator for
 200    --  the overloaded entity being called.
 201
 202    function Junk_Operand (N : Node_Id) return Boolean;
 203    --  Test for an operand that is an inappropriate entity (e.g. a package
 204    --  name or a label). If so, issue an error message and return True. If
 205    --  the operand is not an inappropriate entity kind, return False.
 206
 207    procedure Operator_Check (N : Node_Id);
 208    --  Verify that an operator has received some valid interpretation. If none
 209    --  was found, determine whether a use clause would make the operation
 210    --  legal. The variable Candidate_Type (defined in Sem_Type) is set for
 211    --  every type compatible with the operator, even if the operator for the
 212    --  type is not directly visible. The routine uses this type to emit a more
 213    --  informative message.
 214
 215    procedure Process_Implicit_Dereference_Prefix
 216      (E : Entity_Id;
 217       P : Node_Id);
 218    --  Called when P is the prefix of an implicit dereference, denoting an
 219    --  object E. If in semantics only mode (-gnatc or generic), record that is
 220    --  a reference to E. Normally, such a reference is generated only when the
 221    --  implicit dereference is expanded into an explicit one. E may be empty,
 222    --  in which case this procedure does nothing.
 223
 224    procedure Remove_Abstract_Operations (N : Node_Id);
 225    --  Ada 2005: implementation of AI-310. An abstract non-dispatching
 226    --  operation is not a candidate interpretation.
 227
 228    function Try_Indexed_Call
 229      (N   : Node_Id;
 230       Nam : Entity_Id;
 231       Typ : Entity_Id) return Boolean;
 232    --  If a function has defaults for all its actuals, a call to it may
 233    --  in fact be an indexing on the result of the call. Try_Indexed_Call
 234    --  attempts the interpretation as an indexing, prior to analysis as
 235    --  a call. If both are possible,  the node is overloaded with both
 236    --  interpretations (same symbol but two different types).
 237
 238    function Try_Indirect_Call
 239      (N   : Node_Id;
 240       Nam : Entity_Id;
 241       Typ : Entity_Id) return Boolean;
 242    --  Similarly, a function F that needs no actuals can return an access
 243    --  to a subprogram, and the call F (X)  interpreted as F.all (X). In
 244    --  this case the call may be overloaded with both interpretations.
 245
 246    function Try_Object_Operation (N : Node_Id) return Boolean;
 247    --  Ada 2005 (AI-252): Give support to the object operation notation
 248
 249    ------------------------
 250    -- Ambiguous_Operands --
 251    ------------------------
 252
 253    procedure Ambiguous_Operands (N : Node_Id) is
 254       procedure List_Operand_Interps (Opnd : Node_Id);
 255
 256       --------------------------
 257       -- List_Operand_Interps --
 258       --------------------------
 259
 260       procedure List_Operand_Interps (Opnd : Node_Id) is
 261          Nam   : Node_Id;
 262          Err   : Node_Id := N;
 263
 264       begin
 265          if Is_Overloaded (Opnd) then
 266             if Nkind (Opnd) in N_Op then
 267                Nam := Opnd;
 268             elsif Nkind (Opnd) = N_Function_Call then
 269                Nam := Name (Opnd);
 270             else
 271                return;
 272             end if;
 273
 274          else
 275             return;
 276          end if;
 277
 278          if Opnd = Left_Opnd (N) then
 279             Error_Msg_N
 280               ("\left operand has the following interpretations", N);
 281          else
 282             Error_Msg_N
 283               ("\right operand has the following interpretations", N);
 284             Err := Opnd;
 285          end if;
 286
 287          List_Interps (Nam, Err);
 288       end List_Operand_Interps;
 289
 290    --  Start of processing for Ambiguous_Operands
 291
 292    begin
 293       if Nkind (N) = N_In
 294         or else Nkind (N) = N_Not_In
 295       then
 296          Error_Msg_N ("ambiguous operands for membership",  N);
 297
 298       elsif Nkind (N) = N_Op_Eq
 299         or else Nkind (N) = N_Op_Ne
 300       then
 301          Error_Msg_N ("ambiguous operands for equality",  N);
 302
 303       else
 304          Error_Msg_N ("ambiguous operands for comparison",  N);
 305       end if;
 306
 307       if All_Errors_Mode then
 308          List_Operand_Interps (Left_Opnd  (N));
 309          List_Operand_Interps (Right_Opnd (N));
 310       else
 311          Error_Msg_N ("\use -gnatf switch for details", N);
 312       end if;
 313    end Ambiguous_Operands;
 314
 315    -----------------------
 316    -- Analyze_Aggregate --
 317    -----------------------
 318
 319    --  Most of the analysis of Aggregates requires that the type be known,
 320    --  and is therefore put off until resolution.
 321
 322    procedure Analyze_Aggregate (N : Node_Id) is
 323    begin
 324       if No (Etype (N)) then
 325          Set_Etype (N, Any_Composite);
 326       end if;
 327    end Analyze_Aggregate;
 328
 329    -----------------------
 330    -- Analyze_Allocator --
 331    -----------------------
 332
 333    procedure Analyze_Allocator (N : Node_Id) is
 334       Loc      : constant Source_Ptr := Sloc (N);
 335       Sav_Errs : constant Nat        := Serious_Errors_Detected;
 336       E        : Node_Id            := Expression (N);
 337       Acc_Type : Entity_Id;
 338       Type_Id  : Entity_Id;
 339
 340    begin
 341       Check_Restriction (No_Allocators, N);
 342
 343       if Nkind (E) = N_Qualified_Expression then
 344          Acc_Type := Create_Itype (E_Allocator_Type, N);
 345          Set_Etype (Acc_Type, Acc_Type);
 346          Init_Size_Align (Acc_Type);
 347          Find_Type (Subtype_Mark (E));
 348          Type_Id := Entity (Subtype_Mark (E));
 349          Check_Fully_Declared (Type_Id, N);
 350          Set_Directly_Designated_Type (Acc_Type, Type_Id);
 351
 352          if Is_Limited_Type (Type_Id)
 353            and then Comes_From_Source (N)
 354            and then not In_Instance_Body
 355          then
 356             --  Ada 2005 (AI-287): Do not post an error if the expression
 357             --  corresponds to a limited aggregate. Limited aggregates
 358             --  are checked in sem_aggr in a per-component manner
 359             --  (compare with handling of Get_Value subprogram).
 360
 361             if Ada_Version >= Ada_05
 362               and then Nkind (Expression (E)) = N_Aggregate
 363             then
 364                null;
 365             else
 366                Error_Msg_N ("initialization not allowed for limited types", N);
 367                Explain_Limited_Type (Type_Id, N);
 368             end if;
 369          end if;
 370
 371          Analyze_And_Resolve (Expression (E), Type_Id);
 372
 373          --  A qualified expression requires an exact match of the type,
 374          --  class-wide matching is not allowed.
 375
 376          if Is_Class_Wide_Type (Type_Id)
 377            and then Base_Type (Etype (Expression (E))) /= Base_Type (Type_Id)
 378          then
 379             Wrong_Type (Expression (E), Type_Id);
 380          end if;
 381
 382          Check_Non_Static_Context (Expression (E));
 383
 384          --  We don't analyze the qualified expression itself because it's
 385          --  part of the allocator
 386
 387          Set_Etype  (E, Type_Id);
 388
 389       --  Case where no qualified expression is present
 390
 391       else
 392          declare
 393             Def_Id   : Entity_Id;
 394             Base_Typ : Entity_Id;
 395
 396          begin
 397             --  If the allocator includes a N_Subtype_Indication then a
 398             --  constraint is present, otherwise the node is a subtype mark.
 399             --  Introduce an explicit subtype declaration into the tree
 400             --  defining some anonymous subtype and rewrite the allocator to
 401             --  use this subtype rather than the subtype indication.
 402
 403             --  It is important to introduce the explicit subtype declaration
 404             --  so that the bounds of the subtype indication are attached to
 405             --  the tree in case the allocator is inside a generic unit.
 406
 407             if Nkind (E) = N_Subtype_Indication then
 408
 409                --  A constraint is only allowed for a composite type in Ada
 410                --  95. In Ada 83, a constraint is also allowed for an
 411                --  access-to-composite type, but the constraint is ignored.
 412
 413                Find_Type (Subtype_Mark (E));
 414                Base_Typ := Entity (Subtype_Mark (E));
 415
 416                if Is_Elementary_Type (Base_Typ) then
 417                   if not (Ada_Version = Ada_83
 418                            and then Is_Access_Type (Base_Typ))
 419                   then
 420                      Error_Msg_N ("constraint not allowed here", E);
 421
 422                      if Nkind (Constraint (E))
 423                        = N_Index_Or_Discriminant_Constraint
 424                      then
 425                         Error_Msg_N
 426                           ("\if qualified expression was meant, " &
 427                               "use apostrophe", Constraint (E));
 428                      end if;
 429                   end if;
 430
 431                   --  Get rid of the bogus constraint:
 432
 433                   Rewrite (E, New_Copy_Tree (Subtype_Mark (E)));
 434                   Analyze_Allocator (N);
 435                   return;
 436
 437                --  Ada 2005, AI-363: if the designated type has a constrained
 438                --  partial view, it cannot receive a discriminant constraint,
 439                --  and the allocated object is unconstrained.
 440
 441                elsif Ada_Version >= Ada_05
 442                  and then Has_Constrained_Partial_View (Base_Typ)
 443                then
 444                   Error_Msg_N
 445                     ("constraint no allowed when type " &
 446                       "has a constrained partial view", Constraint (E));
 447                end if;
 448
 449                if Expander_Active then
 450                   Def_Id :=
 451                     Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 452
 453                   Insert_Action (E,
 454                     Make_Subtype_Declaration (Loc,
 455                       Defining_Identifier => Def_Id,
 456                       Subtype_Indication  => Relocate_Node (E)));
 457
 458                   if Sav_Errs /= Serious_Errors_Detected
 459                     and then Nkind (Constraint (E))
 460                       = N_Index_Or_Discriminant_Constraint
 461                   then
 462                      Error_Msg_N
 463                        ("if qualified expression was meant, " &
 464                            "use apostrophe!", Constraint (E));
 465                   end if;
 466
 467                   E := New_Occurrence_Of (Def_Id, Loc);
 468                   Rewrite (Expression (N), E);
 469                end if;
 470             end if;
 471
 472             Type_Id := Process_Subtype (E, N);
 473             Acc_Type := Create_Itype (E_Allocator_Type, N);
 474             Set_Etype                    (Acc_Type, Acc_Type);
 475             Init_Size_Align              (Acc_Type);
 476             Set_Directly_Designated_Type (Acc_Type, Type_Id);
 477             Check_Fully_Declared (Type_Id, N);
 478
 479             --  Ada 2005 (AI-231)
 480
 481             if Can_Never_Be_Null (Type_Id) then
 482                Error_Msg_N ("(Ada 2005) qualified expression required",
 483                             Expression (N));
 484             end if;
 485
 486             --  Check restriction against dynamically allocated protected
 487             --  objects. Note that when limited aggregates are supported,
 488             --  a similar test should be applied to an allocator with a
 489             --  qualified expression ???
 490
 491             if Is_Protected_Type (Type_Id) then
 492                Check_Restriction (No_Protected_Type_Allocators, N);
 493             end if;
 494
 495             --  Check for missing initialization. Skip this check if we already
 496             --  had errors on analyzing the allocator, since in that case these
 497             --  are probably cascaded errors
 498
 499             if Is_Indefinite_Subtype (Type_Id)
 500               and then Serious_Errors_Detected = Sav_Errs
 501             then
 502                if Is_Class_Wide_Type (Type_Id) then
 503                   Error_Msg_N
 504                     ("initialization required in class-wide allocation", N);
 505                else
 506                   Error_Msg_N
 507                     ("initialization required in unconstrained allocation", N);
 508                end if;
 509             end if;
 510          end;
 511       end if;
 512
 513       if Is_Abstract (Type_Id) then
 514          Error_Msg_N ("cannot allocate abstract object", E);
 515       end if;
 516
 517       if Has_Task (Designated_Type (Acc_Type)) then
 518          Check_Restriction (No_Tasking, N);
 519          Check_Restriction (Max_Tasks, N);
 520          Check_Restriction (No_Task_Allocators, N);
 521       end if;
 522
 523       --  If the No_Streams restriction is set, check that the type of the
 524       --  object is not, and does not contain, any subtype derived from
 525       --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
 526       --  Has_Stream just for efficiency reasons. There is no point in
 527       --  spending time on a Has_Stream check if the restriction is not set.
 528
 529       if Restrictions.Set (No_Streams) then
 530          if Has_Stream (Designated_Type (Acc_Type)) then
 531             Check_Restriction (No_Streams, N);
 532          end if;
 533       end if;
 534
 535       Set_Etype (N, Acc_Type);
 536
 537       if not Is_Library_Level_Entity (Acc_Type) then
 538          Check_Restriction (No_Local_Allocators, N);
 539       end if;
 540
 541       --  Ada 2005 (AI-231): Static checks
 542
 543       if Ada_Version >= Ada_05
 544         and then (Null_Exclusion_Present (N)
 545                     or else Can_Never_Be_Null (Etype (N)))
 546       then
 547          Null_Exclusion_Static_Checks (N);
 548       end if;
 549
 550       if Serious_Errors_Detected > Sav_Errs then
 551          Set_Error_Posted (N);
 552          Set_Etype (N, Any_Type);
 553       end if;
 554    end Analyze_Allocator;
 555
 556    ---------------------------
 557    -- Analyze_Arithmetic_Op --
 558    ---------------------------
 559
 560    procedure Analyze_Arithmetic_Op (N : Node_Id) is
 561       L     : constant Node_Id := Left_Opnd (N);
 562       R     : constant Node_Id := Right_Opnd (N);
 563       Op_Id : Entity_Id;
 564
 565    begin
 566       Candidate_Type := Empty;
 567       Analyze_Expression (L);
 568       Analyze_Expression (R);
 569
 570       --  If the entity is already set, the node is the instantiation of
 571       --  a generic node with a non-local reference, or was manufactured
 572       --  by a call to Make_Op_xxx. In either case the entity is known to
 573       --  be valid, and we do not need to collect interpretations, instead
 574       --  we just get the single possible interpretation.
 575
 576       Op_Id := Entity (N);
 577
 578       if Present (Op_Id) then
 579          if Ekind (Op_Id) = E_Operator then
 580
 581             if (Nkind (N) = N_Op_Divide   or else
 582                 Nkind (N) = N_Op_Mod      or else
 583                 Nkind (N) = N_Op_Multiply or else
 584                 Nkind (N) = N_Op_Rem)
 585               and then Treat_Fixed_As_Integer (N)
 586             then
 587                null;
 588             else
 589                Set_Etype (N, Any_Type);
 590                Find_Arithmetic_Types (L, R, Op_Id, N);
 591             end if;
 592
 593          else
 594             Set_Etype (N, Any_Type);
 595             Add_One_Interp (N, Op_Id, Etype (Op_Id));
 596          end if;
 597
 598       --  Entity is not already set, so we do need to collect interpretations
 599
 600       else
 601          Op_Id := Get_Name_Entity_Id (Chars (N));
 602          Set_Etype (N, Any_Type);
 603
 604          while Present (Op_Id) loop
 605             if Ekind (Op_Id) = E_Operator
 606               and then Present (Next_Entity (First_Entity (Op_Id)))
 607             then
 608                Find_Arithmetic_Types (L, R, Op_Id, N);
 609
 610             --  The following may seem superfluous, because an operator cannot
 611             --  be generic, but this ignores the cleverness of the author of
 612             --  ACVC bc1013a.
 613
 614             elsif Is_Overloadable (Op_Id) then
 615                Analyze_User_Defined_Binary_Op (N, Op_Id);
 616             end if;
 617
 618             Op_Id := Homonym (Op_Id);
 619          end loop;
 620       end if;
 621
 622       Operator_Check (N);
 623    end Analyze_Arithmetic_Op;
 624
 625    ------------------
 626    -- Analyze_Call --
 627    ------------------
 628
 629    --  Function, procedure, and entry calls are checked here. The Name in
 630    --  the call may be overloaded. The actuals have been analyzed and may
 631    --  themselves be overloaded. On exit from this procedure, the node N
 632    --  may have zero, one or more interpretations. In the first case an
 633    --  error message is produced. In the last case, the node is flagged
 634    --  as overloaded and the interpretations are collected in All_Interp.
 635
 636    --  If the name is an Access_To_Subprogram, it cannot be overloaded, but
 637    --  the type-checking is similar to that of other calls.
 638
 639    procedure Analyze_Call (N : Node_Id) is
 640       Actuals : constant List_Id := Parameter_Associations (N);
 641       Nam     : Node_Id          := Name (N);
 642       X       : Interp_Index;
 643       It      : Interp;
 644       Nam_Ent : Entity_Id;
 645       Success : Boolean := False;
 646
 647       function Name_Denotes_Function return Boolean;
 648       --  If the type of the name is an access to subprogram, this may be
 649       --  the type of a name, or the return type of the function being called.
 650       --  If the name is not an entity then it can denote a protected function.
 651       --  Until we distinguish Etype from Return_Type, we must use this
 652       --  routine to resolve the meaning of the name in the call.
 653
 654       ---------------------------
 655       -- Name_Denotes_Function --
 656       ---------------------------
 657
 658       function Name_Denotes_Function return Boolean is
 659       begin
 660          if Is_Entity_Name (Nam) then
 661             return Ekind (Entity (Nam)) = E_Function;
 662
 663          elsif Nkind (Nam) = N_Selected_Component then
 664             return Ekind (Entity (Selector_Name (Nam))) = E_Function;
 665
 666          else
 667             return False;
 668          end if;
 669       end Name_Denotes_Function;
 670
 671    --  Start of processing for Analyze_Call
 672
 673    begin
 674       --  Initialize the type of the result of the call to the error type,
 675       --  which will be reset if the type is successfully resolved.
 676
 677       Set_Etype (N, Any_Type);
 678
 679       if not Is_Overloaded (Nam) then
 680
 681          --  Only one interpretation to check
 682
 683          if Ekind (Etype (Nam)) = E_Subprogram_Type then
 684             Nam_Ent := Etype (Nam);
 685
 686          --  If the prefix is an access_to_subprogram, this may be an indirect
 687          --  call. This is the case if the name in the call is not an entity
 688          --  name, or if it is a function name in the context of a procedure
 689          --  call. In this latter case, we have a call to a parameterless
 690          --  function that returns a pointer_to_procedure which is the entity
 691          --  being called.
 692
 693          elsif Is_Access_Type (Etype (Nam))
 694            and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
 695            and then
 696              (not Name_Denotes_Function
 697                 or else Nkind (N) = N_Procedure_Call_Statement)
 698          then
 699             Nam_Ent := Designated_Type (Etype (Nam));
 700             Insert_Explicit_Dereference (Nam);
 701
 702          --  Selected component case. Simple entry or protected operation,
 703          --  where the entry name is given by the selector name.
 704
 705          elsif Nkind (Nam) = N_Selected_Component then
 706             Nam_Ent := Entity (Selector_Name (Nam));
 707
 708             if Ekind (Nam_Ent) /= E_Entry
 709               and then Ekind (Nam_Ent) /= E_Entry_Family
 710               and then Ekind (Nam_Ent) /= E_Function
 711               and then Ekind (Nam_Ent) /= E_Procedure
 712             then
 713                Error_Msg_N ("name in call is not a callable entity", Nam);
 714                Set_Etype (N, Any_Type);
 715                return;
 716             end if;
 717
 718          --  If the name is an Indexed component, it can be a call to a member
 719          --  of an entry family. The prefix must be a selected component whose
 720          --  selector is the entry. Analyze_Procedure_Call normalizes several
 721          --  kinds of call into this form.
 722
 723          elsif Nkind (Nam) = N_Indexed_Component then
 724
 725             if Nkind (Prefix (Nam)) = N_Selected_Component then
 726                Nam_Ent := Entity (Selector_Name (Prefix (Nam)));
 727             else
 728                Error_Msg_N ("name in call is not a callable entity", Nam);
 729                Set_Etype (N, Any_Type);
 730                return;
 731             end if;
 732
 733          elsif not Is_Entity_Name (Nam) then
 734             Error_Msg_N ("name in call is not a callable entity", Nam);
 735             Set_Etype (N, Any_Type);
 736             return;
 737
 738          else
 739             Nam_Ent := Entity (Nam);
 740
 741             --  If no interpretations, give error message
 742
 743             if not Is_Overloadable (Nam_Ent) then
 744                declare
 745                   L : constant Boolean   := Is_List_Member (N);
 746                   K : constant Node_Kind := Nkind (Parent (N));
 747
 748                begin
 749                   --  If the node is in a list whose parent is not an
 750                   --  expression then it must be an attempted procedure call.
 751
 752                   if L and then K not in N_Subexpr then
 753                      if Ekind (Entity (Nam)) = E_Generic_Procedure then
 754                         Error_Msg_NE
 755                           ("must instantiate generic procedure& before call",
 756                            Nam, Entity (Nam));
 757                      else
 758                         Error_Msg_N
 759                           ("procedure or entry name expected", Nam);
 760                      end if;
 761
 762                   --  Check for tasking cases where only an entry call will do
 763
 764                   elsif not L
 765                     and then (K = N_Entry_Call_Alternative
 766                                or else K = N_Triggering_Alternative)
 767                   then
 768                      Error_Msg_N ("entry name expected", Nam);
 769
 770                   --  Otherwise give general error message
 771
 772                   else
 773                      Error_Msg_N ("invalid prefix in call", Nam);
 774                   end if;
 775
 776                   return;
 777                end;
 778             end if;
 779          end if;
 780
 781          Analyze_One_Call (N, Nam_Ent, True, Success);
 782
 783       else
 784          --  An overloaded selected component must denote overloaded
 785          --  operations of a concurrent type. The interpretations are
 786          --  attached to the simple name of those operations.
 787
 788          if Nkind (Nam) = N_Selected_Component then
 789             Nam := Selector_Name (Nam);
 790          end if;
 791
 792          Get_First_Interp (Nam, X, It);
 793
 794          while Present (It.Nam) loop
 795             Nam_Ent := It.Nam;
 796
 797             --  Name may be call that returns an access to subprogram, or more
 798             --  generally an overloaded expression one of whose interpretations
 799             --  yields an access to subprogram. If the name is an entity, we
 800             --  do not dereference, because the node is a call that returns
 801             --  the access type: note difference between f(x), where the call
 802             --  may return an access subprogram type, and f(x)(y), where the
 803             --  type returned by the call to f is implicitly dereferenced to
 804             --  analyze the outer call.
 805
 806             if Is_Access_Type (Nam_Ent) then
 807                Nam_Ent := Designated_Type (Nam_Ent);
 808
 809             elsif Is_Access_Type (Etype (Nam_Ent))
 810               and then not Is_Entity_Name (Nam)
 811               and then Ekind (Designated_Type (Etype (Nam_Ent)))
 812                                                           = E_Subprogram_Type
 813             then
 814                Nam_Ent := Designated_Type (Etype (Nam_Ent));
 815             end if;
 816
 817             Analyze_One_Call (N, Nam_Ent, False, Success);
 818
 819             --  If the interpretation succeeds, mark the proper type of the
 820             --  prefix (any valid candidate will do). If not, remove the
 821             --  candidate interpretation. This only needs to be done for
 822             --  overloaded protected operations, for other entities disambi-
 823             --  guation is done directly in Resolve.
 824
 825             if Success then
 826                Set_Etype (Nam, It.Typ);
 827
 828             elsif Nkind (Name (N)) = N_Selected_Component
 829               or else Nkind (Name (N)) = N_Function_Call
 830             then
 831                Remove_Interp (X);
 832             end if;
 833
 834             Get_Next_Interp (X, It);
 835          end loop;
 836
 837          --  If the name is the result of a function call, it can only
 838          --  be a call to a function returning an access to subprogram.
 839          --  Insert explicit dereference.
 840
 841          if Nkind (Nam) = N_Function_Call then
 842             Insert_Explicit_Dereference (Nam);
 843          end if;
 844
 845          if Etype (N) = Any_Type then
 846
 847             --  None of the interpretations is compatible with the actuals
 848
 849             Diagnose_Call (N, Nam);
 850
 851             --  Special checks for uninstantiated put routines
 852
 853             if Nkind (N) = N_Procedure_Call_Statement
 854               and then Is_Entity_Name (Nam)
 855               and then Chars (Nam) = Name_Put
 856               and then List_Length (Actuals) = 1
 857             then
 858                declare
 859                   Arg : constant Node_Id := First (Actuals);
 860                   Typ : Entity_Id;
 861
 862                begin
 863                   if Nkind (Arg) = N_Parameter_Association then
 864                      Typ := Etype (Explicit_Actual_Parameter (Arg));
 865                   else
 866                      Typ := Etype (Arg);
 867                   end if;
 868
 869                   if Is_Signed_Integer_Type (Typ) then
 870                      Error_Msg_N
 871                        ("possible missing instantiation of " &
 872                           "'Text_'I'O.'Integer_'I'O!", Nam);
 873
 874                   elsif Is_Modular_Integer_Type (Typ) then
 875                      Error_Msg_N
 876                        ("possible missing instantiation of " &
 877                           "'Text_'I'O.'Modular_'I'O!", Nam);
 878
 879                   elsif Is_Floating_Point_Type (Typ) then
 880                      Error_Msg_N
 881                        ("possible missing instantiation of " &
 882                           "'Text_'I'O.'Float_'I'O!", Nam);
 883
 884                   elsif Is_Ordinary_Fixed_Point_Type (Typ) then
 885                      Error_Msg_N
 886                        ("possible missing instantiation of " &
 887                           "'Text_'I'O.'Fixed_'I'O!", Nam);
 888
 889                   elsif Is_Decimal_Fixed_Point_Type (Typ) then
 890                      Error_Msg_N
 891                        ("possible missing instantiation of " &
 892                           "'Text_'I'O.'Decimal_'I'O!", Nam);
 893
 894                   elsif Is_Enumeration_Type (Typ) then
 895                      Error_Msg_N
 896                        ("possible missing instantiation of " &
 897                           "'Text_'I'O.'Enumeration_'I'O!", Nam);
 898                   end if;
 899                end;
 900             end if;
 901
 902          elsif not Is_Overloaded (N)
 903            and then Is_Entity_Name (Nam)
 904          then
 905             --  Resolution yields a single interpretation. Verify that
 906             --  is has the proper capitalization.
 907
 908             Set_Entity_With_Style_Check (Nam, Entity (Nam));
 909             Generate_Reference (Entity (Nam), Nam);
 910
 911             Set_Etype (Nam, Etype (Entity (Nam)));
 912          else
 913             Remove_Abstract_Operations (N);
 914          end if;
 915
 916          End_Interp_List;
 917       end if;
 918    end Analyze_Call;
 919
 920    ---------------------------
 921    -- Analyze_Comparison_Op --
 922    ---------------------------
 923
 924    procedure Analyze_Comparison_Op (N : Node_Id) is
 925       L     : constant Node_Id := Left_Opnd (N);
 926       R     : constant Node_Id := Right_Opnd (N);
 927       Op_Id : Entity_Id        := Entity (N);
 928
 929    begin
 930       Set_Etype (N, Any_Type);
 931       Candidate_Type := Empty;
 932
 933       Analyze_Expression (L);
 934       Analyze_Expression (R);
 935
 936       if Present (Op_Id) then
 937          if Ekind (Op_Id) = E_Operator then
 938             Find_Comparison_Types (L, R, Op_Id, N);
 939          else
 940             Add_One_Interp (N, Op_Id, Etype (Op_Id));
 941          end if;
 942
 943          if Is_Overloaded (L) then
 944             Set_Etype (L, Intersect_Types (L, R));
 945          end if;
 946
 947       else
 948          Op_Id := Get_Name_Entity_Id (Chars (N));
 949          while Present (Op_Id) loop
 950             if Ekind (Op_Id) = E_Operator then
 951                Find_Comparison_Types (L, R, Op_Id, N);
 952             else
 953                Analyze_User_Defined_Binary_Op (N, Op_Id);
 954             end if;
 955
 956             Op_Id := Homonym (Op_Id);
 957          end loop;
 958       end if;
 959
 960       Operator_Check (N);
 961    end Analyze_Comparison_Op;
 962
 963    ---------------------------
 964    -- Analyze_Concatenation --
 965    ---------------------------
 966
 967    --  If the only one-dimensional array type in scope is String,
 968    --  this is the resulting type of the operation. Otherwise there
 969    --  will be a concatenation operation defined for each user-defined
 970    --  one-dimensional array.
 971
 972    procedure Analyze_Concatenation (N : Node_Id) is
 973       L     : constant Node_Id := Left_Opnd (N);
 974       R     : constant Node_Id := Right_Opnd (N);
 975       Op_Id : Entity_Id        := Entity (N);
 976       LT    : Entity_Id;
 977       RT    : Entity_Id;
 978
 979    begin
 980       Set_Etype (N, Any_Type);
 981       Candidate_Type := Empty;
 982
 983       Analyze_Expression (L);
 984       Analyze_Expression (R);
 985
 986       --  If the entity is present, the  node appears in an instance,
 987       --  and denotes a predefined concatenation operation. The resulting
 988       --  type is obtained from the arguments when possible. If the arguments
 989       --  are aggregates, the array type and the concatenation type must be
 990       --  visible.
 991
 992       if Present (Op_Id) then
 993          if Ekind (Op_Id) = E_Operator then
 994
 995             LT := Base_Type (Etype (L));
 996             RT := Base_Type (Etype (R));
 997
 998             if Is_Array_Type (LT)
 999               and then (RT = LT or else RT = Base_Type (Component_Type (LT)))
1000             then
1001                Add_One_Interp (N, Op_Id, LT);
1002
1003             elsif Is_Array_Type (RT)
1004               and then LT = Base_Type (Component_Type (RT))
1005             then
1006                Add_One_Interp (N, Op_Id, RT);
1007
1008             --  If one operand is a string type or a user-defined array type,
1009             --  and the other is a literal, result is of the specific type.
1010
1011             elsif
1012               (Root_Type (LT) = Standard_String
1013                  or else Scope (LT) /= Standard_Standard)
1014               and then Etype (R) = Any_String
1015             then
1016                Add_One_Interp (N, Op_Id, LT);
1017
1018             elsif
1019               (Root_Type (RT) = Standard_String
1020                  or else Scope (RT) /= Standard_Standard)
1021               and then Etype (L) = Any_String
1022             then
1023                Add_One_Interp (N, Op_Id, RT);
1024
1025             elsif not Is_Generic_Type (Etype (Op_Id)) then
1026                Add_One_Interp (N, Op_Id, Etype (Op_Id));
1027
1028             else
1029                --  Type and its operations must be visible
1030
1031                Set_Entity (N, Empty);
1032                Analyze_Concatenation (N);
1033             end if;
1034
1035          else
1036             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1037          end if;
1038
1039       else
1040          Op_Id := Get_Name_Entity_Id (Name_Op_Concat);
1041          while Present (Op_Id) loop
1042             if Ekind (Op_Id) = E_Operator then
1043
1044                --  Do not consider operators declared in dead code, they can
1045                --  not be part of the resolution.
1046
1047                if Is_Eliminated (Op_Id) then
1048                   null;
1049                else
1050                   Find_Concatenation_Types (L, R, Op_Id, N);
1051                end if;
1052
1053             else
1054                Analyze_User_Defined_Binary_Op (N, Op_Id);
1055             end if;
1056
1057             Op_Id := Homonym (Op_Id);
1058          end loop;
1059       end if;
1060
1061       Operator_Check (N);
1062    end Analyze_Concatenation;
1063
1064    ------------------------------------
1065    -- Analyze_Conditional_Expression --
1066    ------------------------------------
1067
1068    procedure Analyze_Conditional_Expression (N : Node_Id) is
1069       Condition : constant Node_Id := First (Expressions (N));
1070       Then_Expr : constant Node_Id := Next (Condition);
1071       Else_Expr : constant Node_Id := Next (Then_Expr);
1072    begin
1073       Analyze_Expression (Condition);
1074       Analyze_Expression (Then_Expr);
1075       Analyze_Expression (Else_Expr);
1076       Set_Etype (N, Etype (Then_Expr));
1077    end Analyze_Conditional_Expression;
1078
1079    -------------------------
1080    -- Analyze_Equality_Op --
1081    -------------------------
1082
1083    procedure Analyze_Equality_Op (N : Node_Id) is
1084       Loc   : constant Source_Ptr := Sloc (N);
1085       L     : constant Node_Id := Left_Opnd (N);
1086       R     : constant Node_Id := Right_Opnd (N);
1087       Op_Id : Entity_Id;
1088
1089    begin
1090       Set_Etype (N, Any_Type);
1091       Candidate_Type := Empty;
1092
1093       Analyze_Expression (L);
1094       Analyze_Expression (R);
1095
1096       --  If the entity is set, the node is a generic instance with a non-local
1097       --  reference to the predefined operator or to a user-defined function.
1098       --  It can also be an inequality that is expanded into the negation of a
1099       --  call to a user-defined equality operator.
1100
1101       --  For the predefined case, the result is Boolean, regardless of the
1102       --  type of the  operands. The operands may even be limited, if they are
1103       --  generic actuals. If they are overloaded, label the left argument with
1104       --  the common type that must be present, or with the type of the formal
1105       --  of the user-defined function.
1106
1107       if Present (Entity (N)) then
1108          Op_Id := Entity (N);
1109
1110          if Ekind (Op_Id) = E_Operator then
1111             Add_One_Interp (N, Op_Id, Standard_Boolean);
1112          else
1113             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1114          end if;
1115
1116          if Is_Overloaded (L) then
1117             if Ekind (Op_Id) = E_Operator then
1118                Set_Etype (L, Intersect_Types (L, R));
1119             else
1120                Set_Etype (L, Etype (First_Formal (Op_Id)));
1121             end if;
1122          end if;
1123
1124       else
1125          Op_Id := Get_Name_Entity_Id (Chars (N));
1126          while Present (Op_Id) loop
1127             if Ekind (Op_Id) = E_Operator then
1128                Find_Equality_Types (L, R, Op_Id, N);
1129             else
1130                Analyze_User_Defined_Binary_Op (N, Op_Id);
1131             end if;
1132
1133             Op_Id := Homonym (Op_Id);
1134          end loop;
1135       end if;
1136
1137       --  If there was no match, and the operator is inequality, this may
1138       --  be a case where inequality has not been made explicit, as for
1139       --  tagged types. Analyze the node as the negation of an equality
1140       --  operation. This cannot be done earlier, because before analysis
1141       --  we cannot rule out the presence of an explicit inequality.
1142
1143       if Etype (N) = Any_Type
1144         and then Nkind (N) = N_Op_Ne
1145       then
1146          Op_Id := Get_Name_Entity_Id (Name_Op_Eq);
1147
1148          while Present (Op_Id) loop
1149
1150             if Ekind (Op_Id) = E_Operator then
1151                Find_Equality_Types (L, R, Op_Id, N);
1152             else
1153                Analyze_User_Defined_Binary_Op (N, Op_Id);
1154             end if;
1155
1156             Op_Id := Homonym (Op_Id);
1157          end loop;
1158
1159          if Etype (N) /= Any_Type then
1160             Op_Id := Entity (N);
1161
1162             Rewrite (N,
1163               Make_Op_Not (Loc,
1164                 Right_Opnd =>
1165                   Make_Op_Eq (Loc,
1166                     Left_Opnd =>  Relocate_Node (Left_Opnd (N)),
1167                     Right_Opnd => Relocate_Node (Right_Opnd (N)))));
1168
1169             Set_Entity (Right_Opnd (N), Op_Id);
1170             Analyze (N);
1171          end if;
1172       end if;
1173
1174       Operator_Check (N);
1175    end Analyze_Equality_Op;
1176
1177    ----------------------------------
1178    -- Analyze_Explicit_Dereference --
1179    ----------------------------------
1180
1181    procedure Analyze_Explicit_Dereference (N : Node_Id) is
1182       Loc   : constant Source_Ptr := Sloc (N);
1183       P     : constant Node_Id := Prefix (N);
1184       T     : Entity_Id;
1185       I     : Interp_Index;
1186       It    : Interp;
1187       New_N : Node_Id;
1188
1189       function Is_Function_Type return Boolean;
1190       --  Check whether node may be interpreted as an implicit function call
1191
1192       ----------------------
1193       -- Is_Function_Type --
1194       ----------------------
1195
1196       function Is_Function_Type return Boolean is
1197          I  : Interp_Index;
1198          It : Interp;
1199
1200       begin
1201          if not Is_Overloaded (N) then
1202             return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type
1203               and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type;
1204
1205          else
1206             Get_First_Interp (N, I, It);
1207
1208             while Present (It.Nam) loop
1209                if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type
1210                  or else Etype (Base_Type (It.Typ)) = Standard_Void_Type
1211                then
1212                   return False;
1213                end if;
1214
1215                Get_Next_Interp (I, It);
1216             end loop;
1217
1218             return True;
1219          end if;
1220       end Is_Function_Type;
1221
1222    --  Start of processing for Analyze_Explicit_Dereference
1223
1224    begin
1225       Analyze (P);
1226       Set_Etype (N, Any_Type);
1227
1228       --  Test for remote access to subprogram type, and if so return
1229       --  after rewriting the original tree.
1230
1231       if Remote_AST_E_Dereference (P) then
1232          return;
1233       end if;
1234
1235       --  Normal processing for other than remote access to subprogram type
1236
1237       if not Is_Overloaded (P) then
1238          if Is_Access_Type (Etype (P)) then
1239
1240             --  Set the Etype. We need to go thru Is_For_Access_Subtypes
1241             --  to avoid other problems caused by the Private_Subtype
1242             --  and it is safe to go to the Base_Type because this is the
1243             --  same as converting the access value to its Base_Type.
1244
1245             declare
1246                DT : Entity_Id := Designated_Type (Etype (P));
1247
1248             begin
1249                if Ekind (DT) = E_Private_Subtype
1250                  and then Is_For_Access_Subtype (DT)
1251                then
1252                   DT := Base_Type (DT);
1253                end if;
1254
1255                Set_Etype (N, DT);
1256             end;
1257
1258          elsif Etype (P) /= Any_Type then
1259             Error_Msg_N ("prefix of dereference must be an access type", N);
1260             return;
1261          end if;
1262
1263       else
1264          Get_First_Interp (P, I, It);
1265
1266          while Present (It.Nam) loop
1267             T := It.Typ;
1268
1269             if Is_Access_Type (T) then
1270                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
1271             end if;
1272
1273             Get_Next_Interp (I, It);
1274          end loop;
1275
1276          --  Error if no interpretation of the prefix has an access type
1277
1278          if Etype (N) = Any_Type then
1279             Error_Msg_N
1280               ("access type required in prefix of explicit dereference", P);
1281             Set_Etype (N, Any_Type);
1282             return;
1283          end if;
1284       end if;
1285
1286       if Is_Function_Type
1287         and then Nkind (Parent (N)) /= N_Indexed_Component
1288
1289         and then (Nkind (Parent (N)) /= N_Function_Call
1290                    or else N /= Name (Parent (N)))
1291
1292         and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement
1293                    or else N /= Name (Parent (N)))
1294
1295         and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
1296         and then (Nkind (Parent (N)) /= N_Attribute_Reference
1297                     or else
1298                       (Attribute_Name (Parent (N)) /= Name_Address
1299                         and then
1300                        Attribute_Name (Parent (N)) /= Name_Access))
1301       then
1302          --  Name is a function call with no actuals, in a context that
1303          --  requires deproceduring (including as an actual in an enclosing
1304          --  function or procedure call). There are some pathological cases
1305          --  where the prefix might include functions that return access to
1306          --  subprograms and others that return a regular type. Disambiguation
1307          --  of those has to take place in Resolve.
1308          --  See e.g. 7117-014 and E317-001.
1309
1310          New_N :=
1311            Make_Function_Call (Loc,
1312            Name => Make_Explicit_Dereference (Loc, P),
1313            Parameter_Associations => New_List);
1314
1315          --  If the prefix is overloaded, remove operations that have formals,
1316          --  we know that this is a parameterless call.
1317
1318          if Is_Overloaded (P) then
1319             Get_First_Interp (P, I, It);
1320             while Present (It.Nam) loop
1321                T := It.Typ;
1322
1323                if No (First_Formal (Base_Type (Designated_Type (T)))) then
1324                   Set_Etype (P, T);
1325                else
1326                   Remove_Interp (I);
1327                end if;
1328
1329                Get_Next_Interp (I, It);
1330             end loop;
1331          end if;
1332
1333          Rewrite (N, New_N);
1334          Analyze (N);
1335
1336       elsif not Is_Function_Type
1337         and then Is_Overloaded (N)
1338       then
1339          --  The prefix may include access to subprograms and other access
1340          --  types. If the context selects the interpretation that is a call,
1341          --  we cannot rewrite the node yet, but we include the result of
1342          --  the call interpretation.
1343
1344          Get_First_Interp (N, I, It);
1345          while Present (It.Nam) loop
1346             if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type
1347                and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type
1348             then
1349                Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ));
1350             end if;
1351
1352             Get_Next_Interp (I, It);
1353          end loop;
1354       end if;
1355
1356       --  A value of remote access-to-class-wide must not be dereferenced
1357       --  (RM E.2.2(16)).
1358
1359       Validate_Remote_Access_To_Class_Wide_Type (N);
1360    end Analyze_Explicit_Dereference;
1361
1362    ------------------------
1363    -- Analyze_Expression --
1364    ------------------------
1365
1366    procedure Analyze_Expression (N : Node_Id) is
1367    begin
1368       Analyze (N);
1369       Check_Parameterless_Call (N);
1370    end Analyze_Expression;
1371
1372    ------------------------------------
1373    -- Analyze_Indexed_Component_Form --
1374    ------------------------------------
1375
1376    procedure Analyze_Indexed_Component_Form (N : Node_Id) is
1377       P     : constant Node_Id := Prefix (N);
1378       Exprs : constant List_Id := Expressions (N);
1379       Exp   : Node_Id;
1380       P_T   : Entity_Id;
1381       E     : Node_Id;
1382       U_N   : Entity_Id;
1383
1384       procedure Process_Function_Call;
1385       --  Prefix in indexed component form is an overloadable entity,
1386       --  so the node is a function call. Reformat it as such.
1387
1388       procedure Process_Indexed_Component;
1389       --  Prefix in indexed component form is actually an indexed component.
1390       --  This routine processes it, knowing that the prefix is already
1391       --  resolved.
1392
1393       procedure Process_Indexed_Component_Or_Slice;
1394       --  An indexed component with a single index may designate a slice if
1395       --  the index is a subtype mark. This routine disambiguates these two
1396       --  cases by resolving the prefix to see if it is a subtype mark.
1397
1398       procedure Process_Overloaded_Indexed_Component;
1399       --  If the prefix of an indexed component is overloaded, the proper
1400       --  interpretation is selected by the index types and the context.
1401
1402       ---------------------------
1403       -- Process_Function_Call --
1404       ---------------------------
1405
1406       procedure Process_Function_Call is
1407          Actual : Node_Id;
1408
1409       begin
1410          Change_Node (N, N_Function_Call);
1411          Set_Name (N, P);
1412          Set_Parameter_Associations (N, Exprs);
1413
1414          Actual := First (Parameter_Associations (N));
1415          while Present (Actual) loop
1416             Analyze (Actual);
1417             Check_Parameterless_Call (Actual);
1418             Next_Actual (Actual);
1419          end loop;
1420
1421          Analyze_Call (N);
1422       end Process_Function_Call;
1423
1424       -------------------------------
1425       -- Process_Indexed_Component --
1426       -------------------------------
1427
1428       procedure Process_Indexed_Component is
1429          Exp          : Node_Id;
1430          Array_Type   : Entity_Id;
1431          Index        : Node_Id;
1432          Pent         : Entity_Id := Empty;
1433
1434       begin
1435          Exp := First (Exprs);
1436
1437          if Is_Overloaded (P) then
1438             Process_Overloaded_Indexed_Component;
1439
1440          else
1441             Array_Type := Etype (P);
1442
1443             if Is_Entity_Name (P) then
1444                Pent := Entity (P);
1445             elsif Nkind (P) = N_Selected_Component
1446               and then Is_Entity_Name (Selector_Name (P))
1447             then
1448                Pent := Entity (Selector_Name (P));
1449             end if;
1450
1451             --  Prefix must be appropriate for an array type, taking into
1452             --  account a possible implicit dereference.
1453
1454             if Is_Access_Type (Array_Type) then
1455                Array_Type := Designated_Type (Array_Type);
1456                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
1457                Process_Implicit_Dereference_Prefix (Pent, P);
1458             end if;
1459
1460             if Is_Array_Type (Array_Type) then
1461                null;
1462
1463             elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then
1464                Analyze (Exp);
1465                Set_Etype (N, Any_Type);
1466
1467                if not Has_Compatible_Type
1468                  (Exp, Entry_Index_Type (Pent))
1469                then
1470                   Error_Msg_N ("invalid index type in entry name", N);
1471
1472                elsif Present (Next (Exp)) then
1473                   Error_Msg_N ("too many subscripts in entry reference", N);
1474
1475                else
1476                   Set_Etype (N,  Etype (P));
1477                end if;
1478
1479                return;
1480
1481             elsif Is_Record_Type (Array_Type)
1482               and then Remote_AST_I_Dereference (P)
1483             then
1484                return;
1485
1486             elsif Array_Type = Any_Type then
1487                Set_Etype (N, Any_Type);
1488                return;
1489
1490             --  Here we definitely have a bad indexing
1491
1492             else
1493                if Nkind (Parent (N)) = N_Requeue_Statement
1494                  and then Present (Pent) and then Ekind (Pent) = E_Entry
1495                then
1496                   Error_Msg_N
1497                     ("REQUEUE does not permit parameters", First (Exprs));
1498
1499                elsif Is_Entity_Name (P)
1500                  and then Etype (P) = Standard_Void_Type
1501                then
1502                   Error_Msg_NE ("incorrect use of&", P, Entity (P));
1503
1504                else
1505                   Error_Msg_N ("array type required in indexed component", P);
1506                end if;
1507
1508                Set_Etype (N, Any_Type);
1509                return;
1510             end if;
1511
1512             Index := First_Index (Array_Type);
1513
1514             while Present (Index) and then Present (Exp) loop
1515                if not Has_Compatible_Type (Exp, Etype (Index)) then
1516                   Wrong_Type (Exp, Etype (Index));
1517                   Set_Etype (N, Any_Type);
1518                   return;
1519                end if;
1520
1521                Next_Index (Index);
1522                Next (Exp);
1523             end loop;
1524
1525             Set_Etype (N, Component_Type (Array_Type));
1526
1527             if Present (Index) then
1528                Error_Msg_N
1529                  ("too few subscripts in array reference", First (Exprs));
1530
1531             elsif Present (Exp) then
1532                Error_Msg_N ("too many subscripts in array reference", Exp);
1533             end if;
1534          end if;
1535       end Process_Indexed_Component;
1536
1537       ----------------------------------------
1538       -- Process_Indexed_Component_Or_Slice --
1539       ----------------------------------------
1540
1541       procedure Process_Indexed_Component_Or_Slice is
1542       begin
1543          Exp := First (Exprs);
1544          while Present (Exp) loop
1545             Analyze_Expression (Exp);
1546             Next (Exp);
1547          end loop;
1548
1549          Exp := First (Exprs);
1550
1551          --  If one index is present, and it is a subtype name, then the
1552          --  node denotes a slice (note that the case of an explicit range
1553          --  for a slice was already built as an N_Slice node in the first
1554          --  place, so that case is not handled here).
1555
1556          --  We use a replace rather than a rewrite here because this is one
1557          --  of the cases in which the tree built by the parser is plain wrong.
1558
1559          if No (Next (Exp))
1560            and then Is_Entity_Name (Exp)
1561            and then Is_Type (Entity (Exp))
1562          then
1563             Replace (N,
1564                Make_Slice (Sloc (N),
1565                  Prefix => P,
1566                  Discrete_Range => New_Copy (Exp)));
1567             Analyze (N);
1568
1569          --  Otherwise (more than one index present, or single index is not
1570          --  a subtype name), then we have the indexed component case.
1571
1572          else
1573             Process_Indexed_Component;
1574          end if;
1575       end Process_Indexed_Component_Or_Slice;
1576
1577       ------------------------------------------
1578       -- Process_Overloaded_Indexed_Component --
1579       ------------------------------------------
1580
1581       procedure Process_Overloaded_Indexed_Component is
1582          Exp   : Node_Id;
1583          I     : Interp_Index;
1584          It    : Interp;
1585          Typ   : Entity_Id;
1586          Index : Node_Id;
1587          Found : Boolean;
1588
1589       begin
1590          Set_Etype (N, Any_Type);
1591
1592          Get_First_Interp (P, I, It);
1593          while Present (It.Nam) loop
1594             Typ := It.Typ;
1595
1596             if Is_Access_Type (Typ) then
1597                Typ := Designated_Type (Typ);
1598                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
1599             end if;
1600
1601             if Is_Array_Type (Typ) then
1602
1603                --  Got a candidate: verify that index types are compatible
1604
1605                Index := First_Index (Typ);
1606                Found := True;
1607                Exp := First (Exprs);
1608                while Present (Index) and then Present (Exp) loop
1609                   if Has_Compatible_Type (Exp, Etype (Index)) then
1610                      null;
1611                   else
1612                      Found := False;
1613                      Remove_Interp (I);
1614                      exit;
1615                   end if;
1616
1617                   Next_Index (Index);
1618                   Next (Exp);
1619                end loop;
1620
1621                if Found and then No (Index) and then No (Exp) then
1622                   Add_One_Interp (N,
1623                      Etype (Component_Type (Typ)),
1624                      Etype (Component_Type (Typ)));
1625                end if;
1626             end if;
1627
1628             Get_Next_Interp (I, It);
1629          end loop;
1630
1631          if Etype (N) = Any_Type then
1632             Error_Msg_N ("no legal interpetation for indexed component", N);
1633             Set_Is_Overloaded (N, False);
1634          end if;
1635
1636          End_Interp_List;
1637       end Process_Overloaded_Indexed_Component;
1638
1639    --  Start of processing for Analyze_Indexed_Component_Form
1640
1641    begin
1642       --  Get name of array, function or type
1643
1644       Analyze (P);
1645       if Nkind (N) = N_Function_Call
1646         or else Nkind (N) = N_Procedure_Call_Statement
1647       then
1648          --  If P is an explicit dereference whose prefix is of a
1649          --  remote access-to-subprogram type, then N has already
1650          --  been rewritten as a subprogram call and analyzed.
1651
1652          return;
1653       end if;
1654
1655       pragma Assert (Nkind (N) = N_Indexed_Component);
1656
1657       P_T := Base_Type (Etype (P));
1658
1659       if Is_Entity_Name (P)
1660         or else Nkind (P) = N_Operator_Symbol
1661       then
1662          U_N := Entity (P);
1663
1664          if Ekind (U_N) in Type_Kind then
1665
1666             --  Reformat node as a type conversion
1667
1668             E := Remove_Head (Exprs);
1669
1670             if Present (First (Exprs)) then
1671                Error_Msg_N
1672                 ("argument of type conversion must be single expression", N);
1673             end if;
1674
1675             Change_Node (N, N_Type_Conversion);
1676             Set_Subtype_Mark (N, P);
1677             Set_Etype (N, U_N);
1678             Set_Expression (N, E);
1679
1680             --  After changing the node, call for the specific Analysis
1681             --  routine directly, to avoid a double call to the expander.
1682
1683             Analyze_Type_Conversion (N);
1684             return;
1685          end if;
1686
1687          if Is_Overloadable (U_N) then
1688             Process_Function_Call;
1689
1690          elsif Ekind (Etype (P)) = E_Subprogram_Type
1691            or else (Is_Access_Type (Etype (P))
1692                       and then
1693                     Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type)
1694          then
1695             --  Call to access_to-subprogram with possible implicit dereference
1696
1697             Process_Function_Call;
1698
1699          elsif Is_Generic_Subprogram (U_N) then
1700
1701             --  A common beginner's (or C++ templates fan) error
1702
1703             Error_Msg_N ("generic subprogram cannot be called", N);
1704             Set_Etype (N, Any_Type);
1705             return;
1706
1707          else
1708             Process_Indexed_Component_Or_Slice;
1709          end if;
1710
1711       --  If not an entity name, prefix is an expression that may denote
1712       --  an array or an access-to-subprogram.
1713
1714       else
1715          if Ekind (P_T) = E_Subprogram_Type
1716            or else (Is_Access_Type (P_T)
1717                      and then
1718                     Ekind (Designated_Type (P_T)) = E_Subprogram_Type)
1719          then
1720             Process_Function_Call;
1721
1722          elsif Nkind (P) = N_Selected_Component
1723            and then Is_Overloadable (Entity (Selector_Name (P)))
1724          then
1725             Process_Function_Call;
1726
1727          else
1728             --  Indexed component, slice, or a call to a member of a family
1729             --  entry, which will be converted to an entry call later.
1730
1731             Process_Indexed_Component_Or_Slice;
1732          end if;
1733       end if;
1734    end Analyze_Indexed_Component_Form;
1735
1736    ------------------------
1737    -- Analyze_Logical_Op --
1738    ------------------------
1739
1740    procedure Analyze_Logical_Op (N : Node_Id) is
1741       L     : constant Node_Id := Left_Opnd (N);
1742       R     : constant Node_Id := Right_Opnd (N);
1743       Op_Id : Entity_Id := Entity (N);
1744
1745    begin
1746       Set_Etype (N, Any_Type);
1747       Candidate_Type := Empty;
1748
1749       Analyze_Expression (L);
1750       Analyze_Expression (R);
1751
1752       if Present (Op_Id) then
1753
1754          if Ekind (Op_Id) = E_Operator then
1755             Find_Boolean_Types (L, R, Op_Id, N);
1756          else
1757             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1758          end if;
1759
1760       else
1761          Op_Id := Get_Name_Entity_Id (Chars (N));
1762
1763          while Present (Op_Id) loop
1764             if Ekind (Op_Id) = E_Operator then
1765                Find_Boolean_Types (L, R, Op_Id, N);
1766             else
1767                Analyze_User_Defined_Binary_Op (N, Op_Id);
1768             end if;
1769
1770             Op_Id := Homonym (Op_Id);
1771          end loop;
1772       end if;
1773
1774       Operator_Check (N);
1775    end Analyze_Logical_Op;
1776
1777    ---------------------------
1778    -- Analyze_Membership_Op --
1779    ---------------------------
1780
1781    procedure Analyze_Membership_Op (N : Node_Id) is
1782       L     : constant Node_Id := Left_Opnd (N);
1783       R     : constant Node_Id := Right_Opnd (N);
1784
1785       Index : Interp_Index;
1786       It    : Interp;
1787       Found : Boolean := False;
1788       I_F   : Interp_Index;
1789       T_F   : Entity_Id;
1790
1791       procedure Try_One_Interp (T1 : Entity_Id);
1792       --  Routine to try one proposed interpretation. Note that the context
1793       --  of the operation plays no role in resolving the arguments, so that
1794       --  if there is more than one interpretation of the operands that is
1795       --  compatible with a membership test, the operation is ambiguous.
1796
1797       --------------------
1798       -- Try_One_Interp --
1799       --------------------
1800
1801       procedure Try_One_Interp (T1 : Entity_Id) is
1802       begin
1803          if Has_Compatible_Type (R, T1) then
1804             if Found
1805               and then Base_Type (T1) /= Base_Type (T_F)
1806             then
1807                It := Disambiguate (L, I_F, Index, Any_Type);
1808
1809                if It = No_Interp then
1810                   Ambiguous_Operands (N);
1811                   Set_Etype (L, Any_Type);
1812                   return;
1813
1814                else
1815                   T_F := It.Typ;
1816                end if;
1817
1818             else
1819                Found := True;
1820                T_F   := T1;
1821                I_F   := Index;
1822             end if;
1823
1824             Set_Etype (L, T_F);
1825          end if;
1826
1827       end Try_One_Interp;
1828
1829    --  Start of processing for Analyze_Membership_Op
1830
1831    begin
1832       Analyze_Expression (L);
1833
1834       if Nkind (R) = N_Range
1835         or else (Nkind (R) = N_Attribute_Reference
1836                   and then Attribute_Name (R) = Name_Range)
1837       then
1838          Analyze (R);
1839
1840          if not Is_Overloaded (L) then
1841             Try_One_Interp (Etype (L));
1842
1843          else
1844             Get_First_Interp (L, Index, It);
1845
1846             while Present (It.Typ) loop
1847                Try_One_Interp (It.Typ);
1848                Get_Next_Interp (Index, It);
1849             end loop;
1850          end if;
1851
1852       --  If not a range, it can only be a subtype mark, or else there
1853       --  is a more basic error, to be diagnosed in Find_Type.
1854
1855       else
1856          Find_Type (R);
1857
1858          if Is_Entity_Name (R) then
1859             Check_Fully_Declared (Entity (R), R);
1860          end if;
1861       end if;
1862
1863       --  Compatibility between expression and subtype mark or range is
1864       --  checked during resolution. The result of the operation is Boolean
1865       --  in any case.
1866
1867       Set_Etype (N, Standard_Boolean);
1868    end Analyze_Membership_Op;
1869
1870    ----------------------
1871    -- Analyze_Negation --
1872    ----------------------
1873
1874    procedure Analyze_Negation (N : Node_Id) is
1875       R     : constant Node_Id := Right_Opnd (N);
1876       Op_Id : Entity_Id := Entity (N);
1877
1878    begin
1879       Set_Etype (N, Any_Type);
1880       Candidate_Type := Empty;
1881
1882       Analyze_Expression (R);
1883
1884       if Present (Op_Id) then
1885          if Ekind (Op_Id) = E_Operator then
1886             Find_Negation_Types (R, Op_Id, N);
1887          else
1888             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1889          end if;
1890
1891       else
1892          Op_Id := Get_Name_Entity_Id (Chars (N));
1893          while Present (Op_Id) loop
1894             if Ekind (Op_Id) = E_Operator then
1895                Find_Negation_Types (R, Op_Id, N);
1896             else
1897                Analyze_User_Defined_Unary_Op (N, Op_Id);
1898             end if;
1899
1900             Op_Id := Homonym (Op_Id);
1901          end loop;
1902       end if;
1903
1904       Operator_Check (N);
1905    end Analyze_Negation;
1906
1907    ------------------
1908    -- Analyze_Null --
1909    ------------------
1910
1911    procedure Analyze_Null (N : Node_Id) is
1912    begin
1913       Set_Etype (N, Any_Access);
1914    end Analyze_Null;
1915
1916    ----------------------
1917    -- Analyze_One_Call --
1918    ----------------------
1919
1920    procedure Analyze_One_Call
1921       (N       : Node_Id;
1922        Nam     : Entity_Id;
1923        Report  : Boolean;
1924        Success : out Boolean)
1925    is
1926       Actuals    : constant List_Id   := Parameter_Associations (N);
1927       Prev_T     : constant Entity_Id := Etype (N);
1928       Formal     : Entity_Id;
1929       Actual     : Node_Id;
1930       Is_Indexed : Boolean := False;
1931       Subp_Type  : constant Entity_Id := Etype (Nam);
1932       Norm_OK    : Boolean;
1933
1934       procedure Indicate_Name_And_Type;
1935       --  If candidate interpretation matches, indicate name and type of
1936       --  result on call node.
1937
1938       ----------------------------
1939       -- Indicate_Name_And_Type --
1940       ----------------------------
1941
1942       procedure Indicate_Name_And_Type is
1943       begin
1944          Add_One_Interp (N, Nam, Etype (Nam));
1945          Success := True;
1946
1947          --  If the prefix of the call is a name, indicate the entity
1948          --  being called. If it is not a name,  it is an expression that
1949          --  denotes an access to subprogram or else an entry or family. In
1950          --  the latter case, the name is a selected component, and the entity
1951          --  being called is noted on the selector.
1952
1953          if not Is_Type (Nam) then
1954             if Is_Entity_Name (Name (N))
1955               or else Nkind (Name (N)) = N_Operator_Symbol
1956             then
1957                Set_Entity (Name (N), Nam);
1958
1959             elsif Nkind (Name (N)) = N_Selected_Component then
1960                Set_Entity (Selector_Name (Name (N)),  Nam);
1961             end if;
1962          end if;
1963
1964          if Debug_Flag_E and not Report then
1965             Write_Str (" Overloaded call ");
1966             Write_Int (Int (N));
1967             Write_Str (" compatible with ");
1968             Write_Int (Int (Nam));
1969             Write_Eol;
1970          end if;
1971       end Indicate_Name_And_Type;
1972
1973    --  Start of processing for Analyze_One_Call
1974
1975    begin
1976       Success := False;
1977
1978       --  If the subprogram has no formals, or if all the formals have
1979       --  defaults, and the return type is an array type, the node may
1980       --  denote an indexing of the result of a parameterless call.
1981
1982       if Needs_No_Actuals (Nam)
1983         and then Present (Actuals)
1984       then
1985          if Is_Array_Type (Subp_Type) then
1986             Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type);
1987
1988          elsif Is_Access_Type (Subp_Type)
1989            and then Is_Array_Type (Designated_Type (Subp_Type))
1990          then
1991             Is_Indexed :=
1992               Try_Indexed_Call (N, Nam, Designated_Type (Subp_Type));
1993
1994          --  The prefix can also be a parameterless function that returns an
1995          --  access to subprogram. in which case this is an indirect call.
1996
1997          elsif Is_Access_Type (Subp_Type)
1998            and then Ekind (Designated_Type (Subp_Type))  = E_Subprogram_Type
1999          then
2000             Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type);
2001          end if;
2002
2003       end if;
2004
2005       Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK);
2006
2007       if not Norm_OK then
2008
2009          --  Mismatch in number or names of parameters
2010
2011          if Debug_Flag_E then
2012             Write_Str (" normalization fails in call ");
2013             Write_Int (Int (N));
2014             Write_Str (" with subprogram ");
2015             Write_Int (Int (Nam));
2016             Write_Eol;
2017          end if;
2018
2019       --  If the context expects a function call, discard any interpretation
2020       --  that is a procedure. If the node is not overloaded, leave as is for
2021       --  better error reporting when type mismatch is found.
2022
2023       elsif Nkind (N) = N_Function_Call
2024         and then Is_Overloaded (Name (N))
2025         and then Ekind (Nam) = E_Procedure
2026       then
2027          return;
2028
2029       --  Ditto for function calls in a procedure context
2030
2031       elsif Nkind (N) = N_Procedure_Call_Statement
2032          and then Is_Overloaded (Name (N))
2033          and then Etype (Nam) /= Standard_Void_Type
2034       then
2035          return;
2036
2037       elsif not Present (Actuals) then
2038
2039          --  If Normalize succeeds, then there are default parameters for
2040          --  all formals.
2041
2042          Indicate_Name_And_Type;
2043
2044       elsif Ekind (Nam) = E_Operator then
2045          if Nkind (N) = N_Procedure_Call_Statement then
2046             return;
2047          end if;
2048
2049          --  This can occur when the prefix of the call is an operator
2050          --  name or an expanded name whose selector is an operator name.
2051
2052          Analyze_Operator_Call (N, Nam);
2053
2054          if Etype (N) /= Prev_T then
2055
2056             --  There may be a user-defined operator that hides the
2057             --  current interpretation. We must check for this independently
2058             --  of the analysis of the call with the user-defined operation,
2059             --  because the parameter names may be wrong and yet the hiding
2060             --  takes place. Fixes b34014o.
2061
2062             if Is_Overloaded (Name (N)) then
2063                declare
2064                   I  : Interp_Index;
2065                   It : Interp;
2066
2067                begin
2068                   Get_First_Interp (Name (N), I, It);
2069                   while Present (It.Nam) loop
2070                      if Ekind (It.Nam) /= E_Operator
2071                         and then Hides_Op (It.Nam, Nam)
2072                         and then
2073                           Has_Compatible_Type
2074                             (First_Actual (N), Etype (First_Formal (It.Nam)))
2075                         and then (No (Next_Actual (First_Actual (N)))
2076                            or else Has_Compatible_Type
2077                             (Next_Actual (First_Actual (N)),
2078                              Etype (Next_Formal (First_Formal (It.Nam)))))
2079                      then
2080                         Set_Etype (N, Prev_T);
2081                         return;
2082                      end if;
2083
2084                      Get_Next_Interp (I, It);
2085                   end loop;
2086                end;
2087             end if;
2088
2089             --  If operator matches formals, record its name on the call.
2090             --  If the operator is overloaded, Resolve will select the
2091             --  correct one from the list of interpretations. The call
2092             --  node itself carries the first candidate.
2093
2094             Set_Entity (Name (N), Nam);
2095             Success := True;
2096
2097          elsif Report and then Etype (N) = Any_Type then
2098             Error_Msg_N ("incompatible arguments for operator", N);
2099          end if;
2100
2101       else
2102          --  Normalize_Actuals has chained the named associations in the
2103          --  correct order of the formals.
2104
2105          Actual := First_Actual (N);
2106          Formal := First_Formal (Nam);
2107          while Present (Actual) and then Present (Formal) loop
2108             if Nkind (Parent (Actual)) /= N_Parameter_Association
2109               or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
2110             then
2111                if Has_Compatible_Type (Actual, Etype (Formal)) then
2112                   Next_Actual (Actual);
2113                   Next_Formal (Formal);
2114
2115                else
2116                   if Debug_Flag_E then
2117                      Write_Str (" type checking fails in call ");
2118                      Write_Int (Int (N));
2119                      Write_Str (" with formal ");
2120                      Write_Int (Int (Formal));
2121                      Write_Str (" in subprogram ");
2122                      Write_Int (Int (Nam));
2123                      Write_Eol;
2124                   end if;
2125
2126                   if Report and not Is_Indexed then
2127
2128                      --  Ada 2005 (AI-251): Complete the error notification
2129                      --  to help new Ada 2005 users
2130
2131                      if Is_Class_Wide_Type (Etype (Formal))
2132                        and then Is_Interface (Etype (Etype (Formal)))
2133                        and then not Interface_Present_In_Ancestor
2134                                       (Typ   => Etype (Actual),
2135                                        Iface => Etype (Etype (Formal)))
2136                      then
2137                         Error_Msg_Name_1 := Chars (Actual);
2138                         Error_Msg_Name_2 := Chars (Etype (Etype (Formal)));
2139                         Error_Msg_NE
2140                           ("(Ada 2005) % does not implement interface %",
2141                            Actual, Etype (Etype (Formal)));
2142                      end if;
2143
2144                      Wrong_Type (Actual, Etype (Formal));
2145
2146                      if Nkind (Actual) = N_Op_Eq
2147                        and then Nkind (Left_Opnd (Actual)) = N_Identifier
2148                      then
2149                         Formal := First_Formal (Nam);
2150
2151                         while Present (Formal) loop
2152
2153                            if Chars (Left_Opnd (Actual)) = Chars (Formal) then
2154                               Error_Msg_N
2155                                 ("possible misspelling of `='>`!", Actual);
2156                               exit;
2157                            end if;
2158
2159                            Next_Formal (Formal);
2160                         end loop;
2161                      end if;
2162
2163                      if All_Errors_Mode then
2164                         Error_Msg_Sloc := Sloc (Nam);
2165
2166                         if Is_Overloadable (Nam)
2167                           and then Present (Alias (Nam))
2168                           and then not Comes_From_Source (Nam)
2169                         then
2170                            Error_Msg_NE
2171                              ("  =='> in call to &#(inherited)!", Actual, Nam);
2172
2173                         elsif Ekind (Nam) = E_Subprogram_Type then
2174                            declare
2175                               Access_To_Subprogram_Typ :
2176                                 constant Entity_Id :=
2177                                   Defining_Identifier
2178                                     (Associated_Node_For_Itype (Nam));
2179                            begin
2180                               Error_Msg_NE (
2181                                 "  =='> in call to dereference of &#!",
2182                                 Actual, Access_To_Subprogram_Typ);
2183                            end;
2184
2185                         else
2186                            Error_Msg_NE ("  =='> in call to &#!", Actual, Nam);
2187
2188                         end if;
2189                      end if;
2190                   end if;
2191
2192                   return;
2193                end if;
2194
2195             else
2196                --  Normalize_Actuals has verified that a default value exists
2197                --  for this formal. Current actual names a subsequent formal.
2198
2199                Next_Formal (Formal);
2200             end if;
2201          end loop;
2202
2203          --  On exit, all actuals match
2204
2205          Indicate_Name_And_Type;
2206       end if;
2207    end Analyze_One_Call;
2208
2209    ---------------------------
2210    -- Analyze_Operator_Call --
2211    ---------------------------
2212
2213    procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
2214       Op_Name : constant Name_Id := Chars (Op_Id);
2215       Act1    : constant Node_Id := First_Actual (N);
2216       Act2    : constant Node_Id := Next_Actual (Act1);
2217
2218    begin
2219       --  Binary operator case
2220
2221       if Present (Act2) then
2222
2223          --  If more than two operands, then not binary operator after all
2224
2225          if Present (Next_Actual (Act2)) then
2226             return;
2227
2228          elsif     Op_Name = Name_Op_Add
2229            or else Op_Name = Name_Op_Subtract
2230            or else Op_Name = Name_Op_Multiply
2231            or else Op_Name = Name_Op_Divide
2232            or else Op_Name = Name_Op_Mod
2233            or else Op_Name = Name_Op_Rem
2234            or else Op_Name = Name_Op_Expon
2235          then
2236             Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
2237
2238          elsif     Op_Name =  Name_Op_And
2239            or else Op_Name = Name_Op_Or
2240            or else Op_Name = Name_Op_Xor
2241          then
2242             Find_Boolean_Types (Act1, Act2, Op_Id, N);
2243
2244          elsif     Op_Name = Name_Op_Lt
2245            or else Op_Name = Name_Op_Le
2246            or else Op_Name = Name_Op_Gt
2247            or else Op_Name = Name_Op_Ge
2248          then
2249             Find_Comparison_Types (Act1, Act2, Op_Id,  N);
2250
2251          elsif     Op_Name = Name_Op_Eq
2252            or else Op_Name = Name_Op_Ne
2253          then
2254             Find_Equality_Types (Act1, Act2, Op_Id,  N);
2255
2256          elsif     Op_Name = Name_Op_Concat then
2257             Find_Concatenation_Types (Act1, Act2, Op_Id, N);
2258
2259          --  Is this else null correct, or should it be an abort???
2260
2261          else
2262             null;
2263          end if;
2264
2265       --  Unary operator case
2266
2267       else
2268          if Op_Name = Name_Op_Subtract or else
2269             Op_Name = Name_Op_Add      or else
2270             Op_Name = Name_Op_Abs
2271          then
2272             Find_Unary_Types (Act1, Op_Id, N);
2273
2274          elsif
2275             Op_Name = Name_Op_Not
2276          then
2277             Find_Negation_Types (Act1, Op_Id, N);
2278
2279          --  Is this else null correct, or should it be an abort???
2280
2281          else
2282             null;
2283          end if;
2284       end if;
2285    end Analyze_Operator_Call;
2286
2287    -------------------------------------------
2288    -- Analyze_Overloaded_Selected_Component --
2289    -------------------------------------------
2290
2291    procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is
2292       Nam   : constant Node_Id := Prefix (N);
2293       Sel   : constant Node_Id := Selector_Name (N);
2294       Comp  : Entity_Id;
2295       I     : Interp_Index;
2296       It    : Interp;
2297       T     : Entity_Id;
2298
2299    begin
2300       Set_Etype (Sel, Any_Type);
2301
2302       Get_First_Interp (Nam, I, It);
2303       while Present (It.Typ) loop
2304          if Is_Access_Type (It.Typ) then
2305             T := Designated_Type (It.Typ);
2306             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2307          else
2308             T := It.Typ;
2309          end if;
2310
2311          if Is_Record_Type (T) then
2312             Comp := First_Entity (T);
2313             while Present (Comp) loop
2314                if Chars (Comp) = Chars (Sel)
2315                  and then Is_Visible_Component (Comp)
2316                then
2317                   Set_Entity_With_Style_Check (Sel, Comp);
2318                   Generate_Reference (Comp, Sel);
2319
2320                   Set_Etype (Sel, Etype (Comp));
2321                   Add_One_Interp (N, Etype (Comp), Etype (Comp));
2322
2323                   --  This also specifies a candidate to resolve the name.
2324                   --  Further overloading will be resolved from context.
2325
2326                   Set_Etype (Nam, It.Typ);
2327                end if;
2328
2329                Next_Entity (Comp);
2330             end loop;
2331
2332          elsif Is_Concurrent_Type (T) then
2333             Comp := First_Entity (T);
2334             while Present (Comp)
2335               and then Comp /= First_Private_Entity (T)
2336             loop
2337                if Chars (Comp) = Chars (Sel) then
2338                   if Is_Overloadable (Comp) then
2339                      Add_One_Interp (Sel, Comp, Etype (Comp));
2340                   else
2341                      Set_Entity_With_Style_Check (Sel, Comp);
2342                      Generate_Reference (Comp, Sel);
2343                   end if;
2344
2345                   Set_Etype (Sel, Etype (Comp));
2346                   Set_Etype (N,   Etype (Comp));
2347                   Set_Etype (Nam, It.Typ);
2348
2349                   --  For access type case, introduce explicit deference for
2350                   --  more uniform treatment of entry calls.
2351
2352                   if Is_Access_Type (Etype (Nam)) then
2353                      Insert_Explicit_Dereference (Nam);
2354                      Error_Msg_NW
2355                        (Warn_On_Dereference, "?implicit dereference", N);
2356                   end if;
2357                end if;
2358
2359                Next_Entity (Comp);
2360             end loop;
2361
2362             Set_Is_Overloaded (N, Is_Overloaded (Sel));
2363          end if;
2364
2365          Get_Next_Interp (I, It);
2366       end loop;
2367
2368       if Etype (N) = Any_Type then
2369          Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
2370          Set_Entity (Sel, Any_Id);
2371          Set_Etype  (Sel, Any_Type);
2372       end if;
2373    end Analyze_Overloaded_Selected_Component;
2374
2375    ----------------------------------
2376    -- Analyze_Qualified_Expression --
2377    ----------------------------------
2378
2379    procedure Analyze_Qualified_Expression (N : Node_Id) is
2380       Mark : constant Entity_Id := Subtype_Mark (N);
2381       T    : Entity_Id;
2382
2383    begin
2384       Set_Etype (N, Any_Type);
2385       Find_Type (Mark);
2386       T := Entity (Mark);
2387
2388       if T = Any_Type then
2389          return;
2390       end if;
2391
2392       Check_Fully_Declared (T, N);
2393       Analyze_Expression (Expression (N));
2394       Set_Etype  (N, T);
2395    end Analyze_Qualified_Expression;
2396
2397    -------------------
2398    -- Analyze_Range --
2399    -------------------
2400
2401    procedure Analyze_Range (N : Node_Id) is
2402       L        : constant Node_Id := Low_Bound (N);
2403       H        : constant Node_Id := High_Bound (N);
2404       I1, I2   : Interp_Index;
2405       It1, It2 : Interp;
2406
2407       procedure Check_Common_Type (T1, T2 : Entity_Id);
2408       --  Verify the compatibility of two types,  and choose the
2409       --  non universal one if the other is universal.
2410
2411       procedure Check_High_Bound (T : Entity_Id);
2412       --  Test one interpretation of the low bound against all those
2413       --  of the high bound.
2414
2415       procedure Check_Universal_Expression (N : Node_Id);
2416       --  In Ada83, reject bounds of a universal range that are not
2417       --  literals or entity names.
2418
2419       -----------------------
2420       -- Check_Common_Type --
2421       -----------------------
2422
2423       procedure Check_Common_Type (T1, T2 : Entity_Id) is
2424       begin
2425          if Covers (T1, T2) or else Covers (T2, T1) then
2426             if T1 = Universal_Integer
2427               or else T1 = Universal_Real
2428               or else T1 = Any_Character
2429             then
2430                Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
2431
2432             elsif T1 = T2 then
2433                Add_One_Interp (N, T1, T1);
2434
2435             else
2436                Add_One_Interp (N, Base_Type (T1), Base_Type (T1));
2437             end if;
2438          end if;
2439       end Check_Common_Type;
2440
2441       ----------------------
2442       -- Check_High_Bound --
2443       ----------------------
2444
2445       procedure Check_High_Bound (T : Entity_Id) is
2446       begin
2447          if not Is_Overloaded (H) then
2448             Check_Common_Type (T, Etype (H));
2449          else
2450             Get_First_Interp (H, I2, It2);
2451             while Present (It2.Typ) loop
2452                Check_Common_Type (T, It2.Typ);
2453                Get_Next_Interp (I2, It2);
2454             end loop;
2455          end if;
2456       end Check_High_Bound;
2457
2458       -----------------------------
2459       -- Is_Universal_Expression --
2460       -----------------------------
2461
2462       procedure Check_Universal_Expression (N : Node_Id) is
2463       begin
2464          if Etype (N) = Universal_Integer
2465            and then Nkind (N) /= N_Integer_Literal
2466            and then not Is_Entity_Name (N)
2467            and then Nkind (N) /= N_Attribute_Reference
2468          then
2469             Error_Msg_N ("illegal bound in discrete range", N);
2470          end if;
2471       end Check_Universal_Expression;
2472
2473    --  Start of processing for Analyze_Range
2474
2475    begin
2476       Set_Etype (N, Any_Type);
2477       Analyze_Expression (L);
2478       Analyze_Expression (H);
2479
2480       if Etype (L) = Any_Type or else Etype (H) = Any_Type then
2481          return;
2482
2483       else
2484          if not Is_Overloaded (L) then
2485             Check_High_Bound (Etype (L));
2486          else
2487             Get_First_Interp (L, I1, It1);
2488             while Present (It1.Typ) loop
2489                Check_High_Bound (It1.Typ);
2490                Get_Next_Interp (I1, It1);
2491             end loop;
2492          end if;
2493
2494          --  If result is Any_Type, then we did not find a compatible pair
2495
2496          if Etype (N) = Any_Type then
2497             Error_Msg_N ("incompatible types in range ", N);
2498          end if;
2499       end if;
2500
2501       if Ada_Version = Ada_83
2502         and then
2503           (Nkind (Parent (N)) = N_Loop_Parameter_Specification
2504              or else Nkind (Parent (N)) = N_Constrained_Array_Definition)
2505       then
2506          Check_Universal_Expression (L);
2507          Check_Universal_Expression (H);
2508       end if;
2509    end Analyze_Range;
2510
2511    -----------------------
2512    -- Analyze_Reference --
2513    -----------------------
2514
2515    procedure Analyze_Reference (N : Node_Id) is
2516       P        : constant Node_Id := Prefix (N);
2517       Acc_Type : Entity_Id;
2518    begin
2519       Analyze (P);
2520       Acc_Type := Create_Itype (E_Allocator_Type, N);
2521       Set_Etype                    (Acc_Type,  Acc_Type);
2522       Init_Size_Align              (Acc_Type);
2523       Set_Directly_Designated_Type (Acc_Type, Etype (P));
2524       Set_Etype (N, Acc_Type);
2525    end Analyze_Reference;
2526
2527    --------------------------------
2528    -- Analyze_Selected_Component --
2529    --------------------------------
2530
2531    --  Prefix is a record type or a task or protected type. In the
2532    --  later case, the selector must denote a visible entry.
2533
2534    procedure Analyze_Selected_Component (N : Node_Id) is
2535       Name        : constant Node_Id := Prefix (N);
2536       Sel         : constant Node_Id := Selector_Name (N);
2537       Comp        : Entity_Id;
2538       Entity_List : Entity_Id;
2539       Prefix_Type : Entity_Id;
2540       Pent        : Entity_Id := Empty;
2541       Act_Decl    : Node_Id;
2542       In_Scope    : Boolean;
2543       Parent_N    : Node_Id;
2544
2545    --  Start of processing for Analyze_Selected_Component
2546
2547    begin
2548       Set_Etype (N, Any_Type);
2549
2550       if Is_Overloaded (Name) then
2551          Analyze_Overloaded_Selected_Component (N);
2552          return;
2553
2554       elsif Etype (Name) = Any_Type then
2555          Set_Entity (Sel, Any_Id);
2556          Set_Etype (Sel, Any_Type);
2557          return;
2558
2559       else
2560          --  Function calls that are prefixes of selected components must be
2561          --  fully resolved in case we need to build an actual subtype, or
2562          --  do some other operation requiring a fully resolved prefix.
2563
2564          --  Note: Resolving all Nkinds of nodes here doesn't work.
2565          --  (Breaks 2129-008) ???.
2566
2567          if Nkind (Name) = N_Function_Call then
2568             Resolve (Name);
2569          end if;
2570
2571          Prefix_Type := Etype (Name);
2572       end if;
2573
2574       if Is_Access_Type (Prefix_Type) then
2575
2576          --  A RACW object can never be used as prefix of a selected
2577          --  component since that means it is dereferenced without
2578          --  being a controlling operand of a dispatching operation
2579          --  (RM E.2.2(15)).
2580
2581          if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
2582            and then Comes_From_Source (N)
2583          then
2584             Error_Msg_N
2585               ("invalid dereference of a remote access to class-wide value",
2586                N);
2587
2588          --  Normal case of selected component applied to access type
2589
2590          else
2591             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2592
2593             if Is_Entity_Name (Name) then
2594                Pent := Entity (Name);
2595             elsif Nkind (Name) = N_Selected_Component
2596               and then Is_Entity_Name (Selector_Name (Name))
2597             then
2598                Pent := Entity (Selector_Name (Name));
2599             end if;
2600
2601             Process_Implicit_Dereference_Prefix (Pent, Name);
2602          end if;
2603
2604          Prefix_Type := Designated_Type (Prefix_Type);
2605       end if;
2606
2607       if Ekind (Prefix_Type) = E_Private_Subtype then
2608          Prefix_Type := Base_Type (Prefix_Type);
2609       end if;
2610
2611       Entity_List := Prefix_Type;
2612
2613       --  For class-wide types, use the entity list of the root type. This
2614       --  indirection is specially important for private extensions because
2615       --  only the root type get switched (not the class-wide type).
2616
2617       if Is_Class_Wide_Type (Prefix_Type) then
2618          Entity_List := Root_Type (Prefix_Type);
2619       end if;
2620
2621       Comp := First_Entity (Entity_List);
2622
2623       --  If the selector has an original discriminant, the node appears in
2624       --  an instance. Replace the discriminant with the corresponding one
2625       --  in the current discriminated type. For nested generics, this must
2626       --  be done transitively, so note the new original discriminant.
2627
2628       if Nkind (Sel) = N_Identifier
2629         and then Present (Original_Discriminant (Sel))
2630       then
2631          Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
2632
2633          --  Mark entity before rewriting, for completeness and because
2634          --  subsequent semantic checks might examine the original node.
2635
2636          Set_Entity (Sel, Comp);
2637          Rewrite (Selector_Name (N),
2638            New_Occurrence_Of (Comp, Sloc (N)));
2639          Set_Original_Discriminant (Selector_Name (N), Comp);
2640          Set_Etype (N, Etype (Comp));
2641
2642          if Is_Access_Type (Etype (Name)) then
2643             Insert_Explicit_Dereference (Name);
2644             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2645          end if;
2646
2647       elsif Is_Record_Type (Prefix_Type) then
2648
2649          --  Find component with given name
2650
2651          while Present (Comp) loop
2652             if Chars (Comp) = Chars (Sel)
2653               and then Is_Visible_Component (Comp)
2654             then
2655                Set_Entity_With_Style_Check (Sel, Comp);
2656                Generate_Reference (Comp, Sel);
2657
2658                Set_Etype (Sel, Etype (Comp));
2659
2660                if Ekind (Comp) = E_Discriminant then
2661                   if Is_Unchecked_Union (Base_Type (Prefix_Type)) then
2662                      Error_Msg_N
2663                        ("cannot reference discriminant of Unchecked_Union",
2664                         Sel);
2665                   end if;
2666
2667                   if Is_Generic_Type (Prefix_Type)
2668                        or else
2669                      Is_Generic_Type (Root_Type (Prefix_Type))
2670                   then
2671                      Set_Original_Discriminant (Sel, Comp);
2672                   end if;
2673                end if;
2674
2675                --  Resolve the prefix early otherwise it is not possible to
2676                --  build the actual subtype of the component: it may need
2677                --  to duplicate this prefix and duplication is only allowed
2678                --  on fully resolved expressions.
2679
2680                Resolve (Name);
2681
2682                --  We never need an actual subtype for the case of a selection
2683                --  for a indexed component of a non-packed array, since in
2684                --  this case gigi generates all the checks and can find the
2685                --  necessary bounds information.
2686
2687                --  We also do not need an actual subtype for the case of
2688                --  a first, last, length, or range attribute applied to a
2689                --  non-packed array, since gigi can again get the bounds in
2690                --  these cases (gigi cannot handle the packed case, since it
2691                --  has the bounds of the packed array type, not the original
2692                --  bounds of the type). However, if the prefix is itself a
2693                --  selected component, as in a.b.c (i), gigi may regard a.b.c
2694                --  as a dynamic-sized temporary, so we do generate an actual
2695                --  subtype for this case.
2696
2697                Parent_N := Parent (N);
2698
2699                if not Is_Packed (Etype (Comp))
2700                  and then
2701                    ((Nkind (Parent_N) = N_Indexed_Component
2702                       and then Nkind (Name) /= N_Selected_Component)
2703                      or else
2704                       (Nkind (Parent_N) = N_Attribute_Reference
2705                          and then (Attribute_Name (Parent_N) = Name_First
2706                                      or else
2707                                    Attribute_Name (Parent_N) = Name_Last
2708                                      or else
2709                                    Attribute_Name (Parent_N) = Name_Length
2710                                      or else
2711                                    Attribute_Name (Parent_N) = Name_Range)))
2712                then
2713                   Set_Etype (N, Etype (Comp));
2714
2715                --  If full analysis is not enabled, we do not generate an
2716                --  actual subtype, because in the absence of expansion
2717                --  reference to a formal of a protected type, for example,
2718                --  will not be properly transformed, and will lead to
2719                --  out-of-scope references in gigi.
2720
2721                --  In all other cases, we currently build an actual subtype.
2722                --  It seems likely that many of these cases can be avoided,
2723                --  but right now, the front end makes direct references to the
2724                --  bounds (e.g. in generating a length check), and if we do
2725                --  not make an actual subtype, we end up getting a direct
2726                --  reference to a discriminant, which will not do.
2727
2728                elsif Full_Analysis then
2729                   Act_Decl :=
2730                     Build_Actual_Subtype_Of_Component (Etype (Comp), N);
2731                   Insert_Action (N, Act_Decl);
2732
2733                   if No (Act_Decl) then
2734                      Set_Etype (N, Etype (Comp));
2735
2736                   else
2737                      --  Component type depends on discriminants. Enter the
2738                      --  main attributes of the subtype.
2739
2740                      declare
2741                         Subt : constant Entity_Id :=
2742                                  Defining_Identifier (Act_Decl);
2743
2744                      begin
2745                         Set_Etype (Subt, Base_Type (Etype (Comp)));
2746                         Set_Ekind (Subt, Ekind (Etype (Comp)));
2747                         Set_Etype (N, Subt);
2748                      end;
2749                   end if;
2750
2751                --  If Full_Analysis not enabled, just set the Etype
2752
2753                else
2754                   Set_Etype (N, Etype (Comp));
2755                end if;
2756
2757                return;
2758             end if;
2759
2760             Next_Entity (Comp);
2761          end loop;
2762
2763          --  Ada 2005 (AI-252)
2764
2765          if Ada_Version >= Ada_05
2766            and then Is_Tagged_Type (Prefix_Type)
2767            and then Try_Object_Operation (N)
2768          then
2769             return;
2770
2771             --  If the transformation fails, it will be necessary to redo the
2772             --  analysis with all errors enabled, to indicate candidate
2773             --  interpretations and reasons for each failure ???
2774
2775          end if;
2776
2777       elsif Is_Private_Type (Prefix_Type) then
2778
2779          --  Allow access only to discriminants of the type. If the type has
2780          --  no full view, gigi uses the parent type for the components, so we
2781          --  do the same here.
2782
2783          if No (Full_View (Prefix_Type)) then
2784             Entity_List := Root_Type (Base_Type (Prefix_Type));
2785             Comp := First_Entity (Entity_List);
2786          end if;
2787
2788          while Present (Comp) loop
2789             if Chars (Comp) = Chars (Sel) then
2790                if Ekind (Comp) = E_Discriminant then
2791                   Set_Entity_With_Style_Check (Sel, Comp);
2792                   Generate_Reference (Comp, Sel);
2793
2794                   Set_Etype (Sel, Etype (Comp));
2795                   Set_Etype (N,   Etype (Comp));
2796
2797                   if Is_Generic_Type (Prefix_Type)
2798                     or else
2799                      Is_Generic_Type (Root_Type (Prefix_Type))
2800                   then
2801                      Set_Original_Discriminant (Sel, Comp);
2802                   end if;
2803
2804                else
2805                   Error_Msg_NE
2806                     ("invisible selector for }",
2807                      N, First_Subtype (Prefix_Type));
2808                   Set_Entity (Sel, Any_Id);
2809                   Set_Etype (N, Any_Type);
2810                end if;
2811
2812                return;
2813             end if;
2814
2815             Next_Entity (Comp);
2816          end loop;
2817
2818       elsif Is_Concurrent_Type (Prefix_Type) then
2819
2820          --  Prefix is concurrent type. Find visible operation with given name
2821          --  For a task, this can only include entries or discriminants if the
2822          --  task type is not an enclosing scope. If it is an enclosing scope
2823          --  (e.g. in an inner task) then all entities are visible, but the
2824          --  prefix must denote the enclosing scope, i.e. can only be a direct
2825          --  name or an expanded name.
2826
2827          Set_Etype (Sel,  Any_Type);
2828          In_Scope := In_Open_Scopes (Prefix_Type);
2829
2830          while Present (Comp) loop
2831             if Chars (Comp) = Chars (Sel) then
2832                if Is_Overloadable (Comp) then
2833                   Add_One_Interp (Sel, Comp, Etype (Comp));
2834
2835                elsif Ekind (Comp) = E_Discriminant
2836                  or else Ekind (Comp) = E_Entry_Family
2837                  or else (In_Scope
2838                    and then Is_Entity_Name (Name))
2839                then
2840                   Set_Entity_With_Style_Check (Sel, Comp);
2841                   Generate_Reference (Comp, Sel);
2842
2843                else
2844                   goto Next_Comp;
2845                end if;
2846
2847                Set_Etype (Sel, Etype (Comp));
2848                Set_Etype (N,   Etype (Comp));
2849
2850                if Ekind (Comp) = E_Discriminant then
2851                   Set_Original_Discriminant (Sel, Comp);
2852                end if;
2853
2854                --  For access type case, introduce explicit deference for more
2855                --  uniform treatment of entry calls.
2856
2857                if Is_Access_Type (Etype (Name)) then
2858                   Insert_Explicit_Dereference (Name);
2859                   Error_Msg_NW
2860                     (Warn_On_Dereference, "?implicit dereference", N);
2861                end if;
2862             end if;
2863
2864             <<Next_Comp>>
2865                Next_Entity (Comp);
2866                exit when not In_Scope
2867                  and then
2868                    Comp = First_Private_Entity (Base_Type (Prefix_Type));
2869          end loop;
2870
2871          Set_Is_Overloaded (N, Is_Overloaded (Sel));
2872
2873       else
2874          --  Invalid prefix
2875
2876          Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
2877       end if;
2878
2879       --  If N still has no type, the component is not defined in the prefix
2880
2881       if Etype (N) = Any_Type then
2882
2883          --  If the prefix is a single concurrent object, use its name in the
2884          --  error message, rather than that of its anonymous type.
2885
2886          if Is_Concurrent_Type (Prefix_Type)
2887            and then Is_Internal_Name (Chars (Prefix_Type))
2888            and then not Is_Derived_Type (Prefix_Type)
2889            and then Is_Entity_Name (Name)
2890          then
2891
2892             Error_Msg_Node_2 := Entity (Name);
2893             Error_Msg_NE ("no selector& for&", N, Sel);
2894
2895             Check_Misspelled_Selector (Entity_List, Sel);
2896
2897          elsif Is_Generic_Type (Prefix_Type)
2898            and then Ekind (Prefix_Type) = E_Record_Type_With_Private
2899            and then Prefix_Type /= Etype (Prefix_Type)
2900            and then Is_Record_Type (Etype (Prefix_Type))
2901          then
2902             --  If this is a derived formal type, the parent may have
2903             --  different visibility at this point. Try for an inherited
2904             --  component before reporting an error.
2905
2906             Set_Etype (Prefix (N), Etype (Prefix_Type));
2907             Analyze_Selected_Component (N);
2908             return;
2909
2910          elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private
2911            and then Is_Generic_Actual_Type (Prefix_Type)
2912            and then Present (Full_View (Prefix_Type))
2913          then
2914             --  Similarly, if this the actual for a formal derived type, the
2915             --  component inherited from the generic parent may not be visible
2916             --  in the actual, but the selected component is legal.
2917
2918             declare
2919                Comp : Entity_Id;
2920
2921             begin
2922                Comp :=
2923                  First_Component (Generic_Parent_Type (Parent (Prefix_Type)));
2924                while Present (Comp) loop
2925                   if Chars (Comp) = Chars (Sel) then
2926                      Set_Entity_With_Style_Check (Sel, Comp);
2927                      Set_Etype (Sel, Etype (Comp));
2928                      Set_Etype (N,   Etype (Comp));
2929                      exit;
2930                   end if;
2931
2932                   Next_Component (Comp);
2933                end loop;
2934
2935                pragma Assert (Etype (N) /= Any_Type);
2936             end;
2937
2938          else
2939             if Ekind (Prefix_Type) = E_Record_Subtype then
2940
2941                --  Check whether this is a component of the base type
2942                --  which is absent from a statically constrained subtype.
2943                --  This will raise constraint error at run-time, but is
2944                --  not a compile-time error. When the selector is illegal
2945                --  for base type as well fall through and generate a
2946                --  compilation error anyway.
2947
2948                Comp := First_Component (Base_Type (Prefix_Type));
2949                while Present (Comp) loop
2950                   if Chars (Comp) = Chars (Sel)
2951                     and then Is_Visible_Component (Comp)
2952                   then
2953                      Set_Entity_With_Style_Check (Sel, Comp);
2954                      Generate_Reference (Comp, Sel);
2955                      Set_Etype (Sel, Etype (Comp));
2956                      Set_Etype (N,   Etype (Comp));
2957
2958                      --  Emit appropriate message. Gigi will replace the
2959                      --  node subsequently with the appropriate Raise.
2960
2961                      Apply_Compile_Time_Constraint_Error
2962                        (N, "component not present in }?",
2963                         CE_Discriminant_Check_Failed,
2964                         Ent => Prefix_Type, Rep => False);
2965                      Set_Raises_Constraint_Error (N);
2966                      return;
2967                   end if;
2968
2969                   Next_Component (Comp);
2970                end loop;
2971
2972             end if;
2973
2974             Error_Msg_Node_2 := First_Subtype (Prefix_Type);
2975             Error_Msg_NE ("no selector& for}", N, Sel);
2976
2977             Check_Misspelled_Selector (Entity_List, Sel);
2978
2979          end if;
2980
2981          Set_Entity (Sel, Any_Id);
2982          Set_Etype (Sel, Any_Type);
2983       end if;
2984    end Analyze_Selected_Component;
2985
2986    ---------------------------
2987    -- Analyze_Short_Circuit --
2988    ---------------------------
2989
2990    procedure Analyze_Short_Circuit (N : Node_Id) is
2991       L   : constant Node_Id := Left_Opnd  (N);
2992       R   : constant Node_Id := Right_Opnd (N);
2993       Ind : Interp_Index;
2994       It  : Interp;
2995
2996    begin
2997       Analyze_Expression (L);
2998       Analyze_Expression (R);
2999       Set_Etype (N, Any_Type);
3000
3001       if not Is_Overloaded (L) then
3002
3003          if Root_Type (Etype (L)) = Standard_Boolean
3004            and then Has_Compatible_Type (R, Etype (L))
3005          then
3006             Add_One_Interp (N, Etype (L), Etype (L));
3007          end if;
3008
3009       else
3010          Get_First_Interp (L, Ind, It);
3011
3012          while Present (It.Typ) loop
3013             if Root_Type (It.Typ) = Standard_Boolean
3014               and then Has_Compatible_Type (R, It.Typ)
3015             then
3016                Add_One_Interp (N, It.Typ, It.Typ);
3017             end if;
3018
3019             Get_Next_Interp (Ind, It);
3020          end loop;
3021       end if;
3022
3023       --  Here we have failed to find an interpretation. Clearly we
3024       --  know that it is not the case that both operands can have
3025       --  an interpretation of Boolean, but this is by far the most
3026       --  likely intended interpretation. So we simply resolve both
3027       --  operands as Booleans, and at least one of these resolutions
3028       --  will generate an error message, and we do not need to give
3029       --  a further error message on the short circuit operation itself.
3030
3031       if Etype (N) = Any_Type then
3032          Resolve (L, Standard_Boolean);
3033          Resolve (R, Standard_Boolean);
3034          Set_Etype (N, Standard_Boolean);
3035       end if;
3036    end Analyze_Short_Circuit;
3037
3038    -------------------
3039    -- Analyze_Slice --
3040    -------------------
3041
3042    procedure Analyze_Slice (N : Node_Id) is
3043       P          : constant Node_Id := Prefix (N);
3044       D          : constant Node_Id := Discrete_Range (N);
3045       Array_Type : Entity_Id;
3046
3047       procedure Analyze_Overloaded_Slice;
3048       --  If the prefix is overloaded, select those interpretations that
3049       --  yield a one-dimensional array type.
3050
3051       ------------------------------
3052       -- Analyze_Overloaded_Slice --
3053       ------------------------------
3054
3055       procedure Analyze_Overloaded_Slice is
3056          I   : Interp_Index;
3057          It  : Interp;
3058          Typ : Entity_Id;
3059
3060       begin
3061          Set_Etype (N, Any_Type);
3062
3063          Get_First_Interp (P, I, It);
3064          while Present (It.Nam) loop
3065             Typ := It.Typ;
3066
3067             if Is_Access_Type (Typ) then
3068                Typ := Designated_Type (Typ);
3069                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3070             end if;
3071
3072             if Is_Array_Type (Typ)
3073               and then Number_Dimensions (Typ) = 1
3074               and then Has_Compatible_Type (D, Etype (First_Index (Typ)))
3075             then
3076                Add_One_Interp (N, Typ, Typ);
3077             end if;
3078
3079             Get_Next_Interp (I, It);
3080          end loop;
3081
3082          if Etype (N) = Any_Type then
3083             Error_Msg_N ("expect array type in prefix of slice",  N);
3084          end if;
3085       end Analyze_Overloaded_Slice;
3086
3087    --  Start of processing for Analyze_Slice
3088
3089    begin
3090       Analyze (P);
3091       Analyze (D);
3092
3093       if Is_Overloaded (P) then
3094          Analyze_Overloaded_Slice;
3095
3096       else
3097          Array_Type := Etype (P);
3098          Set_Etype (N, Any_Type);
3099
3100          if Is_Access_Type (Array_Type) then
3101             Array_Type := Designated_Type (Array_Type);
3102             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3103          end if;
3104
3105          if not Is_Array_Type (Array_Type) then
3106             Wrong_Type (P, Any_Array);
3107
3108          elsif Number_Dimensions (Array_Type) > 1 then
3109             Error_Msg_N
3110               ("type is not one-dimensional array in slice prefix", N);
3111
3112          elsif not
3113            Has_Compatible_Type (D, Etype (First_Index (Array_Type)))
3114          then
3115             Wrong_Type (D, Etype (First_Index (Array_Type)));
3116
3117          else
3118             Set_Etype (N, Array_Type);
3119          end if;
3120       end if;
3121    end Analyze_Slice;
3122
3123    -----------------------------
3124    -- Analyze_Type_Conversion --
3125    -----------------------------
3126
3127    procedure Analyze_Type_Conversion (N : Node_Id) is
3128       Expr : constant Node_Id := Expression (N);
3129       T    : Entity_Id;
3130
3131    begin
3132       --  If Conversion_OK is set, then the Etype is already set, and the
3133       --  only processing required is to analyze the expression. This is
3134       --  used to construct certain "illegal" conversions which are not
3135       --  allowed by Ada semantics, but can be handled OK by Gigi, see
3136       --  Sinfo for further details.
3137
3138       if Conversion_OK (N) then
3139          Analyze (Expr);
3140          return;
3141       end if;
3142
3143       --  Otherwise full type analysis is required, as well as some semantic
3144       --  checks to make sure the argument of the conversion is appropriate.
3145
3146       Find_Type (Subtype_Mark (N));
3147       T := Entity (Subtype_Mark (N));
3148       Set_Etype (N, T);
3149       Check_Fully_Declared (T, N);
3150       Analyze_Expression (Expr);
3151       Validate_Remote_Type_Type_Conversion (N);
3152
3153       --  Only remaining step is validity checks on the argument. These
3154       --  are skipped if the conversion does not come from the source.
3155
3156       if not Comes_From_Source (N) then
3157          return;
3158
3159       elsif Nkind (Expr) = N_Null then
3160          Error_Msg_N ("argument of conversion cannot be null", N);
3161          Error_Msg_N ("\use qualified expression instead", N);
3162          Set_Etype (N, Any_Type);
3163
3164       elsif Nkind (Expr) = N_Aggregate then
3165          Error_Msg_N ("argument of conversion cannot be aggregate", N);
3166          Error_Msg_N ("\use qualified expression instead", N);
3167
3168       elsif Nkind (Expr) = N_Allocator then
3169          Error_Msg_N ("argument of conversion cannot be an allocator", N);
3170          Error_Msg_N ("\use qualified expression instead", N);
3171
3172       elsif Nkind (Expr) = N_String_Literal then
3173          Error_Msg_N ("argument of conversion cannot be string literal", N);
3174          Error_Msg_N ("\use qualified expression instead", N);
3175
3176       elsif Nkind (Expr) = N_Character_Literal then
3177          if Ada_Version = Ada_83 then
3178             Resolve (Expr, T);
3179          else
3180             Error_Msg_N ("argument of conversion cannot be character literal",
3181               N);
3182             Error_Msg_N ("\use qualified expression instead", N);
3183          end if;
3184
3185       elsif Nkind (Expr) = N_Attribute_Reference
3186         and then
3187           (Attribute_Name (Expr) = Name_Access            or else
3188            Attribute_Name (Expr) = Name_Unchecked_Access  or else
3189            Attribute_Name (Expr) = Name_Unrestricted_Access)
3190       then
3191          Error_Msg_N ("argument of conversion cannot be access", N);
3192          Error_Msg_N ("\use qualified expression instead", N);
3193       end if;
3194    end Analyze_Type_Conversion;
3195
3196    ----------------------
3197    -- Analyze_Unary_Op --
3198    ----------------------
3199
3200    procedure Analyze_Unary_Op (N : Node_Id) is
3201       R     : constant Node_Id := Right_Opnd (N);
3202       Op_Id : Entity_Id := Entity (N);
3203
3204    begin
3205       Set_Etype (N, Any_Type);
3206       Candidate_Type := Empty;
3207
3208       Analyze_Expression (R);
3209
3210       if Present (Op_Id) then
3211          if Ekind (Op_Id) = E_Operator then
3212             Find_Unary_Types (R, Op_Id,  N);
3213          else
3214             Add_One_Interp (N, Op_Id, Etype (Op_Id));
3215          end if;
3216
3217       else
3218          Op_Id := Get_Name_Entity_Id (Chars (N));
3219          while Present (Op_Id) loop
3220             if Ekind (Op_Id) = E_Operator then
3221                if No (Next_Entity (First_Entity (Op_Id))) then
3222                   Find_Unary_Types (R, Op_Id,  N);
3223                end if;
3224
3225             elsif Is_Overloadable (Op_Id) then
3226                Analyze_User_Defined_Unary_Op (N, Op_Id);
3227             end if;
3228
3229             Op_Id := Homonym (Op_Id);
3230          end loop;
3231       end if;
3232
3233       Operator_Check (N);
3234    end Analyze_Unary_Op;
3235
3236    ----------------------------------
3237    -- Analyze_Unchecked_Expression --
3238    ----------------------------------
3239
3240    procedure Analyze_Unchecked_Expression (N : Node_Id) is
3241    begin
3242       Analyze (Expression (N), Suppress => All_Checks);
3243       Set_Etype (N, Etype (Expression (N)));
3244       Save_Interps (Expression (N), N);
3245    end Analyze_Unchecked_Expression;
3246
3247    ---------------------------------------
3248    -- Analyze_Unchecked_Type_Conversion --
3249    ---------------------------------------
3250
3251    procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is
3252    begin
3253       Find_Type (Subtype_Mark (N));
3254       Analyze_Expression (Expression (N));
3255       Set_Etype (N, Entity (Subtype_Mark (N)));
3256    end Analyze_Unchecked_Type_Conversion;
3257
3258    ------------------------------------
3259    -- Analyze_User_Defined_Binary_Op --
3260    ------------------------------------
3261
3262    procedure Analyze_User_Defined_Binary_Op
3263      (N     : Node_Id;
3264       Op_Id : Entity_Id)
3265    is
3266    begin
3267       --  Only do analysis if the operator Comes_From_Source, since otherwise
3268       --  the operator was generated by the expander, and all such operators
3269       --  always refer to the operators in package Standard.
3270
3271       if Comes_From_Source (N) then
3272          declare
3273             F1 : constant Entity_Id := First_Formal (Op_Id);
3274             F2 : constant Entity_Id := Next_Formal (F1);
3275
3276          begin
3277             --  Verify that Op_Id is a visible binary function. Note that since
3278             --  we know Op_Id is overloaded, potentially use visible means use
3279             --  visible for sure (RM 9.4(11)).
3280
3281             if Ekind (Op_Id) = E_Function
3282               and then Present (F2)
3283               and then (Is_Immediately_Visible (Op_Id)
3284                          or else Is_Potentially_Use_Visible (Op_Id))
3285               and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
3286               and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
3287             then
3288                Add_One_Interp (N, Op_Id, Etype (Op_Id));
3289
3290                if Debug_Flag_E then
3291                   Write_Str ("user defined operator ");
3292                   Write_Name (Chars (Op_Id));
3293                   Write_Str (" on node ");
3294                   Write_Int (Int (N));
3295                   Write_Eol;
3296                end if;
3297             end if;
3298          end;
3299       end if;
3300    end Analyze_User_Defined_Binary_Op;
3301
3302    -----------------------------------
3303    -- Analyze_User_Defined_Unary_Op --
3304    -----------------------------------
3305
3306    procedure Analyze_User_Defined_Unary_Op
3307      (N     : Node_Id;
3308       Op_Id : Entity_Id)
3309    is
3310    begin
3311       --  Only do analysis if the operator Comes_From_Source, since otherwise
3312       --  the operator was generated by the expander, and all such operators
3313       --  always refer to the operators in package Standard.
3314
3315       if Comes_From_Source (N) then
3316          declare
3317             F : constant Entity_Id := First_Formal (Op_Id);
3318
3319          begin
3320             --  Verify that Op_Id is a visible unary function. Note that since
3321             --  we know Op_Id is overloaded, potentially use visible means use
3322             --  visible for sure (RM 9.4(11)).
3323
3324             if Ekind (Op_Id) = E_Function
3325               and then No (Next_Formal (F))
3326               and then (Is_Immediately_Visible (Op_Id)
3327                          or else Is_Potentially_Use_Visible (Op_Id))
3328               and then Has_Compatible_Type (Right_Opnd (N), Etype (F))
3329             then
3330                Add_One_Interp (N, Op_Id, Etype (Op_Id));
3331             end if;
3332          end;
3333       end if;
3334    end Analyze_User_Defined_Unary_Op;
3335
3336    ---------------------------
3337    -- Check_Arithmetic_Pair --
3338    ---------------------------
3339
3340    procedure Check_Arithmetic_Pair
3341      (T1, T2 : Entity_Id;
3342       Op_Id  : Entity_Id;
3343       N      : Node_Id)
3344    is
3345       Op_Name : constant Name_Id   := Chars (Op_Id);
3346
3347       function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean;
3348       --  Check whether the fixed-point type Typ has a user-defined operator
3349       --  (multiplication or division) that should hide the corresponding
3350       --  predefined operator. Used to implement Ada 2005 AI-264, to make
3351       --  such operators more visible and therefore useful.
3352
3353       function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
3354       --  Get specific type (i.e. non-universal type if there is one)
3355
3356       ------------------
3357       -- Has_Fixed_Op --
3358       ------------------
3359
3360       function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean is
3361          Ent : Entity_Id;
3362          F1  : Entity_Id;
3363          F2  : Entity_Id;
3364
3365       begin
3366          --  The operation is treated as primitive if it is declared in the
3367          --  same scope as the type, and therefore on the same entity chain.
3368
3369          Ent := Next_Entity (Typ);
3370          while Present (Ent) loop
3371             if Chars (Ent) = Chars (Op) then
3372                F1 := First_Formal (Ent);
3373                F2 := Next_Formal (F1);
3374
3375                --  The operation counts as primitive if either operand or
3376                --  result are of the given type, and both operands are fixed
3377                --  point types.
3378
3379                if (Etype (F1) = Typ
3380                     and then Is_Fixed_Point_Type (Etype (F2)))
3381
3382                  or else
3383                    (Etype (F2) = Typ
3384                      and then Is_Fixed_Point_Type (Etype (F1)))
3385
3386                  or else
3387                    (Etype (Ent) = Typ
3388                      and then Is_Fixed_Point_Type (Etype (F1))
3389                      and then Is_Fixed_Point_Type (Etype (F2)))
3390                then
3391                   return True;
3392                end if;
3393             end if;
3394
3395             Next_Entity (Ent);
3396          end loop;
3397
3398          return False;
3399       end Has_Fixed_Op;
3400
3401       -------------------
3402       -- Specific_Type --
3403       -------------------
3404
3405       function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
3406       begin
3407          if T1 = Universal_Integer or else T1 = Universal_Real then
3408             return Base_Type (T2);
3409          else
3410             return Base_Type (T1);
3411          end if;
3412       end Specific_Type;
3413
3414    --  Start of processing for Check_Arithmetic_Pair
3415
3416    begin
3417       if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
3418
3419          if Is_Numeric_Type (T1)
3420            and then Is_Numeric_Type (T2)
3421            and then (Covers (T1, T2) or else Covers (T2, T1))
3422          then
3423             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
3424          end if;
3425
3426       elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then
3427
3428          if Is_Fixed_Point_Type (T1)
3429            and then (Is_Fixed_Point_Type (T2)
3430                        or else T2 = Universal_Real)
3431          then
3432             --  If Treat_Fixed_As_Integer is set then the Etype is already set
3433             --  and no further processing is required (this is the case of an
3434             --  operator constructed by Exp_Fixd for a fixed point operation)
3435             --  Otherwise add one interpretation with universal fixed result
3436             --  If the operator is given in  functional notation, it comes
3437             --  from source and Fixed_As_Integer cannot apply.
3438
3439             if (Nkind (N) not in N_Op
3440                  or else not Treat_Fixed_As_Integer (N))
3441               and then
3442                 (not (Ada_Version >= Ada_05 and then Has_Fixed_Op (T1, Op_Id))
3443                   or else Nkind (Parent (N)) = N_Type_Conversion)
3444             then
3445                Add_One_Interp (N, Op_Id, Universal_Fixed);
3446             end if;
3447
3448          elsif Is_Fixed_Point_Type (T2)
3449            and then (Nkind (N) not in N_Op
3450                       or else not Treat_Fixed_As_Integer (N))
3451            and then T1 = Universal_Real
3452            and then
3453              (not (Ada_Version >= Ada_05 and then Has_Fixed_Op (T1, Op_Id))
3454                or else Nkind (Parent (N)) = N_Type_Conversion)
3455          then
3456             Add_One_Interp (N, Op_Id, Universal_Fixed);
3457
3458          elsif Is_Numeric_Type (T1)
3459            and then Is_Numeric_Type (T2)
3460            and then (Covers (T1, T2) or else Covers (T2, T1))
3461          then
3462             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
3463
3464          elsif Is_Fixed_Point_Type (T1)
3465            and then (Base_Type (T2) = Base_Type (Standard_Integer)
3466                        or else T2 = Universal_Integer)
3467          then
3468             Add_One_Interp (N, Op_Id, T1);
3469
3470          elsif T2 = Universal_Real
3471            and then Base_Type (T1) = Base_Type (Standard_Integer)
3472            and then Op_Name = Name_Op_Multiply
3473          then
3474             Add_One_Interp (N, Op_Id, Any_Fixed);
3475
3476          elsif T1 = Universal_Real
3477            and then Base_Type (T2) = Base_Type (Standard_Integer)
3478          then
3479             Add_One_Interp (N, Op_Id, Any_Fixed);
3480
3481          elsif Is_Fixed_Point_Type (T2)
3482            and then (Base_Type (T1) = Base_Type (Standard_Integer)
3483                        or else T1 = Universal_Integer)
3484            and then Op_Name = Name_Op_Multiply
3485          then
3486             Add_One_Interp (N, Op_Id, T2);
3487
3488          elsif T1 = Universal_Real and then T2 = Universal_Integer then
3489             Add_One_Interp (N, Op_Id, T1);
3490
3491          elsif T2 = Universal_Real
3492            and then T1 = Universal_Integer
3493            and then Op_Name = Name_Op_Multiply
3494          then
3495             Add_One_Interp (N, Op_Id, T2);
3496          end if;
3497
3498       elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
3499
3500          --  Note: The fixed-point operands case with Treat_Fixed_As_Integer
3501          --  set does not require any special processing, since the Etype is
3502          --  already set (case of operation constructed by Exp_Fixed).
3503
3504          if Is_Integer_Type (T1)
3505            and then (Covers (T1, T2) or else Covers (T2, T1))
3506          then
3507             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
3508          end if;
3509
3510       elsif Op_Name = Name_Op_Expon then
3511          if Is_Numeric_Type (T1)
3512            and then not Is_Fixed_Point_Type (T1)
3513            and then (Base_Type (T2) = Base_Type (Standard_Integer)
3514                       or else T2 = Universal_Integer)
3515          then
3516             Add_One_Interp (N, Op_Id, Base_Type (T1));
3517          end if;
3518
3519       else pragma Assert (Nkind (N) in N_Op_Shift);
3520
3521          --  If not one of the predefined operators, the node may be one
3522          --  of the intrinsic functions. Its kind is always specific, and
3523          --  we can use it directly, rather than the name of the operation.
3524
3525          if Is_Integer_Type (T1)
3526            and then (Base_Type (T2) = Base_Type (Standard_Integer)
3527                       or else T2 = Universal_Integer)
3528          then
3529             Add_One_Interp (N, Op_Id, Base_Type (T1));
3530          end if;
3531       end if;
3532    end Check_Arithmetic_Pair;
3533
3534    -------------------------------
3535    -- Check_Misspelled_Selector --
3536    -------------------------------
3537
3538    procedure Check_Misspelled_Selector
3539      (Prefix : Entity_Id;
3540       Sel    : Node_Id)
3541    is
3542       Max_Suggestions   : constant := 2;
3543       Nr_Of_Suggestions : Natural := 0;
3544
3545       Suggestion_1 : Entity_Id := Empty;
3546       Suggestion_2 : Entity_Id := Empty;
3547
3548       Comp : Entity_Id;
3549
3550    begin
3551       --  All the components of the prefix of selector Sel are matched
3552       --  against  Sel and a count is maintained of possible misspellings.
3553       --  When at the end of the analysis there are one or two (not more!)
3554       --  possible misspellings, these misspellings will be suggested as
3555       --  possible correction.
3556
3557       if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then
3558
3559          --  Concurrent types should be handled as well ???
3560
3561          return;
3562       end if;
3563
3564       Get_Name_String (Chars (Sel));
3565
3566       declare
3567          S  : constant String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
3568
3569       begin
3570          Comp  := First_Entity (Prefix);
3571          while Nr_Of_Suggestions <= Max_Suggestions
3572             and then Present (Comp)
3573          loop
3574             if Is_Visible_Component (Comp) then
3575                Get_Name_String (Chars (Comp));
3576
3577                if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
3578                   Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
3579
3580                   case Nr_Of_Suggestions is
3581                      when 1      => Suggestion_1 := Comp;
3582                      when 2      => Suggestion_2 := Comp;
3583                      when others => exit;
3584                   end case;
3585                end if;
3586             end if;
3587
3588             Comp := Next_Entity (Comp);
3589          end loop;
3590
3591          --  Report at most two suggestions
3592
3593          if Nr_Of_Suggestions = 1 then
3594             Error_Msg_NE ("\possible misspelling of&", Sel, Suggestion_1);
3595
3596          elsif Nr_Of_Suggestions = 2 then
3597             Error_Msg_Node_2 := Suggestion_2;
3598             Error_Msg_NE ("\possible misspelling of& or&",
3599               Sel, Suggestion_1);
3600          end if;
3601       end;
3602    end Check_Misspelled_Selector;
3603
3604    ----------------------
3605    -- Defined_In_Scope --
3606    ----------------------
3607
3608    function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean
3609    is
3610       S1 : constant Entity_Id := Scope (Base_Type (T));
3611    begin
3612       return S1 = S
3613         or else (S1 = System_Aux_Id and then S = Scope (S1));
3614    end Defined_In_Scope;
3615
3616    -------------------
3617    -- Diagnose_Call --
3618    -------------------
3619
3620    procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is
3621       Actual           : Node_Id;
3622       X                : Interp_Index;
3623       It               : Interp;
3624       Success          : Boolean;
3625       Err_Mode         : Boolean;
3626       New_Nam          : Node_Id;
3627       Void_Interp_Seen : Boolean := False;
3628
3629    begin
3630       if Ada_Version >= Ada_05 then
3631          Actual := First_Actual (N);
3632          while Present (Actual) loop
3633
3634             --  Ada 2005 (AI-50217): Post an error in case of premature
3635             --  usage of an entity from the limited view.
3636
3637             if not Analyzed (Etype (Actual))
3638              and then From_With_Type (Etype (Actual))
3639             then
3640                Error_Msg_Qual_Level := 1;
3641                Error_Msg_NE
3642                 ("missing with_clause for scope of imported type&",
3643                   Actual, Etype (Actual));
3644                Error_Msg_Qual_Level := 0;
3645             end if;
3646
3647             Next_Actual (Actual);
3648          end loop;
3649       end if;
3650
3651       --   Analyze each candidate call again, with full error reporting
3652       --   for each.
3653
3654       Error_Msg_N
3655         ("no candidate interpretations match the actuals:!", Nam);
3656       Err_Mode := All_Errors_Mode;
3657       All_Errors_Mode := True;
3658
3659       --  If this is a call to an operation of a concurrent type,
3660       --  the failed interpretations have been removed from the
3661       --  name. Recover them to provide full diagnostics.
3662
3663       if Nkind (Parent (Nam)) = N_Selected_Component then
3664          Set_Entity (Nam, Empty);
3665          New_Nam := New_Copy_Tree (Parent (Nam));
3666          Set_Is_Overloaded (New_Nam, False);
3667          Set_Is_Overloaded (Selector_Name (New_Nam), False);
3668          Set_Parent (New_Nam, Parent (Parent (Nam)));
3669          Analyze_Selected_Component (New_Nam);
3670          Get_First_Interp (Selector_Name (New_Nam), X, It);
3671       else
3672          Get_First_Interp (Nam, X, It);
3673       end if;
3674
3675       while Present (It.Nam) loop
3676          if Etype (It.Nam) = Standard_Void_Type then
3677             Void_Interp_Seen := True;
3678          end if;
3679
3680          Analyze_One_Call (N, It.Nam, True, Success);
3681          Get_Next_Interp (X, It);
3682       end loop;
3683
3684       if Nkind (N) = N_Function_Call then
3685          Get_First_Interp (Nam, X, It);
3686          while Present (It.Nam) loop
3687             if Ekind (It.Nam) = E_Function
3688               or else Ekind (It.Nam) = E_Operator
3689             then
3690                return;
3691             else
3692                Get_Next_Interp (X, It);
3693             end if;
3694          end loop;
3695
3696          --  If all interpretations are procedures, this deserves a
3697          --  more precise message. Ditto if this appears as the prefix
3698          --  of a selected component, which may be a lexical error.
3699
3700          Error_Msg_N
3701            ("\context requires function call, found procedure name", Nam);
3702
3703          if Nkind (Parent (N)) = N_Selected_Component
3704            and then N = Prefix (Parent (N))
3705          then
3706             Error_Msg_N (
3707               "\period should probably be semicolon", Parent (N));
3708          end if;
3709
3710       elsif Nkind (N) = N_Procedure_Call_Statement
3711         and then not Void_Interp_Seen
3712       then
3713          Error_Msg_N (
3714          "\function name found in procedure call", Nam);
3715       end if;
3716
3717       All_Errors_Mode := Err_Mode;
3718    end Diagnose_Call;
3719
3720    ---------------------------
3721    -- Find_Arithmetic_Types --
3722    ---------------------------
3723
3724    procedure Find_Arithmetic_Types
3725      (L, R  : Node_Id;
3726       Op_Id : Entity_Id;
3727       N     : Node_Id)
3728    is
3729       Index1 : Interp_Index;
3730       Index2 : Interp_Index;
3731       It1    : Interp;
3732       It2    : Interp;
3733
3734       procedure Check_Right_Argument (T : Entity_Id);
3735       --  Check right operand of operator
3736
3737       --------------------------
3738       -- Check_Right_Argument --
3739       --------------------------
3740
3741       procedure Check_Right_Argument (T : Entity_Id) is
3742       begin
3743          if not Is_Overloaded (R) then
3744             Check_Arithmetic_Pair (T, Etype (R), Op_Id,  N);
3745          else
3746             Get_First_Interp (R, Index2, It2);
3747             while Present (It2.Typ) loop
3748                Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N);
3749                Get_Next_Interp (Index2, It2);
3750             end loop;
3751          end if;
3752       end Check_Right_Argument;
3753
3754    --  Start processing for Find_Arithmetic_Types
3755
3756    begin
3757       if not Is_Overloaded (L) then
3758          Check_Right_Argument (Etype (L));
3759
3760       else
3761          Get_First_Interp (L, Index1, It1);
3762
3763          while Present (It1.Typ) loop
3764             Check_Right_Argument (It1.Typ);
3765             Get_Next_Interp (Index1, It1);
3766          end loop;
3767       end if;
3768
3769    end Find_Arithmetic_Types;
3770
3771    ------------------------
3772    -- Find_Boolean_Types --
3773    ------------------------
3774
3775    procedure Find_Boolean_Types
3776      (L, R  : Node_Id;
3777       Op_Id : Entity_Id;
3778       N     : Node_Id)
3779    is
3780       Index : Interp_Index;
3781       It    : Interp;
3782
3783       procedure Check_Numeric_Argument (T : Entity_Id);
3784       --  Special case for logical operations one of whose operands is an
3785       --  integer literal. If both are literal the result is any modular type.
3786
3787       ----------------------------
3788       -- Check_Numeric_Argument --
3789       ----------------------------
3790
3791       procedure Check_Numeric_Argument (T : Entity_Id) is
3792       begin
3793          if T = Universal_Integer then
3794             Add_One_Interp (N, Op_Id, Any_Modular);
3795
3796          elsif Is_Modular_Integer_Type (T) then
3797             Add_One_Interp (N, Op_Id, T);
3798          end if;
3799       end Check_Numeric_Argument;
3800
3801    --  Start of processing for Find_Boolean_Types
3802
3803    begin
3804       if not Is_Overloaded (L) then
3805          if Etype (L) = Universal_Integer
3806            or else Etype (L) = Any_Modular
3807          then
3808             if not Is_Overloaded (R) then
3809                Check_Numeric_Argument (Etype (R));
3810
3811             else
3812                Get_First_Interp (R, Index, It);
3813                while Present (It.Typ) loop
3814                   Check_Numeric_Argument (It.Typ);
3815                   Get_Next_Interp (Index, It);
3816                end loop;
3817             end if;
3818
3819          elsif Valid_Boolean_Arg (Etype (L))
3820            and then Has_Compatible_Type (R, Etype (L))
3821          then
3822             Add_One_Interp (N, Op_Id, Etype (L));
3823          end if;
3824
3825       else
3826          Get_First_Interp (L, Index, It);
3827          while Present (It.Typ) loop
3828             if Valid_Boolean_Arg (It.Typ)
3829               and then Has_Compatible_Type (R, It.Typ)
3830             then
3831                Add_One_Interp (N, Op_Id, It.Typ);
3832             end if;
3833
3834             Get_Next_Interp (Index, It);
3835          end loop;
3836       end if;
3837    end Find_Boolean_Types;
3838
3839    ---------------------------
3840    -- Find_Comparison_Types --
3841    ---------------------------
3842
3843    procedure Find_Comparison_Types
3844      (L, R  : Node_Id;
3845       Op_Id : Entity_Id;
3846       N     : Node_Id)
3847    is
3848       Index : Interp_Index;
3849       It    : Interp;
3850       Found : Boolean := False;
3851       I_F   : Interp_Index;
3852       T_F   : Entity_Id;
3853       Scop  : Entity_Id := Empty;
3854
3855       procedure Try_One_Interp (T1 : Entity_Id);
3856       --  Routine to try one proposed interpretation. Note that the context
3857       --  of the operator plays no role in resolving the arguments, so that
3858       --  if there is more than one interpretation of the operands that is
3859       --  compatible with comparison, the operation is ambiguous.
3860
3861       --------------------
3862       -- Try_One_Interp --
3863       --------------------
3864
3865       procedure Try_One_Interp (T1 : Entity_Id) is
3866       begin
3867
3868          --  If the operator is an expanded name, then the type of the operand
3869          --  must be defined in the corresponding scope. If the type is
3870          --  universal, the context will impose the correct type.
3871
3872          if Present (Scop)
3873             and then not Defined_In_Scope (T1, Scop)
3874             and then T1 /= Universal_Integer
3875             and then T1 /= Universal_Real
3876             and then T1 /= Any_String
3877             and then T1 /= Any_Composite
3878          then
3879             return;
3880          end if;
3881
3882          if Valid_Comparison_Arg (T1)
3883            and then Has_Compatible_Type (R, T1)
3884          then
3885             if Found
3886               and then Base_Type (T1) /= Base_Type (T_F)
3887             then
3888                It := Disambiguate (L, I_F, Index, Any_Type);
3889
3890                if It = No_Interp then
3891                   Ambiguous_Operands (N);
3892                   Set_Etype (L, Any_Type);
3893                   return;
3894
3895                else
3896                   T_F := It.Typ;
3897                end if;
3898
3899             else
3900                Found := True;
3901                T_F   := T1;
3902                I_F   := Index;
3903             end if;
3904
3905             Set_Etype (L, T_F);
3906             Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
3907
3908          end if;
3909       end Try_One_Interp;
3910
3911    --  Start processing for Find_Comparison_Types
3912
3913    begin
3914       --  If left operand is aggregate, the right operand has to
3915       --  provide a usable type for it.
3916
3917       if Nkind (L) = N_Aggregate
3918         and then Nkind (R) /= N_Aggregate
3919       then
3920          Find_Comparison_Types (R, L, Op_Id, N);
3921          return;
3922       end if;
3923
3924       if Nkind (N) = N_Function_Call
3925          and then Nkind (Name (N)) = N_Expanded_Name
3926       then
3927          Scop := Entity (Prefix (Name (N)));
3928
3929          --  The prefix may be a package renaming, and the subsequent test
3930          --  requires the original package.
3931
3932          if Ekind (Scop) = E_Package
3933            and then Present (Renamed_Entity (Scop))
3934          then
3935             Scop := Renamed_Entity (Scop);
3936             Set_Entity (Prefix (Name (N)), Scop);
3937          end if;
3938       end if;
3939
3940       if not Is_Overloaded (L) then
3941          Try_One_Interp (Etype (L));
3942
3943       else
3944          Get_First_Interp (L, Index, It);
3945          while Present (It.Typ) loop
3946             Try_One_Interp (It.Typ);
3947             Get_Next_Interp (Index, It);
3948          end loop;
3949       end if;
3950    end Find_Comparison_Types;
3951
3952    ----------------------------------------
3953    -- Find_Non_Universal_Interpretations --
3954    ----------------------------------------
3955
3956    procedure Find_Non_Universal_Interpretations
3957      (N     : Node_Id;
3958       R     : Node_Id;
3959       Op_Id : Entity_Id;
3960       T1    : Entity_Id)
3961    is
3962       Index : Interp_Index;
3963       It    : Interp;
3964
3965    begin
3966       if T1 = Universal_Integer
3967         or else T1 = Universal_Real
3968       then
3969          if not Is_Overloaded (R) then
3970             Add_One_Interp
3971               (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
3972          else
3973             Get_First_Interp (R, Index, It);
3974             while Present (It.Typ) loop
3975                if Covers (It.Typ, T1) then
3976                   Add_One_Interp
3977                     (N, Op_Id, Standard_Boolean, Base_Type (It.Typ));
3978                end if;
3979
3980                Get_Next_Interp (Index, It);
3981             end loop;
3982          end if;
3983       else
3984          Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
3985       end if;
3986    end Find_Non_Universal_Interpretations;
3987
3988    ------------------------------
3989    -- Find_Concatenation_Types --
3990    ------------------------------
3991
3992    procedure Find_Concatenation_Types
3993      (L, R  : Node_Id;
3994       Op_Id : Entity_Id;
3995       N     : Node_Id)
3996    is
3997       Op_Type : constant Entity_Id := Etype (Op_Id);
3998
3999    begin
4000       if Is_Array_Type (Op_Type)
4001         and then not Is_Limited_Type (Op_Type)
4002
4003         and then (Has_Compatible_Type (L, Op_Type)
4004                     or else
4005                   Has_Compatible_Type (L, Component_Type (Op_Type)))
4006
4007         and then (Has_Compatible_Type (R, Op_Type)
4008                     or else
4009                   Has_Compatible_Type (R, Component_Type (Op_Type)))
4010       then
4011          Add_One_Interp (N, Op_Id, Op_Type);
4012       end if;
4013    end Find_Concatenation_Types;
4014
4015    -------------------------
4016    -- Find_Equality_Types --
4017    -------------------------
4018
4019    procedure Find_Equality_Types
4020      (L, R  : Node_Id;
4021       Op_Id : Entity_Id;
4022       N     : Node_Id)
4023    is
4024       Index : Interp_Index;
4025       It    : Interp;
4026       Found : Boolean := False;
4027       I_F   : Interp_Index;
4028       T_F   : Entity_Id;
4029       Scop  : Entity_Id := Empty;
4030
4031       procedure Try_One_Interp (T1 : Entity_Id);
4032       --  The context of the operator plays no role in resolving the
4033       --  arguments,  so that if there is more than one interpretation
4034       --  of the operands that is compatible with equality, the construct
4035       --  is ambiguous and an error can be emitted now, after trying to
4036       --  disambiguate, i.e. applying preference rules.
4037
4038       --------------------
4039       -- Try_One_Interp --
4040       --------------------
4041
4042       procedure Try_One_Interp (T1 : Entity_Id) is
4043       begin
4044          --  If the operator is an expanded name, then the type of the operand
4045          --  must be defined in the corresponding scope. If the type is
4046          --  universal, the context will impose the correct type. An anonymous
4047          --  type for a 'Access reference is also universal in this sense, as
4048          --  the actual type is obtained from context.
4049
4050          if Present (Scop)
4051             and then not Defined_In_Scope (T1, Scop)
4052             and then T1 /= Universal_Integer
4053             and then T1 /= Universal_Real
4054             and then T1 /= Any_Access
4055             and then T1 /= Any_String
4056             and then T1 /= Any_Composite
4057             and then (Ekind (T1) /= E_Access_Subprogram_Type
4058                         or else Comes_From_Source (T1))
4059          then
4060             return;
4061          end if;
4062
4063          --  Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
4064          --  Do not allow anonymous access types in equality operators.
4065
4066          if Ada_Version < Ada_05
4067            and then Ekind (T1) = E_Anonymous_Access_Type
4068          then
4069             return;
4070          end if;
4071
4072          if T1 /= Standard_Void_Type
4073            and then not Is_Limited_Type (T1)
4074            and then not Is_Limited_Composite (T1)
4075            and then Has_Compatible_Type (R, T1)
4076          then
4077             if Found
4078               and then Base_Type (T1) /= Base_Type (T_F)
4079             then
4080                It := Disambiguate (L, I_F, Index, Any_Type);
4081
4082                if It = No_Interp then
4083                   Ambiguous_Operands (N);
4084                   Set_Etype (L, Any_Type);
4085                   return;
4086
4087                else
4088                   T_F := It.Typ;
4089                end if;
4090
4091             else
4092                Found := True;
4093                T_F   := T1;
4094                I_F   := Index;
4095             end if;
4096
4097             if not Analyzed (L) then
4098                Set_Etype (L, T_F);
4099             end if;
4100
4101             Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
4102
4103             --  Case of operator was not visible, Etype still set to Any_Type
4104
4105             if Etype (N) = Any_Type then
4106                Found := False;
4107             end if;
4108          end if;
4109       end Try_One_Interp;
4110
4111    --  Start of processing for Find_Equality_Types
4112
4113    begin
4114       --  If left operand is aggregate, the right operand has to
4115       --  provide a usable type for it.
4116
4117       if Nkind (L) = N_Aggregate
4118         and then Nkind (R) /= N_Aggregate
4119       then
4120          Find_Equality_Types (R, L, Op_Id, N);
4121          return;
4122       end if;
4123
4124       if Nkind (N) = N_Function_Call
4125          and then Nkind (Name (N)) = N_Expanded_Name
4126       then
4127          Scop := Entity (Prefix (Name (N)));
4128
4129          --  The prefix may be a package renaming, and the subsequent test
4130          --  requires the original package.
4131
4132          if Ekind (Scop) = E_Package
4133            and then Present (Renamed_Entity (Scop))
4134          then
4135             Scop := Renamed_Entity (Scop);
4136             Set_Entity (Prefix (Name (N)), Scop);
4137          end if;
4138       end if;
4139
4140       if not Is_Overloaded (L) then
4141          Try_One_Interp (Etype (L));
4142
4143       else
4144          Get_First_Interp (L, Index, It);
4145          while Present (It.Typ) loop
4146             Try_One_Interp (It.Typ);
4147             Get_Next_Interp (Index, It);
4148          end loop;
4149       end if;
4150    end Find_Equality_Types;
4151
4152    -------------------------
4153    -- Find_Negation_Types --
4154    -------------------------
4155
4156    procedure Find_Negation_Types
4157      (R     : Node_Id;
4158       Op_Id : Entity_Id;
4159       N     : Node_Id)
4160    is
4161       Index : Interp_Index;
4162       It    : Interp;
4163
4164    begin
4165       if not Is_Overloaded (R) then
4166          if Etype (R) = Universal_Integer then
4167             Add_One_Interp (N, Op_Id, Any_Modular);
4168          elsif Valid_Boolean_Arg (Etype (R)) then
4169             Add_One_Interp (N, Op_Id, Etype (R));
4170          end if;
4171
4172       else
4173          Get_First_Interp (R, Index, It);
4174          while Present (It.Typ) loop
4175             if Valid_Boolean_Arg (It.Typ) then
4176                Add_One_Interp (N, Op_Id, It.Typ);
4177             end if;
4178
4179             Get_Next_Interp (Index, It);
4180          end loop;
4181       end if;
4182    end Find_Negation_Types;
4183
4184    ----------------------
4185    -- Find_Unary_Types --
4186    ----------------------
4187
4188    procedure Find_Unary_Types
4189      (R     : Node_Id;
4190       Op_Id : Entity_Id;
4191       N     : Node_Id)
4192    is
4193       Index : Interp_Index;
4194       It    : Interp;
4195
4196    begin
4197       if not Is_Overloaded (R) then
4198          if Is_Numeric_Type (Etype (R)) then
4199             Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
4200          end if;
4201
4202       else
4203          Get_First_Interp (R, Index, It);
4204          while Present (It.Typ) loop
4205             if Is_Numeric_Type (It.Typ) then
4206                Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
4207             end if;
4208
4209             Get_Next_Interp (Index, It);
4210          end loop;
4211       end if;
4212    end Find_Unary_Types;
4213
4214    ------------------
4215    -- Junk_Operand --
4216    ------------------
4217
4218    function Junk_Operand (N : Node_Id) return Boolean is
4219       Enode : Node_Id;
4220
4221    begin
4222       if Error_Posted (N) then
4223          return False;
4224       end if;
4225
4226       --  Get entity to be tested
4227
4228       if Is_Entity_Name (N)
4229         and then Present (Entity (N))
4230       then
4231          Enode := N;
4232
4233       --  An odd case, a procedure name gets converted to a very peculiar
4234       --  function call, and here is where we detect this happening.
4235
4236       elsif Nkind (N) = N_Function_Call
4237         and then Is_Entity_Name (Name (N))
4238         and then Present (Entity (Name (N)))
4239       then
4240          Enode := Name (N);
4241
4242       --  Another odd case, there are at least some cases of selected
4243       --  components where the selected component is not marked as having
4244       --  an entity, even though the selector does have an entity
4245
4246       elsif Nkind (N) = N_Selected_Component
4247         and then Present (Entity (Selector_Name (N)))
4248       then
4249          Enode := Selector_Name (N);
4250
4251       else
4252          return False;
4253       end if;
4254
4255       --  Now test the entity we got to see if it a bad case
4256
4257       case Ekind (Entity (Enode)) is
4258
4259          when E_Package =>
4260             Error_Msg_N
4261               ("package name cannot be used as operand", Enode);
4262
4263          when Generic_Unit_Kind =>
4264             Error_Msg_N
4265               ("generic unit name cannot be used as operand", Enode);
4266
4267          when Type_Kind =>
4268             Error_Msg_N
4269               ("subtype name cannot be used as operand", Enode);
4270
4271          when Entry_Kind =>
4272             Error_Msg_N
4273               ("entry name cannot be used as operand", Enode);
4274
4275          when E_Procedure =>
4276             Error_Msg_N
4277               ("procedure name cannot be used as operand", Enode);
4278
4279          when E_Exception =>
4280             Error_Msg_N
4281               ("exception name cannot be used as operand", Enode);
4282
4283          when E_Block | E_Label | E_Loop =>
4284             Error_Msg_N
4285               ("label name cannot be used as operand", Enode);
4286
4287          when others =>
4288             return False;
4289
4290       end case;
4291
4292       return True;
4293    end Junk_Operand;
4294
4295    --------------------
4296    -- Operator_Check --
4297    --------------------
4298
4299    procedure Operator_Check (N : Node_Id) is
4300    begin
4301       Remove_Abstract_Operations (N);
4302
4303       --  Test for case of no interpretation found for operator
4304
4305       if Etype (N) = Any_Type then
4306          declare
4307             L : Node_Id;
4308             R : Node_Id;
4309
4310          begin
4311             R := Right_Opnd (N);
4312
4313             if Nkind (N) in N_Binary_Op then
4314                L := Left_Opnd (N);
4315             else
4316                L := Empty;
4317             end if;
4318
4319             --  If either operand has no type, then don't complain further,
4320             --  since this simply means that we have a propragated error.
4321
4322             if R = Error
4323               or else Etype (R) = Any_Type
4324               or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type)
4325             then
4326                return;
4327
4328             --  We explicitly check for the case of concatenation of component
4329             --  with component to avoid reporting spurious matching array types
4330             --  that might happen to be lurking in distant packages (such as
4331             --  run-time packages). This also prevents inconsistencies in the
4332             --  messages for certain ACVC B tests, which can vary depending on
4333             --  types declared in run-time interfaces. Another improvement when
4334             --  aggregates are present is to look for a well-typed operand.
4335
4336             elsif Present (Candidate_Type)
4337               and then (Nkind (N) /= N_Op_Concat
4338                          or else Is_Array_Type (Etype (L))
4339                          or else Is_Array_Type (Etype (R)))
4340             then
4341
4342                if Nkind (N) = N_Op_Concat then
4343                   if Etype (L) /= Any_Composite
4344                     and then Is_Array_Type (Etype (L))
4345                   then
4346                      Candidate_Type := Etype (L);
4347
4348                   elsif Etype (R) /= Any_Composite
4349                     and then Is_Array_Type (Etype (R))
4350                   then
4351                      Candidate_Type := Etype (R);
4352                   end if;
4353                end if;
4354
4355                Error_Msg_NE
4356                  ("operator for} is not directly visible!",
4357                   N, First_Subtype (Candidate_Type));
4358                Error_Msg_N ("use clause would make operation legal!",  N);
4359                return;
4360
4361             --  If either operand is a junk operand (e.g. package name), then
4362             --  post appropriate error messages, but do not complain further.
4363
4364             --  Note that the use of OR in this test instead of OR ELSE
4365             --  is quite deliberate, we may as well check both operands
4366             --  in the binary operator case.
4367
4368             elsif Junk_Operand (R)
4369               or (Nkind (N) in N_Binary_Op and then Junk_Operand (L))
4370             then
4371                return;
4372
4373             --  If we have a logical operator, one of whose operands is
4374             --  Boolean, then we know that the other operand cannot resolve
4375             --  to Boolean (since we got no interpretations), but in that
4376             --  case we pretty much know that the other operand should be
4377             --  Boolean, so resolve it that way (generating an error)
4378
4379             elsif Nkind (N) = N_Op_And
4380                     or else
4381                   Nkind (N) = N_Op_Or
4382                     or else
4383                   Nkind (N) = N_Op_Xor
4384             then
4385                if Etype (L) = Standard_Boolean then
4386                   Resolve (R, Standard_Boolean);
4387                   return;
4388                elsif Etype (R) = Standard_Boolean then
4389                   Resolve (L, Standard_Boolean);
4390                   return;
4391                end if;
4392
4393             --  For an arithmetic operator or comparison operator, if one
4394             --  of the operands is numeric, then we know the other operand
4395             --  is not the same numeric type. If it is a non-numeric type,
4396             --  then probably it is intended to match the other operand.
4397
4398             elsif Nkind (N) = N_Op_Add      or else
4399                   Nkind (N) = N_Op_Divide   or else
4400                   Nkind (N) = N_Op_Ge       or else
4401                   Nkind (N) = N_Op_Gt       or else
4402                   Nkind (N) = N_Op_Le       or else
4403                   Nkind (N) = N_Op_Lt       or else
4404                   Nkind (N) = N_Op_Mod      or else
4405                   Nkind (N) = N_Op_Multiply or else
4406                   Nkind (N) = N_Op_Rem      or else
4407                   Nkind (N) = N_Op_Subtract
4408             then
4409                if Is_Numeric_Type (Etype (L))
4410                  and then not Is_Numeric_Type (Etype (R))
4411                then
4412                   Resolve (R, Etype (L));
4413                   return;
4414
4415                elsif Is_Numeric_Type (Etype (R))
4416                  and then not Is_Numeric_Type (Etype (L))
4417                then
4418                   Resolve (L, Etype (R));
4419                   return;
4420                end if;
4421
4422             --  Comparisons on A'Access are common enough to deserve a
4423             --  special message.
4424
4425             elsif (Nkind (N) = N_Op_Eq  or else
4426                    Nkind (N) = N_Op_Ne)
4427                and then Ekind (Etype (L)) = E_Access_Attribute_Type
4428                and then Ekind (Etype (R)) = E_Access_Attribute_Type
4429             then
4430                Error_Msg_N
4431                  ("two access attributes cannot be compared directly", N);
4432                Error_Msg_N
4433                  ("\they must be converted to an explicit type for comparison",
4434                    N);
4435                return;
4436
4437             --  Another one for C programmers
4438
4439             elsif Nkind (N) = N_Op_Concat
4440               and then Valid_Boolean_Arg (Etype (L))
4441               and then Valid_Boolean_Arg (Etype (R))
4442             then
4443                Error_Msg_N ("invalid operands for concatenation", N);
4444                Error_Msg_N ("\maybe AND was meant", N);
4445                return;
4446
4447             --  A special case for comparison of access parameter with null
4448
4449             elsif Nkind (N) = N_Op_Eq
4450               and then Is_Entity_Name (L)
4451               and then Nkind (Parent (Entity (L))) = N_Parameter_Specification
4452               and then Nkind (Parameter_Type (Parent (Entity (L)))) =
4453                                                   N_Access_Definition
4454               and then Nkind (R) = N_Null
4455             then
4456                Error_Msg_N ("access parameter is not allowed to be null", L);
4457                Error_Msg_N ("\(call would raise Constraint_Error)", L);
4458                return;
4459             end if;
4460
4461             --  If we fall through then just give general message. Note
4462             --  that in the following messages, if the operand is overloaded
4463             --  we choose an arbitrary type to complain about, but that is
4464             --  probably more useful than not giving a type at all.
4465
4466             if Nkind (N) in N_Unary_Op then
4467                Error_Msg_Node_2 := Etype (R);
4468                Error_Msg_N ("operator& not defined for}", N);
4469                return;
4470
4471             else
4472                if Nkind (N) in N_Binary_Op then
4473                   if not Is_Overloaded (L)
4474                     and then not Is_Overloaded (R)
4475                     and then Base_Type (Etype (L)) = Base_Type (Etype (R))
4476                   then
4477                      Error_Msg_Node_2 := First_Subtype (Etype (R));
4478                      Error_Msg_N ("there is no applicable operator& for}", N);
4479
4480                   else
4481                      Error_Msg_N ("invalid operand types for operator&", N);
4482
4483                      if Nkind (N) /= N_Op_Concat then
4484                         Error_Msg_NE ("\left operand has}!",  N, Etype (L));
4485                         Error_Msg_NE ("\right operand has}!", N, Etype (R));
4486                      end if;
4487                   end if;
4488                end if;
4489             end if;
4490          end;
4491       end if;
4492    end Operator_Check;
4493
4494    -----------------------------------------
4495    -- Process_Implicit_Dereference_Prefix --
4496    -----------------------------------------
4497
4498    procedure Process_Implicit_Dereference_Prefix
4499      (E : Entity_Id;
4500       P : Entity_Id)
4501    is
4502       Ref : Node_Id;
4503
4504    begin
4505       if Present (E)
4506         and then (Operating_Mode = Check_Semantics or else not Expander_Active)
4507       then
4508          --  We create a dummy reference to E to ensure that the reference
4509          --  is not considered as part of an assignment (an implicit
4510          --  dereference can never assign to its prefix). The Comes_From_Source
4511          --  attribute needs to be propagated for accurate warnings.
4512
4513          Ref := New_Reference_To (E, Sloc (P));
4514          Set_Comes_From_Source (Ref, Comes_From_Source (P));
4515          Generate_Reference (E, Ref);
4516       end if;
4517    end Process_Implicit_Dereference_Prefix;
4518
4519    --------------------------------
4520    -- Remove_Abstract_Operations --
4521    --------------------------------
4522
4523    procedure Remove_Abstract_Operations (N : Node_Id) is
4524       I            : Interp_Index;
4525       It           : Interp;
4526       Abstract_Op  : Entity_Id := Empty;
4527
4528       --  AI-310: If overloaded, remove abstract non-dispatching
4529       --  operations. We activate this if either extensions are
4530       --  enabled, or if the abstract operation in question comes
4531       --  from a predefined file. This latter test allows us to
4532       --  use abstract to make operations invisible to users. In
4533       --  particular, if type Address is non-private and abstract
4534       --  subprograms are used to hide its operators, they will be
4535       --  truly hidden.
4536
4537       type Operand_Position is (First_Op, Second_Op);
4538       Univ_Type : constant Entity_Id := Universal_Interpretation (N);
4539
4540       procedure Remove_Address_Interpretations (Op : Operand_Position);
4541       --  Ambiguities may arise when the operands are literal and the
4542       --  address operations in s-auxdec are visible. In that case, remove
4543       --  the interpretation of a literal as Address, to retain the semantics
4544       --  of Address as a private type.
4545
4546       ------------------------------------
4547       -- Remove_Address_Interpretations --
4548       ------------------------------------
4549
4550       procedure Remove_Address_Interpretations (Op : Operand_Position) is
4551          Formal : Entity_Id;
4552
4553       begin
4554          if Is_Overloaded (N) then
4555             Get_First_Interp (N, I, It);
4556             while Present (It.Nam) loop
4557                Formal := First_Entity (It.Nam);
4558
4559                if Op = Second_Op then
4560                   Formal := Next_Entity (Formal);
4561                end if;
4562
4563                if Is_Descendent_Of_Address (Etype (Formal)) then
4564                   Remove_Interp (I);
4565                end if;
4566
4567                Get_Next_Interp (I, It);
4568             end loop;
4569          end if;
4570       end Remove_Address_Interpretations;
4571
4572    --  Start of processing for Remove_Abstract_Operations
4573
4574    begin
4575       if Is_Overloaded (N) then
4576          Get_First_Interp (N, I, It);
4577
4578          while Present (It.Nam) loop
4579             if not Is_Type (It.Nam)
4580               and then Is_Abstract (It.Nam)
4581               and then not Is_Dispatching_Operation (It.Nam)
4582               and then
4583                 (Ada_Version >= Ada_05
4584                    or else Is_Predefined_File_Name
4585                              (Unit_File_Name (Get_Source_Unit (It.Nam))))
4586
4587             then
4588                Abstract_Op := It.Nam;
4589                Remove_Interp (I);
4590                exit;
4591             end if;
4592
4593             Get_Next_Interp (I, It);
4594          end loop;
4595
4596          if No (Abstract_Op) then
4597             return;
4598
4599          elsif Nkind (N) in N_Op then
4600
4601             --  Remove interpretations that treat literals as addresses.
4602             --  This is never appropriate.
4603
4604             if Nkind (N) in N_Binary_Op then
4605                declare
4606                   U1 : constant Boolean :=
4607                      Present (Universal_Interpretation (Right_Opnd (N)));
4608                   U2 : constant Boolean :=
4609                      Present (Universal_Interpretation (Left_Opnd (N)));
4610
4611                begin
4612                   if U1 and then not U2 then
4613                      Remove_Address_Interpretations (Second_Op);
4614
4615                   elsif U2 and then not U1 then
4616                      Remove_Address_Interpretations (First_Op);
4617                   end if;
4618
4619                   if not (U1 and U2) then
4620
4621                      --  Remove corresponding predefined operator, which is
4622                      --  always added to the overload set.
4623
4624                      Get_First_Interp (N, I, It);
4625                      while Present (It.Nam) loop
4626                         if Scope (It.Nam) = Standard_Standard
4627                           and then Base_Type (It.Typ) =
4628                                    Base_Type (Etype (Abstract_Op))
4629                         then
4630                            Remove_Interp (I);
4631                         end if;
4632
4633                         Get_Next_Interp (I, It);
4634                      end loop;
4635
4636                   elsif Is_Overloaded (N)
4637                     and then Present (Univ_Type)
4638                   then
4639                      --  If both operands have a universal interpretation,
4640                      --  select the predefined operator and discard others.
4641
4642                      Get_First_Interp (N, I, It);
4643
4644                      while Present (It.Nam) loop
4645                         if Scope (It.Nam) = Standard_Standard then
4646                            Set_Etype (N, Univ_Type);
4647                            Set_Entity (N, It.Nam);
4648                            Set_Is_Overloaded (N, False);
4649                            exit;
4650                         end if;
4651
4652                         Get_Next_Interp (I, It);
4653                      end loop;
4654                   end if;
4655                end;
4656             end if;
4657
4658          elsif Nkind (N) = N_Function_Call
4659            and then
4660              (Nkind (Name (N)) = N_Operator_Symbol
4661                 or else
4662                   (Nkind (Name (N)) = N_Expanded_Name
4663                      and then
4664                        Nkind (Selector_Name (Name (N))) = N_Operator_Symbol))
4665          then
4666
4667             declare
4668                Arg1 : constant Node_Id := First (Parameter_Associations (N));
4669                U1   : constant Boolean :=
4670                         Present (Universal_Interpretation (Arg1));
4671                U2   : constant Boolean :=
4672                         Present (Next (Arg1)) and then
4673                         Present (Universal_Interpretation (Next (Arg1)));
4674
4675             begin
4676                if U1 and then not U2 then
4677                   Remove_Address_Interpretations (First_Op);
4678
4679                elsif U2 and then not U1 then
4680                   Remove_Address_Interpretations (Second_Op);
4681                end if;
4682
4683                if not (U1 and U2) then
4684                   Get_First_Interp (N, I, It);
4685                   while Present (It.Nam) loop
4686                      if Scope (It.Nam) = Standard_Standard
4687                        and then It.Typ = Base_Type (Etype (Abstract_Op))
4688                      then
4689                         Remove_Interp (I);
4690                      end if;
4691
4692                      Get_Next_Interp (I, It);
4693                   end loop;
4694                end if;
4695             end;
4696          end if;
4697
4698          --  If the removal has left no valid interpretations, emit
4699          --  error message now and label node as illegal.
4700
4701          if Present (Abstract_Op) then
4702             Get_First_Interp (N, I, It);
4703
4704             if No (It.Nam) then
4705
4706                --  Removal of abstract operation left no viable candidate
4707
4708                Set_Etype (N, Any_Type);
4709                Error_Msg_Sloc := Sloc (Abstract_Op);
4710                Error_Msg_NE
4711                  ("cannot call abstract operation& declared#", N, Abstract_Op);
4712             end if;
4713          end if;
4714       end if;
4715    end Remove_Abstract_Operations;
4716
4717    -----------------------
4718    -- Try_Indirect_Call --
4719    -----------------------
4720
4721    function Try_Indirect_Call
4722      (N   : Node_Id;
4723       Nam : Entity_Id;
4724       Typ : Entity_Id) return Boolean
4725    is
4726       Actual  : Node_Id;
4727       Formal  : Entity_Id;
4728       Call_OK : Boolean;
4729
4730    begin
4731       Normalize_Actuals (N, Designated_Type (Typ), False, Call_OK);
4732       Actual := First_Actual (N);
4733       Formal := First_Formal (Designated_Type (Typ));
4734
4735       while Present (Actual)
4736         and then Present (Formal)
4737       loop
4738          if not Has_Compatible_Type (Actual, Etype (Formal)) then
4739             return False;
4740          end if;
4741
4742          Next (Actual);
4743          Next_Formal (Formal);
4744       end loop;
4745
4746       if No (Actual) and then No (Formal) then
4747          Add_One_Interp (N, Nam, Etype (Designated_Type (Typ)));
4748
4749          --  Nam is a candidate interpretation for the name in the call,
4750          --  if it is not an indirect call.
4751
4752          if not Is_Type (Nam)
4753             and then Is_Entity_Name (Name (N))
4754          then
4755             Set_Entity (Name (N), Nam);
4756          end if;
4757
4758          return True;
4759       else
4760          return False;
4761       end if;
4762    end Try_Indirect_Call;
4763
4764    ----------------------
4765    -- Try_Indexed_Call --
4766    ----------------------
4767
4768    function Try_Indexed_Call
4769      (N   : Node_Id;
4770       Nam : Entity_Id;
4771       Typ : Entity_Id) return Boolean
4772    is
4773       Actuals : constant List_Id   := Parameter_Associations (N);
4774       Actual : Node_Id;
4775       Index  : Entity_Id;
4776
4777    begin
4778       Actual := First (Actuals);
4779       Index := First_Index (Typ);
4780       while Present (Actual)
4781         and then Present (Index)
4782       loop
4783          --  If the parameter list has a named association, the expression
4784          --  is definitely a call and not an indexed component.
4785
4786          if Nkind (Actual) = N_Parameter_Association then
4787             return False;
4788          end if;
4789
4790          if not Has_Compatible_Type (Actual, Etype (Index)) then
4791             return False;
4792          end if;
4793
4794          Next (Actual);
4795          Next_Index (Index);
4796       end loop;
4797
4798       if No (Actual) and then No (Index) then
4799          Add_One_Interp (N, Nam, Component_Type (Typ));
4800
4801          --  Nam is a candidate interpretation for the name in the call,
4802          --  if it is not an indirect call.
4803
4804          if not Is_Type (Nam)
4805             and then Is_Entity_Name (Name (N))
4806          then
4807             Set_Entity (Name (N), Nam);
4808          end if;
4809
4810          return True;
4811       else
4812          return False;
4813       end if;
4814    end Try_Indexed_Call;
4815
4816    --------------------------
4817    -- Try_Object_Operation --
4818    --------------------------
4819
4820    function Try_Object_Operation (N : Node_Id) return Boolean is
4821       K               : constant Node_Kind  := Nkind (Parent (N));
4822       Loc             : constant Source_Ptr := Sloc (N);
4823       Is_Subprg_Call  : constant Boolean    := K = N_Procedure_Call_Statement
4824                                                 or else K = N_Function_Call;
4825       Obj             : constant Node_Id    := Prefix (N);
4826       Subprog         : constant Node_Id    := Selector_Name (N);
4827
4828       Actual          : Node_Id;
4829       Call_Node       : Node_Id;
4830       Call_Node_Case  : Node_Id := Empty;
4831       First_Actual    : Node_Id;
4832       Node_To_Replace : Node_Id;
4833       Obj_Type        : Entity_Id := Etype (Obj);
4834
4835       procedure Complete_Object_Operation
4836         (Call_Node       : Node_Id;
4837          Node_To_Replace : Node_Id;
4838          Subprog         : Node_Id);
4839       --  Set Subprog as the name of Call_Node, replace Node_To_Replace with
4840       --  Call_Node and reanalyze Node_To_Replace.
4841
4842       procedure Transform_Object_Operation
4843         (Call_Node       : out Node_Id;
4844          First_Actual    : Node_Id;
4845          Node_To_Replace : out Node_Id;
4846          Subprog         : Node_Id);
4847       --  Transform Object.Operation (...) to Operation (Object, ...)
4848       --  Call_Node is the resulting subprogram call node, First_Actual is
4849       --  either the object Obj or an explicit dereference of Obj in certain
4850       --  cases, Node_To_Replace is either N or the parent of N, and Subprog
4851       --  is the subprogram we are trying to match.
4852
4853       function Try_Class_Wide_Operation
4854         (Call_Node       : Node_Id;
4855          Node_To_Replace : Node_Id) return Boolean;
4856       --  Traverse all the ancestor types looking for a class-wide subprogram
4857       --  that matches Subprog.
4858
4859       function Try_Primitive_Operation
4860         (Call_Node       : Node_Id;
4861          Node_To_Replace : Node_Id) return Boolean;
4862       --  Traverse the list of primitive subprograms looking for a subprogram
4863       --  than matches Subprog.
4864
4865       -------------------------------
4866       -- Complete_Object_Operation --
4867       -------------------------------
4868
4869       procedure Complete_Object_Operation
4870         (Call_Node       : Node_Id;
4871          Node_To_Replace : Node_Id;
4872          Subprog         : Node_Id)
4873       is
4874       begin
4875          Set_Name (Call_Node, New_Copy_Tree (Subprog));
4876          Set_Analyzed (Call_Node, False);
4877          Rewrite (Node_To_Replace, Call_Node);
4878          Analyze (Node_To_Replace);
4879       end Complete_Object_Operation;
4880
4881       --------------------------------
4882       -- Transform_Object_Operation --
4883       --------------------------------
4884
4885       procedure Transform_Object_Operation
4886         (Call_Node       : out Node_Id;
4887          First_Actual    : Node_Id;
4888          Node_To_Replace : out Node_Id;
4889          Subprog         : Node_Id)
4890       is
4891          Actuals     : List_Id;
4892          Parent_Node : constant Node_Id := Parent (N);
4893
4894       begin
4895          Actuals := New_List (New_Copy_Tree (First_Actual));
4896
4897          if (Nkind (Parent_Node) = N_Function_Call
4898                or else
4899              Nkind (Parent_Node) = N_Procedure_Call_Statement)
4900
4901             --  Avoid recursive calls
4902
4903            and then N /= First (Parameter_Associations (Parent_Node))
4904          then
4905             Node_To_Replace := Parent_Node;
4906
4907             --  Copy list of actuals in full before attempting to resolve call.
4908             --  This is necessary to ensure that the chaining of named actuals
4909             --  that happens during matching is done on a separate copy.
4910
4911             declare
4912                Actual : Node_Id;
4913             begin
4914                Actual := First (Parameter_Associations (Parent_Node));
4915                while Present (Actual) loop
4916                   declare
4917                      New_Actual : constant Node_Id := New_Copy_Tree (Actual);
4918
4919                   begin
4920                      Append (New_Actual, Actuals);
4921
4922                      if Nkind (Actual) = N_Function_Call
4923                        and then Is_Overloaded (Name (Actual))
4924                      then
4925                         Save_Interps (Name (Actual), Name (New_Actual));
4926                      end if;
4927                   end;
4928
4929                   Next (Actual);
4930                end loop;
4931             end;
4932
4933             if Nkind (Parent_Node) = N_Procedure_Call_Statement then
4934                Call_Node :=
4935                  Make_Procedure_Call_Statement (Loc,
4936                    Name => New_Copy_Tree (Subprog),
4937                    Parameter_Associations => Actuals);
4938
4939             else
4940                pragma Assert (Nkind (Parent_Node) = N_Function_Call);
4941
4942                Call_Node :=
4943                  Make_Function_Call (Loc,
4944                    Name => New_Copy_Tree (Subprog),
4945                    Parameter_Associations => Actuals);
4946
4947             end if;
4948
4949          --  Before analysis, the function call appears as an
4950          --  indexed component.
4951
4952          elsif Nkind (Parent_Node) =  N_Indexed_Component then
4953             Node_To_Replace := Parent_Node;
4954
4955             declare
4956                Actual : Node_Id;
4957                New_Act : Node_Id;
4958             begin
4959                Actual := First (Expressions (Parent_Node));
4960                while Present (Actual) loop
4961                   New_Act := New_Copy_Tree (Actual);
4962                   Analyze (New_Act);
4963                   Append (New_Act, Actuals);
4964                   Next (Actual);
4965                end loop;
4966             end;
4967
4968             Call_Node :=
4969                Make_Function_Call (Loc,
4970                  Name => New_Copy_Tree (Subprog),
4971                  Parameter_Associations => Actuals);
4972
4973          --  Parameterless call
4974
4975          else
4976             Node_To_Replace := N;
4977
4978             Call_Node :=
4979                Make_Function_Call (Loc,
4980                  Name => New_Copy_Tree (Subprog),
4981                  Parameter_Associations => Actuals);
4982          end if;
4983       end Transform_Object_Operation;
4984
4985       ------------------------------
4986       -- Try_Class_Wide_Operation --
4987       ------------------------------
4988
4989       function Try_Class_Wide_Operation
4990         (Call_Node       : Node_Id;
4991          Node_To_Replace : Node_Id) return Boolean
4992       is
4993          Anc_Type : Entity_Id;
4994          Dummy    : Node_Id;
4995          Hom      : Entity_Id;
4996          Hom_Ref  : Node_Id;
4997          Success  : Boolean;
4998
4999       begin
5000          --  Loop through ancestor types, traverse their homonym chains and
5001          --  gather all interpretations of the subprogram.
5002
5003          Anc_Type := Obj_Type;
5004          loop
5005             Hom := Current_Entity (Subprog);
5006             while Present (Hom) loop
5007                if (Ekind (Hom) = E_Procedure
5008                      or else
5009                    Ekind (Hom) = E_Function)
5010                  and then Present (First_Formal (Hom))
5011                  and then Etype (First_Formal (Hom)) =
5012                             Class_Wide_Type (Anc_Type)
5013                then
5014                   Hom_Ref := New_Reference_To (Hom, Loc);
5015
5016                   --  When both the type of the object and the type of the
5017                   --  first formal of the primitive operation are tagged
5018                   --  access types, we use a node with the object as first
5019                   --  actual.
5020
5021                   if Is_Access_Type (Etype (Obj))
5022                     and then Ekind (Etype (First_Formal (Hom))) =
5023                                E_Anonymous_Access_Type
5024                   then
5025                      --  Allocate the node only once
5026
5027                      if not Present (Call_Node_Case) then
5028                         Analyze_Expression (Obj);
5029                         Set_Analyzed       (Obj);
5030
5031                         Transform_Object_Operation (
5032                           Call_Node       => Call_Node_Case,
5033                           First_Actual    => Obj,
5034                           Node_To_Replace => Dummy,
5035                           Subprog         => Subprog);
5036
5037                         Set_Etype (Call_Node_Case, Any_Type);
5038                         Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
5039                      end if;
5040
5041                      Set_Name (Call_Node_Case, Hom_Ref);
5042
5043                      Analyze_One_Call (
5044                        N       => Call_Node_Case,
5045                        Nam     => Hom,
5046                        Report  => False,
5047                        Success => Success);
5048
5049                      if Success then
5050                         Complete_Object_Operation (
5051                           Call_Node       => Call_Node_Case,
5052                           Node_To_Replace => Node_To_Replace,
5053                           Subprog         => Hom_Ref);
5054
5055                         return True;
5056                      end if;
5057
5058                   --  ??? comment required
5059
5060                   else
5061                      Set_Name (Call_Node, Hom_Ref);
5062
5063                      Analyze_One_Call (
5064                        N       => Call_Node,
5065                        Nam     => Hom,
5066                        Report  => False,
5067                        Success => Success);
5068
5069                      if Success then
5070                         Complete_Object_Operation (
5071                           Call_Node       => Call_Node,
5072                           Node_To_Replace => Node_To_Replace,
5073                           Subprog         => Hom_Ref);
5074
5075                         return True;
5076                      end if;
5077                   end if;
5078                end if;
5079
5080                Hom := Homonym (Hom);
5081             end loop;
5082
5083             --  Climb to ancestor type if there is one
5084
5085             exit when Etype (Anc_Type) = Anc_Type;
5086             Anc_Type := Etype (Anc_Type);
5087          end loop;
5088
5089          return False;
5090       end Try_Class_Wide_Operation;
5091
5092       -----------------------------
5093       -- Try_Primitive_Operation --
5094       -----------------------------
5095
5096       function Try_Primitive_Operation
5097         (Call_Node       : Node_Id;
5098          Node_To_Replace : Node_Id) return Boolean
5099       is
5100          Dummy       : Node_Id;
5101          Elmt        : Elmt_Id;
5102          Prim_Op     : Entity_Id;
5103          Prim_Op_Ref : Node_Id;
5104          Success     : Boolean;
5105
5106       begin
5107          --  Look for the subprogram in the list of primitive operations
5108
5109          Elmt := First_Elmt (Primitive_Operations (Obj_Type));
5110          while Present (Elmt) loop
5111             Prim_Op := Node (Elmt);
5112
5113             if Chars (Prim_Op) = Chars (Subprog)
5114               and then Present (First_Formal (Prim_Op))
5115             then
5116                Prim_Op_Ref := New_Reference_To (Prim_Op, Loc);
5117
5118                --  When both the type of the object and the type of the first
5119                --  formal of the primitive operation are tagged access types,
5120                --  we use a node with the object as first actual.
5121
5122                if Is_Access_Type (Etype (Obj))
5123                  and then Ekind (Etype (First_Formal (Prim_Op))) =
5124                             E_Anonymous_Access_Type
5125                then
5126                   --  Allocate the node only once
5127
5128                   if not Present (Call_Node_Case) then
5129                      Analyze_Expression (Obj);
5130                      Set_Analyzed       (Obj);
5131
5132                      Transform_Object_Operation (
5133                        Call_Node       => Call_Node_Case,
5134                        First_Actual    => Obj,
5135                        Node_To_Replace => Dummy,
5136                        Subprog         => Subprog);
5137
5138                      Set_Etype (Call_Node_Case, Any_Type);
5139                      Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
5140                   end if;
5141
5142                   Set_Name (Call_Node_Case, Prim_Op_Ref);
5143
5144                   Analyze_One_Call (
5145                     N       => Call_Node_Case,
5146                     Nam     => Prim_Op,
5147                     Report  => False,
5148                     Success => Success);
5149
5150                   if Success then
5151                      Complete_Object_Operation (
5152                        Call_Node       => Call_Node_Case,
5153                        Node_To_Replace => Node_To_Replace,
5154                        Subprog         => Prim_Op_Ref);
5155
5156                      return True;
5157                   end if;
5158
5159                --  Comment required ???
5160
5161                else
5162                   Set_Name (Call_Node, Prim_Op_Ref);
5163
5164                   Analyze_One_Call (
5165                     N       => Call_Node,
5166                     Nam     => Prim_Op,
5167                     Report  => False,
5168                     Success => Success);
5169
5170                   if Success then
5171                      Complete_Object_Operation (
5172                        Call_Node       => Call_Node,
5173                        Node_To_Replace => Node_To_Replace,
5174                        Subprog         => Prim_Op_Ref);
5175
5176                      return True;
5177                   end if;
5178                end if;
5179             end if;
5180
5181             Next_Elmt (Elmt);
5182          end loop;
5183
5184          return False;
5185       end Try_Primitive_Operation;
5186
5187    --  Start of processing for Try_Object_Operation
5188
5189    begin
5190       if Is_Access_Type (Obj_Type) then
5191          Obj_Type := Designated_Type (Obj_Type);
5192       end if;
5193
5194       if Ekind (Obj_Type) = E_Private_Subtype then
5195          Obj_Type := Base_Type (Obj_Type);
5196       end if;
5197
5198       if Is_Class_Wide_Type (Obj_Type) then
5199          Obj_Type := Etype (Class_Wide_Type (Obj_Type));
5200       end if;
5201
5202       --  Analyze the actuals in case of subprogram call
5203
5204       if Is_Subprg_Call and then N = Name (Parent (N)) then
5205          Actual := First (Parameter_Associations (Parent (N)));
5206          while Present (Actual) loop
5207             Analyze_Expression (Actual);
5208             Next (Actual);
5209          end loop;
5210       end if;
5211
5212       --  If the object is of an Access type, explicit dereference is
5213       --  required.
5214
5215       if Is_Access_Type (Etype (Obj)) then
5216          First_Actual :=
5217            Make_Explicit_Dereference (Sloc (Obj), Obj);
5218          Set_Etype (First_Actual, Obj_Type);
5219       else
5220          First_Actual := Obj;
5221       end if;
5222
5223       Analyze_Expression (First_Actual);
5224       Set_Analyzed       (First_Actual);
5225
5226       --  Build a subprogram call node
5227
5228       Transform_Object_Operation (
5229         Call_Node       => Call_Node,
5230         First_Actual    => First_Actual,
5231         Node_To_Replace => Node_To_Replace,
5232         Subprog         => Subprog);
5233
5234       Set_Etype (Call_Node, Any_Type);
5235       Set_Parent (Call_Node, Parent (Node_To_Replace));
5236
5237       return
5238          Try_Primitive_Operation
5239            (Call_Node       => Call_Node,
5240             Node_To_Replace => Node_To_Replace)
5241         or else
5242          Try_Class_Wide_Operation
5243            (Call_Node       => Call_Node,
5244             Node_To_Replace => Node_To_Replace);
5245    end Try_Object_Operation;
5246
5247 end Sem_Ch4;