gcc/ada/sem_res.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ R E S                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Debug_A;  use Debug_A;
  31 with Einfo;    use Einfo;
  32 with Errout;   use Errout;
  33 with Expander; use Expander;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Tss;  use Exp_Tss;
  36 with Exp_Util; use Exp_Util;
  37 with Freeze;   use Freeze;
  38 with Itypes;   use Itypes;
  39 with Lib;      use Lib;
  40 with Lib.Xref; use Lib.Xref;
  41 with Namet;    use Namet;
  42 with Nmake;    use Nmake;
  43 with Nlists;   use Nlists;
  44 with Opt;      use Opt;
  45 with Output;   use Output;
  46 with Restrict; use Restrict;
  47 with Rident;   use Rident;
  48 with Rtsfind;  use Rtsfind;
  49 with Sem;      use Sem;
  50 with Sem_Aggr; use Sem_Aggr;
  51 with Sem_Attr; use Sem_Attr;
  52 with Sem_Cat;  use Sem_Cat;
  53 with Sem_Ch4;  use Sem_Ch4;
  54 with Sem_Ch6;  use Sem_Ch6;
  55 with Sem_Ch8;  use Sem_Ch8;
  56 with Sem_Disp; use Sem_Disp;
  57 with Sem_Dist; use Sem_Dist;
  58 with Sem_Elab; use Sem_Elab;
  59 with Sem_Eval; use Sem_Eval;
  60 with Sem_Intr; use Sem_Intr;
  61 with Sem_Util; use Sem_Util;
  62 with Sem_Type; use Sem_Type;
  63 with Sem_Warn; use Sem_Warn;
  64 with Sinfo;    use Sinfo;
  65 with Snames;   use Snames;
  66 with Stand;    use Stand;
  67 with Stringt;  use Stringt;
  68 with Targparm; use Targparm;
  69 with Tbuild;   use Tbuild;
  70 with Uintp;    use Uintp;
  71 with Urealp;   use Urealp;
  72
  73 package body Sem_Res is
  74
  75    -----------------------
  76    -- Local Subprograms --
  77    -----------------------
  78
  79    --  Second pass (top-down) type checking and overload resolution procedures
  80    --  Typ is the type required by context. These procedures propagate the
  81    --  type information recursively to the descendants of N. If the node
  82    --  is not overloaded, its Etype is established in the first pass. If
  83    --  overloaded,  the Resolve routines set the correct type. For arith.
  84    --  operators, the Etype is the base type of the context.
  85
  86    --  Note that Resolve_Attribute is separated off in Sem_Attr
  87
  88    procedure Ambiguous_Character (C : Node_Id);
  89    --  Give list of candidate interpretations when a character literal cannot
  90    --  be resolved.
  91
  92    procedure Check_Direct_Boolean_Op (N : Node_Id);
  93    --  N is a binary operator node which may possibly operate on Boolean
  94    --  operands. If the operator does have Boolean operands, then a call is
  95    --  made to check the restriction No_Direct_Boolean_Operators.
  96
  97    procedure Check_Discriminant_Use (N : Node_Id);
  98    --  Enforce the restrictions on the use of discriminants when constraining
  99    --  a component of a discriminated type (record or concurrent type).
 100
 101    procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);
 102    --  Given a node for an operator associated with type T, check that
 103    --  the operator is visible. Operators all of whose operands are
 104    --  universal must be checked for visibility during resolution
 105    --  because their type is not determinable based on their operands.
 106
 107    function Check_Infinite_Recursion (N : Node_Id) return Boolean;
 108    --  Given a call node, N, which is known to occur immediately within the
 109    --  subprogram being called, determines whether it is a detectable case of
 110    --  an infinite recursion, and if so, outputs appropriate messages. Returns
 111    --  True if an infinite recursion is detected, and False otherwise.
 112
 113    procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
 114    --  If the type of the object being initialized uses the secondary stack
 115    --  directly or indirectly, create a transient scope for the call to the
 116    --  init proc. This is because we do not create transient scopes for the
 117    --  initialization of individual components within the init proc itself.
 118    --  Could be optimized away perhaps?
 119
 120    function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
 121    --  Utility to check whether the name in the call is a predefined
 122    --  operator, in which case the call is made into an operator node.
 123    --  An instance of an intrinsic conversion operation may be given
 124    --  an operator name, but is not treated like an operator.
 125
 126    procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);
 127    --  If a default expression in entry call N depends on the discriminants
 128    --  of the task, it must be replaced with a reference to the discriminant
 129    --  of the task being called.
 130
 131    procedure Resolve_Allocator                 (N : Node_Id; Typ : Entity_Id);
 132    procedure Resolve_Arithmetic_Op             (N : Node_Id; Typ : Entity_Id);
 133    procedure Resolve_Call                      (N : Node_Id; Typ : Entity_Id);
 134    procedure Resolve_Character_Literal         (N : Node_Id; Typ : Entity_Id);
 135    procedure Resolve_Comparison_Op             (N : Node_Id; Typ : Entity_Id);
 136    procedure Resolve_Conditional_Expression    (N : Node_Id; Typ : Entity_Id);
 137    procedure Resolve_Equality_Op               (N : Node_Id; Typ : Entity_Id);
 138    procedure Resolve_Explicit_Dereference      (N : Node_Id; Typ : Entity_Id);
 139    procedure Resolve_Entity_Name               (N : Node_Id; Typ : Entity_Id);
 140    procedure Resolve_Indexed_Component         (N : Node_Id; Typ : Entity_Id);
 141    procedure Resolve_Integer_Literal           (N : Node_Id; Typ : Entity_Id);
 142    procedure Resolve_Logical_Op                (N : Node_Id; Typ : Entity_Id);
 143    procedure Resolve_Membership_Op             (N : Node_Id; Typ : Entity_Id);
 144    procedure Resolve_Null                      (N : Node_Id; Typ : Entity_Id);
 145    procedure Resolve_Operator_Symbol           (N : Node_Id; Typ : Entity_Id);
 146    procedure Resolve_Op_Concat                 (N : Node_Id; Typ : Entity_Id);
 147    procedure Resolve_Op_Expon                  (N : Node_Id; Typ : Entity_Id);
 148    procedure Resolve_Op_Not                    (N : Node_Id; Typ : Entity_Id);
 149    procedure Resolve_Qualified_Expression      (N : Node_Id; Typ : Entity_Id);
 150    procedure Resolve_Range                     (N : Node_Id; Typ : Entity_Id);
 151    procedure Resolve_Real_Literal              (N : Node_Id; Typ : Entity_Id);
 152    procedure Resolve_Reference                 (N : Node_Id; Typ : Entity_Id);
 153    procedure Resolve_Selected_Component        (N : Node_Id; Typ : Entity_Id);
 154    procedure Resolve_Shift                     (N : Node_Id; Typ : Entity_Id);
 155    procedure Resolve_Short_Circuit             (N : Node_Id; Typ : Entity_Id);
 156    procedure Resolve_Slice                     (N : Node_Id; Typ : Entity_Id);
 157    procedure Resolve_String_Literal            (N : Node_Id; Typ : Entity_Id);
 158    procedure Resolve_Subprogram_Info           (N : Node_Id; Typ : Entity_Id);
 159    procedure Resolve_Type_Conversion           (N : Node_Id; Typ : Entity_Id);
 160    procedure Resolve_Unary_Op                  (N : Node_Id; Typ : Entity_Id);
 161    procedure Resolve_Unchecked_Expression      (N : Node_Id; Typ : Entity_Id);
 162    procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id);
 163
 164    function Operator_Kind
 165      (Op_Name   : Name_Id;
 166       Is_Binary : Boolean) return Node_Kind;
 167    --  Utility to map the name of an operator into the corresponding Node. Used
 168    --  by other node rewriting procedures.
 169
 170    procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
 171    --  Resolve actuals of call, and add default expressions for missing ones.
 172
 173    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
 174    --  Called from Resolve_Call, when the prefix denotes an entry or element
 175    --  of entry family. Actuals are resolved as for subprograms, and the node
 176    --  is rebuilt as an entry call. Also called for protected operations. Typ
 177    --  is the context type, which is used when the operation is a protected
 178    --  function with no arguments, and the return value is indexed.
 179
 180    procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
 181    --  A call to a user-defined intrinsic operator is rewritten as a call
 182    --  to the corresponding predefined operator, with suitable conversions.
 183
 184    procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
 185    --  Ditto, for unary operators (only arithmetic ones).
 186
 187    procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
 188    --  If an operator node resolves to a call to a user-defined operator,
 189    --  rewrite the node as a function call.
 190
 191    procedure Make_Call_Into_Operator
 192      (N     : Node_Id;
 193       Typ   : Entity_Id;
 194       Op_Id : Entity_Id);
 195    --  Inverse transformation: if an operator is given in functional notation,
 196    --  then after resolving the node, transform into an operator node, so
 197    --  that operands are resolved properly. Recall that predefined operators
 198    --  do not have a full signature and special resolution rules apply.
 199
 200    procedure Rewrite_Renamed_Operator
 201      (N   : Node_Id;
 202       Op  : Entity_Id;
 203       Typ : Entity_Id);
 204    --  An operator can rename another, e.g. in  an instantiation. In that
 205    --  case, the proper operator node must be constructed and resolved.
 206
 207    procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
 208    --  The String_Literal_Subtype is built for all strings that are not
 209    --  operands of a static concatenation operation. If the argument is
 210    --  not a N_String_Literal node, then the call has no effect.
 211
 212    procedure Set_Slice_Subtype (N : Node_Id);
 213    --  Build subtype of array type, with the range specified by the slice
 214
 215    function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
 216    --  A universal_fixed expression in an universal context is unambiguous
 217    --  if there is only one applicable fixed point type. Determining whether
 218    --  there is only one requires a search over all visible entities, and
 219    --  happens only in very pathological cases (see 6115-006).
 220
 221    function Valid_Conversion
 222      (N       : Node_Id;
 223       Target  : Entity_Id;
 224       Operand : Node_Id) return Boolean;
 225    --  Verify legality rules given in 4.6 (8-23). Target is the target
 226    --  type of the conversion, which may be an implicit conversion of
 227    --  an actual parameter to an anonymous access type (in which case
 228    --  N denotes the actual parameter and N = Operand).
 229
 230    -------------------------
 231    -- Ambiguous_Character --
 232    -------------------------
 233
 234    procedure Ambiguous_Character (C : Node_Id) is
 235       E : Entity_Id;
 236
 237    begin
 238       if Nkind (C) = N_Character_Literal then
 239          Error_Msg_N ("ambiguous character literal", C);
 240          Error_Msg_N
 241            ("\possible interpretations: Character, Wide_Character!", C);
 242
 243          E := Current_Entity (C);
 244
 245          if Present (E) then
 246
 247             while Present (E) loop
 248                Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
 249                E := Homonym (E);
 250             end loop;
 251          end if;
 252       end if;
 253    end Ambiguous_Character;
 254
 255    -------------------------
 256    -- Analyze_And_Resolve --
 257    -------------------------
 258
 259    procedure Analyze_And_Resolve (N : Node_Id) is
 260    begin
 261       Analyze (N);
 262       Resolve (N);
 263    end Analyze_And_Resolve;
 264
 265    procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
 266    begin
 267       Analyze (N);
 268       Resolve (N, Typ);
 269    end Analyze_And_Resolve;
 270
 271    --  Version withs check(s) suppressed
 272
 273    procedure Analyze_And_Resolve
 274      (N        : Node_Id;
 275       Typ      : Entity_Id;
 276       Suppress : Check_Id)
 277    is
 278       Scop : constant Entity_Id := Current_Scope;
 279
 280    begin
 281       if Suppress = All_Checks then
 282          declare
 283             Svg : constant Suppress_Array := Scope_Suppress;
 284
 285          begin
 286             Scope_Suppress := (others => True);
 287             Analyze_And_Resolve (N, Typ);
 288             Scope_Suppress := Svg;
 289          end;
 290
 291       else
 292          declare
 293             Svg : constant Boolean := Scope_Suppress (Suppress);
 294
 295          begin
 296             Scope_Suppress (Suppress) := True;
 297             Analyze_And_Resolve (N, Typ);
 298             Scope_Suppress (Suppress) := Svg;
 299          end;
 300       end if;
 301
 302       if Current_Scope /= Scop
 303         and then Scope_Is_Transient
 304       then
 305          --  This can only happen if a transient scope was created
 306          --  for an inner expression, which will be removed upon
 307          --  completion of the analysis of an enclosing construct.
 308          --  The transient scope must have the suppress status of
 309          --  the enclosing environment, not of this Analyze call.
 310
 311          Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
 312            Scope_Suppress;
 313       end if;
 314    end Analyze_And_Resolve;
 315
 316    procedure Analyze_And_Resolve
 317      (N        : Node_Id;
 318       Suppress : Check_Id)
 319    is
 320       Scop : constant Entity_Id := Current_Scope;
 321
 322    begin
 323       if Suppress = All_Checks then
 324          declare
 325             Svg : constant Suppress_Array := Scope_Suppress;
 326
 327          begin
 328             Scope_Suppress := (others => True);
 329             Analyze_And_Resolve (N);
 330             Scope_Suppress := Svg;
 331          end;
 332
 333       else
 334          declare
 335             Svg : constant Boolean := Scope_Suppress (Suppress);
 336
 337          begin
 338             Scope_Suppress (Suppress) := True;
 339             Analyze_And_Resolve (N);
 340             Scope_Suppress (Suppress) := Svg;
 341          end;
 342       end if;
 343
 344       if Current_Scope /= Scop
 345         and then Scope_Is_Transient
 346       then
 347          Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
 348            Scope_Suppress;
 349       end if;
 350    end Analyze_And_Resolve;
 351
 352    -----------------------------
 353    -- Check_Direct_Boolean_Op --
 354    -----------------------------
 355
 356    procedure Check_Direct_Boolean_Op (N : Node_Id) is
 357    begin
 358       if Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean then
 359          Check_Restriction (No_Direct_Boolean_Operators, N);
 360       end if;
 361    end Check_Direct_Boolean_Op;
 362
 363    ----------------------------
 364    -- Check_Discriminant_Use --
 365    ----------------------------
 366
 367    procedure Check_Discriminant_Use (N : Node_Id) is
 368       PN   : constant Node_Id   := Parent (N);
 369       Disc : constant Entity_Id := Entity (N);
 370       P    : Node_Id;
 371       D    : Node_Id;
 372
 373    begin
 374       --  Any use in a default expression is legal.
 375
 376       if In_Default_Expression then
 377          null;
 378
 379       elsif Nkind (PN) = N_Range then
 380
 381          --  Discriminant cannot be used to constrain a scalar type.
 382
 383          P := Parent (PN);
 384
 385          if Nkind (P) = N_Range_Constraint
 386            and then Nkind (Parent (P)) = N_Subtype_Indication
 387            and then Nkind (Parent (Parent (P))) = N_Component_Definition
 388          then
 389             Error_Msg_N ("discriminant cannot constrain scalar type", N);
 390
 391          elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then
 392
 393             --  The following check catches the unusual case where
 394             --  a discriminant appears within an index constraint
 395             --  that is part of a larger expression within a constraint
 396             --  on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))".
 397             --  For now we only check case of record components, and
 398             --  note that a similar check should also apply in the
 399             --  case of discriminant constraints below. ???
 400
 401             --  Note that the check for N_Subtype_Declaration below is to
 402             --  detect the valid use of discriminants in the constraints of a
 403             --  subtype declaration when this subtype declaration appears
 404             --  inside the scope of a record type (which is syntactically
 405             --  illegal, but which may be created as part of derived type
 406             --  processing for records). See Sem_Ch3.Build_Derived_Record_Type
 407             --  for more info.
 408
 409             if Ekind (Current_Scope) = E_Record_Type
 410               and then Scope (Disc) = Current_Scope
 411               and then not
 412                 (Nkind (Parent (P)) = N_Subtype_Indication
 413                    and then
 414                     (Nkind (Parent (Parent (P))) = N_Component_Definition
 415                        or else
 416                      Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
 417                   and then Paren_Count (N) = 0)
 418             then
 419                Error_Msg_N
 420                  ("discriminant must appear alone in component constraint", N);
 421                return;
 422             end if;
 423
 424             --   Detect a common beginner error:
 425
 426             --   type R (D : Positive := 100) is record
 427             --     Name : String (1 .. D);
 428             --   end record;
 429
 430             --  The default value causes an object of type R to be
 431             --  allocated with room for Positive'Last characters.
 432
 433             declare
 434                SI : Node_Id;
 435                T  : Entity_Id;
 436                TB : Node_Id;
 437                CB : Entity_Id;
 438
 439                function Large_Storage_Type (T : Entity_Id) return Boolean;
 440                --  Return True if type T has a large enough range that
 441                --  any array whose index type covered the whole range of
 442                --  the type would likely raise Storage_Error.
 443
 444                ------------------------
 445                -- Large_Storage_Type --
 446                ------------------------
 447
 448                function Large_Storage_Type (T : Entity_Id) return Boolean is
 449                begin
 450                   return
 451                     T = Standard_Integer
 452                       or else
 453                     T = Standard_Positive
 454                       or else
 455                     T = Standard_Natural;
 456                end Large_Storage_Type;
 457
 458             begin
 459                --  Check that the Disc has a large range
 460
 461                if not Large_Storage_Type (Etype (Disc)) then
 462                   goto No_Danger;
 463                end if;
 464
 465                --  If the enclosing type is limited, we allocate only the
 466                --  default value, not the maximum, and there is no need for
 467                --  a warning.
 468
 469                if Is_Limited_Type (Scope (Disc)) then
 470                   goto No_Danger;
 471                end if;
 472
 473                --  Check that it is the high bound
 474
 475                if N /= High_Bound (PN)
 476                  or else not Present (Discriminant_Default_Value (Disc))
 477                then
 478                   goto No_Danger;
 479                end if;
 480
 481                --  Check the array allows a large range at this bound.
 482                --  First find the array
 483
 484                SI := Parent (P);
 485
 486                if Nkind (SI) /= N_Subtype_Indication then
 487                   goto No_Danger;
 488                end if;
 489
 490                T := Entity (Subtype_Mark (SI));
 491
 492                if not Is_Array_Type (T) then
 493                   goto No_Danger;
 494                end if;
 495
 496                --  Next, find the dimension
 497
 498                TB := First_Index (T);
 499                CB := First (Constraints (P));
 500                while True
 501                  and then Present (TB)
 502                  and then Present (CB)
 503                  and then CB /= PN
 504                loop
 505                   Next_Index (TB);
 506                   Next (CB);
 507                end loop;
 508
 509                if CB /= PN then
 510                   goto No_Danger;
 511                end if;
 512
 513                --  Now, check the dimension has a large range
 514
 515                if not Large_Storage_Type (Etype (TB)) then
 516                   goto No_Danger;
 517                end if;
 518
 519                --  Warn about the danger
 520
 521                Error_Msg_N
 522                  ("creation of & object may raise Storage_Error?",
 523                   Scope (Disc));
 524
 525                <<No_Danger>>
 526                   null;
 527
 528             end;
 529          end if;
 530
 531       --  Legal case is in index or discriminant constraint
 532
 533       elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint
 534         or else Nkind (PN) = N_Discriminant_Association
 535       then
 536          if Paren_Count (N) > 0 then
 537             Error_Msg_N
 538               ("discriminant in constraint must appear alone",  N);
 539          end if;
 540
 541          return;
 542
 543       --  Otherwise, context is an expression. It should not be within
 544       --  (i.e. a subexpression of) a constraint for a component.
 545
 546       else
 547          D := PN;
 548          P := Parent (PN);
 549
 550          while Nkind (P) /= N_Component_Declaration
 551            and then Nkind (P) /= N_Subtype_Indication
 552            and then Nkind (P) /= N_Entry_Declaration
 553          loop
 554             D := P;
 555             P := Parent (P);
 556             exit when No (P);
 557          end loop;
 558
 559          --  If the discriminant is used in an expression that is a bound
 560          --  of a scalar type, an Itype is created and the bounds are attached
 561          --  to its range,  not to the original subtype indication. Such use
 562          --  is of course a double fault.
 563
 564          if (Nkind (P) = N_Subtype_Indication
 565               and then
 566                 (Nkind (Parent (P)) = N_Component_Definition
 567                    or else
 568                  Nkind (Parent (P)) = N_Derived_Type_Definition)
 569               and then D = Constraint (P))
 570
 571          --  The constraint itself may be given by a subtype indication,
 572          --  rather than by a more common discrete range.
 573
 574            or else (Nkind (P) = N_Subtype_Indication
 575                       and then
 576                     Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
 577            or else Nkind (P) = N_Entry_Declaration
 578            or else Nkind (D) = N_Defining_Identifier
 579          then
 580             Error_Msg_N
 581               ("discriminant in constraint must appear alone",  N);
 582          end if;
 583       end if;
 584    end Check_Discriminant_Use;
 585
 586    --------------------------------
 587    -- Check_For_Visible_Operator --
 588    --------------------------------
 589
 590    procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
 591    begin
 592       if Is_Invisible_Operator (N, T) then
 593          Error_Msg_NE
 594            ("operator for} is not directly visible!", N, First_Subtype (T));
 595          Error_Msg_N ("use clause would make operation legal!", N);
 596       end if;
 597    end Check_For_Visible_Operator;
 598
 599    ------------------------------
 600    -- Check_Infinite_Recursion --
 601    ------------------------------
 602
 603    function Check_Infinite_Recursion (N : Node_Id) return Boolean is
 604       P : Node_Id;
 605       C : Node_Id;
 606
 607       function Same_Argument_List return Boolean;
 608       --  Check whether list of actuals is identical to list of formals
 609       --  of called function (which is also the enclosing scope).
 610
 611       ------------------------
 612       -- Same_Argument_List --
 613       ------------------------
 614
 615       function Same_Argument_List return Boolean is
 616          A    : Node_Id;
 617          F    : Entity_Id;
 618          Subp : Entity_Id;
 619
 620       begin
 621          if not Is_Entity_Name (Name (N)) then
 622             return False;
 623          else
 624             Subp := Entity (Name (N));
 625          end if;
 626
 627          F := First_Formal (Subp);
 628          A := First_Actual (N);
 629
 630          while Present (F) and then Present (A) loop
 631             if not Is_Entity_Name (A)
 632               or else Entity (A) /= F
 633             then
 634                return False;
 635             end if;
 636
 637             Next_Actual (A);
 638             Next_Formal (F);
 639          end loop;
 640
 641          return True;
 642       end Same_Argument_List;
 643
 644    --  Start of processing for Check_Infinite_Recursion
 645
 646    begin
 647       --  Loop moving up tree, quitting if something tells us we are
 648       --  definitely not in an infinite recursion situation.
 649
 650       C := N;
 651       loop
 652          P := Parent (C);
 653          exit when Nkind (P) = N_Subprogram_Body;
 654
 655          if Nkind (P) = N_Or_Else        or else
 656             Nkind (P) = N_And_Then       or else
 657             Nkind (P) = N_If_Statement   or else
 658             Nkind (P) = N_Case_Statement
 659          then
 660             return False;
 661
 662          elsif Nkind (P) = N_Handled_Sequence_Of_Statements
 663            and then C /= First (Statements (P))
 664          then
 665             --  If the call is the expression of a return statement and
 666             --  the actuals are identical to the formals, it's worth a
 667             --  warning. However, we skip this if there is an immediately
 668             --  preceding raise statement, since the call is never executed.
 669
 670             --  Furthermore, this corresponds to a common idiom:
 671
 672             --    function F (L : Thing) return Boolean is
 673             --    begin
 674             --       raise Program_Error;
 675             --       return F (L);
 676             --    end F;
 677
 678             --  for generating a stub function
 679
 680             if Nkind (Parent (N)) = N_Return_Statement
 681               and then Same_Argument_List
 682             then
 683                exit when not Is_List_Member (Parent (N))
 684                  or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement
 685                             and then
 686                           (Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error
 687                              or else
 688                            Present (Condition (Prev (Parent (N))))));
 689             end if;
 690
 691             return False;
 692
 693          else
 694             C := P;
 695          end if;
 696       end loop;
 697
 698       Error_Msg_N ("possible infinite recursion?", N);
 699       Error_Msg_N ("\Storage_Error may be raised at run time?", N);
 700
 701       return True;
 702    end Check_Infinite_Recursion;
 703
 704    -------------------------------
 705    -- Check_Initialization_Call --
 706    -------------------------------
 707
 708    procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
 709       Typ : constant Entity_Id := Etype (First_Formal (Nam));
 710
 711       function Uses_SS (T : Entity_Id) return Boolean;
 712       --  Check whether the creation of an object of the type will involve
 713       --  use of the secondary stack. If T is a record type, this is true
 714       --  if the expression for some component uses the secondary stack, eg.
 715       --  through a call to a function that returns an unconstrained value.
 716       --  False if T is controlled, because cleanups occur elsewhere.
 717
 718       -------------
 719       -- Uses_SS --
 720       -------------
 721
 722       function Uses_SS (T : Entity_Id) return Boolean is
 723          Comp : Entity_Id;
 724          Expr : Node_Id;
 725
 726       begin
 727          if Is_Controlled (T) then
 728             return False;
 729
 730          elsif Is_Array_Type (T) then
 731             return Uses_SS (Component_Type (T));
 732
 733          elsif Is_Record_Type (T) then
 734             Comp := First_Component (T);
 735
 736             while Present (Comp) loop
 737
 738                if Ekind (Comp) = E_Component
 739                  and then Nkind (Parent (Comp)) = N_Component_Declaration
 740                then
 741                   Expr := Expression (Parent (Comp));
 742
 743                   --  The expression for a dynamic component may be
 744                   --  rewritten as a dereference. Retrieve original
 745                   --  call.
 746
 747                   if Nkind (Original_Node (Expr)) = N_Function_Call
 748                     and then Requires_Transient_Scope (Etype (Expr))
 749                   then
 750                      return True;
 751
 752                   elsif Uses_SS (Etype (Comp)) then
 753                      return True;
 754                   end if;
 755                end if;
 756
 757                Next_Component (Comp);
 758             end loop;
 759
 760             return False;
 761
 762          else
 763             return False;
 764          end if;
 765       end Uses_SS;
 766
 767    --  Start of processing for Check_Initialization_Call
 768
 769    begin
 770       --  Nothing to do if functions do not use the secondary stack for
 771       --  returns (i.e. they use a depressed stack pointer instead).
 772
 773       if Functions_Return_By_DSP_On_Target then
 774          return;
 775
 776       --  Otherwise establish a transient scope if the type needs it
 777
 778       elsif Uses_SS (Typ) then
 779          Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
 780       end if;
 781    end Check_Initialization_Call;
 782
 783    ------------------------------
 784    -- Check_Parameterless_Call --
 785    ------------------------------
 786
 787    procedure Check_Parameterless_Call (N : Node_Id) is
 788       Nam : Node_Id;
 789
 790    begin
 791       --  Defend against junk stuff if errors already detected
 792
 793       if Total_Errors_Detected /= 0 then
 794          if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
 795             return;
 796          elsif Nkind (N) in N_Has_Chars
 797            and then Chars (N) in Error_Name_Or_No_Name
 798          then
 799             return;
 800          end if;
 801
 802          Require_Entity (N);
 803       end if;
 804
 805       --  If the context expects a value, and the name is a procedure,
 806       --  this is most likely a missing 'Access. Do not try to resolve
 807       --  the parameterless call, error will be caught when the outer
 808       --  call is analyzed.
 809
 810       if Is_Entity_Name (N)
 811         and then Ekind (Entity (N)) = E_Procedure
 812         and then not Is_Overloaded (N)
 813         and then
 814          (Nkind (Parent (N)) = N_Parameter_Association
 815             or else Nkind (Parent (N)) = N_Function_Call
 816             or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
 817       then
 818          return;
 819       end if;
 820
 821       --  Rewrite as call if overloadable entity that is (or could be, in
 822       --  the overloaded case) a function call. If we know for sure that
 823       --  the entity is an enumeration literal, we do not rewrite it.
 824
 825       if (Is_Entity_Name (N)
 826             and then Is_Overloadable (Entity (N))
 827             and then (Ekind (Entity (N)) /= E_Enumeration_Literal
 828                         or else Is_Overloaded (N)))
 829
 830       --  Rewrite as call if it is an explicit deference of an expression of
 831       --  a subprogram access type, and the suprogram type is not that of a
 832       --  procedure or entry.
 833
 834       or else
 835         (Nkind (N) = N_Explicit_Dereference
 836           and then Ekind (Etype (N)) = E_Subprogram_Type
 837           and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type)
 838
 839       --  Rewrite as call if it is a selected component which is a function,
 840       --  this is the case of a call to a protected function (which may be
 841       --  overloaded with other protected operations).
 842
 843       or else
 844         (Nkind (N) = N_Selected_Component
 845           and then (Ekind (Entity (Selector_Name (N))) = E_Function
 846                       or else
 847                         ((Ekind (Entity (Selector_Name (N))) = E_Entry
 848                             or else
 849                           Ekind (Entity (Selector_Name (N))) = E_Procedure)
 850                             and then Is_Overloaded (Selector_Name (N)))))
 851
 852       --  If one of the above three conditions is met, rewrite as call.
 853       --  Apply the rewriting only once.
 854
 855       then
 856          if Nkind (Parent (N)) /= N_Function_Call
 857            or else N /= Name (Parent (N))
 858          then
 859             Nam := New_Copy (N);
 860
 861             --  If overloaded, overload set belongs to new copy.
 862
 863             Save_Interps (N, Nam);
 864
 865             --  Change node to parameterless function call (note that the
 866             --  Parameter_Associations associations field is left set to Empty,
 867             --  its normal default value since there are no parameters)
 868
 869             Change_Node (N, N_Function_Call);
 870             Set_Name (N, Nam);
 871             Set_Sloc (N, Sloc (Nam));
 872             Analyze_Call (N);
 873          end if;
 874
 875       elsif Nkind (N) = N_Parameter_Association then
 876          Check_Parameterless_Call (Explicit_Actual_Parameter (N));
 877       end if;
 878    end Check_Parameterless_Call;
 879
 880    ----------------------
 881    -- Is_Predefined_Op --
 882    ----------------------
 883
 884    function Is_Predefined_Op (Nam : Entity_Id) return Boolean is
 885    begin
 886       return Is_Intrinsic_Subprogram (Nam)
 887         and then not Is_Generic_Instance (Nam)
 888         and then Chars (Nam) in Any_Operator_Name
 889         and then (No (Alias (Nam))
 890                    or else Is_Predefined_Op (Alias (Nam)));
 891    end Is_Predefined_Op;
 892
 893    -----------------------------
 894    -- Make_Call_Into_Operator --
 895    -----------------------------
 896
 897    procedure Make_Call_Into_Operator
 898      (N     : Node_Id;
 899       Typ   : Entity_Id;
 900       Op_Id : Entity_Id)
 901    is
 902       Op_Name   : constant Name_Id := Chars (Op_Id);
 903       Act1      : Node_Id := First_Actual (N);
 904       Act2      : Node_Id := Next_Actual (Act1);
 905       Error     : Boolean := False;
 906       Func      : constant Entity_Id := Entity (Name (N));
 907       Is_Binary : constant Boolean   := Present (Act2);
 908       Op_Node   : Node_Id;
 909       Opnd_Type : Entity_Id;
 910       Orig_Type : Entity_Id := Empty;
 911       Pack      : Entity_Id;
 912
 913       type Kind_Test is access function (E : Entity_Id) return Boolean;
 914
 915       function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
 916       --  Determine whether E is an access type declared by an access decla-
 917       --  ration, and  not an (anonymous) allocator type.
 918
 919       function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
 920       --  If the operand is not universal, and the operator is given by a
 921       --  expanded name,  verify that the operand has an interpretation with
 922       --  a type defined in the given scope of the operator.
 923
 924       function Type_In_P (Test : Kind_Test) return Entity_Id;
 925       --  Find a type of the given class in the package Pack that contains
 926       --  the operator.
 927
 928       -----------------------------
 929       -- Is_Definite_Access_Type --
 930       -----------------------------
 931
 932       function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
 933          Btyp : constant Entity_Id := Base_Type (E);
 934       begin
 935          return Ekind (Btyp) = E_Access_Type
 936            or else (Ekind (Btyp) = E_Access_Subprogram_Type
 937                      and then Comes_From_Source (Btyp));
 938       end Is_Definite_Access_Type;
 939
 940       ---------------------------
 941       -- Operand_Type_In_Scope --
 942       ---------------------------
 943
 944       function Operand_Type_In_Scope (S : Entity_Id) return Boolean is
 945          Nod : constant Node_Id := Right_Opnd (Op_Node);
 946          I   : Interp_Index;
 947          It  : Interp;
 948
 949       begin
 950          if not Is_Overloaded (Nod) then
 951             return Scope (Base_Type (Etype (Nod))) = S;
 952
 953          else
 954             Get_First_Interp (Nod, I, It);
 955
 956             while Present (It.Typ) loop
 957
 958                if Scope (Base_Type (It.Typ)) = S then
 959                   return True;
 960                end if;
 961
 962                Get_Next_Interp (I, It);
 963             end loop;
 964
 965             return False;
 966          end if;
 967       end Operand_Type_In_Scope;
 968
 969       ---------------
 970       -- Type_In_P --
 971       ---------------
 972
 973       function Type_In_P (Test : Kind_Test) return Entity_Id is
 974          E : Entity_Id;
 975
 976          function In_Decl return Boolean;
 977          --  Verify that node is not part of the type declaration for the
 978          --  candidate type, which would otherwise be invisible.
 979
 980          -------------
 981          -- In_Decl --
 982          -------------
 983
 984          function In_Decl return Boolean is
 985             Decl_Node : constant Node_Id := Parent (E);
 986             N2        : Node_Id;
 987
 988          begin
 989             N2 := N;
 990
 991             if Etype (E) = Any_Type then
 992                return True;
 993
 994             elsif No (Decl_Node) then
 995                return False;
 996
 997             else
 998                while Present (N2)
 999                  and then Nkind (N2) /= N_Compilation_Unit
1000                loop
1001                   if N2 = Decl_Node then
1002                      return True;
1003                   else
1004                      N2 := Parent (N2);
1005                   end if;
1006                end loop;
1007
1008                return False;
1009             end if;
1010          end In_Decl;
1011
1012       --  Start of processing for Type_In_P
1013
1014       begin
1015          --  If the context type is declared in the prefix package, this
1016          --  is the desired base type.
1017
1018          if Scope (Base_Type (Typ)) = Pack
1019            and then Test (Typ)
1020          then
1021             return Base_Type (Typ);
1022
1023          else
1024             E := First_Entity (Pack);
1025
1026             while Present (E) loop
1027
1028                if Test (E)
1029                  and then not In_Decl
1030                then
1031                   return E;
1032                end if;
1033
1034                Next_Entity (E);
1035             end loop;
1036
1037             return Empty;
1038          end if;
1039       end Type_In_P;
1040
1041    --  Start of processing for Make_Call_Into_Operator
1042
1043    begin
1044       Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
1045
1046       --  Binary operator
1047
1048       if Is_Binary then
1049          Set_Left_Opnd  (Op_Node, Relocate_Node (Act1));
1050          Set_Right_Opnd (Op_Node, Relocate_Node (Act2));
1051          Save_Interps (Act1, Left_Opnd  (Op_Node));
1052          Save_Interps (Act2, Right_Opnd (Op_Node));
1053          Act1 := Left_Opnd (Op_Node);
1054          Act2 := Right_Opnd (Op_Node);
1055
1056       --  Unary operator
1057
1058       else
1059          Set_Right_Opnd (Op_Node, Relocate_Node (Act1));
1060          Save_Interps (Act1, Right_Opnd (Op_Node));
1061          Act1 := Right_Opnd (Op_Node);
1062       end if;
1063
1064       --  If the operator is denoted by an expanded name, and the prefix is
1065       --  not Standard, but the operator is a predefined one whose scope is
1066       --  Standard, then this is an implicit_operator, inserted as an
1067       --  interpretation by the procedure of the same name. This procedure
1068       --  overestimates the presence of implicit operators, because it does
1069       --  not examine the type of the operands. Verify now that the operand
1070       --  type appears in the given scope. If right operand is universal,
1071       --  check the other operand. In the case of concatenation, either
1072       --  argument can be the component type, so check the type of the result.
1073       --  If both arguments are literals, look for a type of the right kind
1074       --  defined in the given scope. This elaborate nonsense is brought to
1075       --  you courtesy of b33302a. The type itself must be frozen, so we must
1076       --  find the type of the proper class in the given scope.
1077
1078       --  A final wrinkle is the multiplication operator for fixed point
1079       --  types, which is defined in Standard only, and not in the scope of
1080       --  the fixed_point type itself.
1081
1082       if Nkind (Name (N)) = N_Expanded_Name then
1083          Pack := Entity (Prefix (Name (N)));
1084
1085          --  If the entity being called is defined in the given package,
1086          --  it is a renaming of a predefined operator, and known to be
1087          --  legal.
1088
1089          if Scope (Entity (Name (N))) = Pack
1090             and then Pack /= Standard_Standard
1091          then
1092             null;
1093
1094          elsif (Op_Name =  Name_Op_Multiply
1095               or else Op_Name = Name_Op_Divide)
1096            and then Is_Fixed_Point_Type (Etype (Left_Opnd  (Op_Node)))
1097            and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
1098          then
1099             if Pack /= Standard_Standard then
1100                Error := True;
1101             end if;
1102
1103          else
1104             Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
1105
1106             if Op_Name = Name_Op_Concat then
1107                Opnd_Type := Base_Type (Typ);
1108
1109             elsif (Scope (Opnd_Type) = Standard_Standard
1110                      and then Is_Binary)
1111               or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference
1112                         and then Is_Binary
1113                         and then not Comes_From_Source (Opnd_Type))
1114             then
1115                Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node)));
1116             end if;
1117
1118             if Scope (Opnd_Type) = Standard_Standard then
1119
1120                --  Verify that the scope contains a type that corresponds to
1121                --  the given literal. Optimize the case where Pack is Standard.
1122
1123                if Pack /= Standard_Standard then
1124
1125                   if Opnd_Type = Universal_Integer then
1126                      Orig_Type :=  Type_In_P (Is_Integer_Type'Access);
1127
1128                   elsif Opnd_Type = Universal_Real then
1129                      Orig_Type := Type_In_P (Is_Real_Type'Access);
1130
1131                   elsif Opnd_Type = Any_String then
1132                      Orig_Type := Type_In_P (Is_String_Type'Access);
1133
1134                   elsif Opnd_Type = Any_Access then
1135                      Orig_Type :=  Type_In_P (Is_Definite_Access_Type'Access);
1136
1137                   elsif Opnd_Type = Any_Composite then
1138                      Orig_Type := Type_In_P (Is_Composite_Type'Access);
1139
1140                      if Present (Orig_Type) then
1141                         if Has_Private_Component (Orig_Type) then
1142                            Orig_Type := Empty;
1143                         else
1144                            Set_Etype (Act1, Orig_Type);
1145
1146                            if Is_Binary then
1147                               Set_Etype (Act2, Orig_Type);
1148                            end if;
1149                         end if;
1150                      end if;
1151
1152                   else
1153                      Orig_Type := Empty;
1154                   end if;
1155
1156                   Error := No (Orig_Type);
1157                end if;
1158
1159             elsif Ekind (Opnd_Type) = E_Allocator_Type
1160                and then No (Type_In_P (Is_Definite_Access_Type'Access))
1161             then
1162                Error := True;
1163
1164             --  If the type is defined elsewhere, and the operator is not
1165             --  defined in the given scope (by a renaming declaration, e.g.)
1166             --  then this is an error as well. If an extension of System is
1167             --  present, and the type may be defined there, Pack must be
1168             --  System itself.
1169
1170             elsif Scope (Opnd_Type) /= Pack
1171               and then Scope (Op_Id) /= Pack
1172               and then (No (System_Aux_Id)
1173                          or else Scope (Opnd_Type) /= System_Aux_Id
1174                          or else Pack /= Scope (System_Aux_Id))
1175             then
1176                if not Is_Overloaded (Right_Opnd (Op_Node)) then
1177                   Error := True;
1178                else
1179                   Error := not Operand_Type_In_Scope (Pack);
1180                end if;
1181
1182             elsif Pack = Standard_Standard
1183               and then not Operand_Type_In_Scope (Standard_Standard)
1184             then
1185                Error := True;
1186             end if;
1187          end if;
1188
1189          if Error then
1190             Error_Msg_Node_2 := Pack;
1191             Error_Msg_NE
1192               ("& not declared in&", N, Selector_Name (Name (N)));
1193             Set_Etype (N, Any_Type);
1194             return;
1195          end if;
1196       end if;
1197
1198       Set_Chars  (Op_Node, Op_Name);
1199
1200       if not Is_Private_Type (Etype (N)) then
1201          Set_Etype (Op_Node, Base_Type (Etype (N)));
1202       else
1203          Set_Etype (Op_Node, Etype (N));
1204       end if;
1205
1206       --  If this is a call to a function that renames a predefined equality,
1207       --  the renaming declaration provides a type that must be used to
1208       --  resolve the operands. This must be done now because resolution of
1209       --  the equality node will not resolve any remaining ambiguity, and it
1210       --  assumes that the first operand is not overloaded.
1211
1212       if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
1213         and then Ekind (Func) = E_Function
1214         and then Is_Overloaded (Act1)
1215       then
1216          Resolve (Act1, Base_Type (Etype (First_Formal (Func))));
1217          Resolve (Act2, Base_Type (Etype (First_Formal (Func))));
1218       end if;
1219
1220       Set_Entity (Op_Node, Op_Id);
1221       Generate_Reference (Op_Id, N, ' ');
1222       Rewrite (N,  Op_Node);
1223
1224       --  If this is an arithmetic operator and the result type is private,
1225       --  the operands and the result must be wrapped in conversion to
1226       --  expose the underlying numeric type and expand the proper checks,
1227       --  e.g. on division.
1228
1229       if Is_Private_Type (Typ) then
1230          case Nkind (N) is
1231             when N_Op_Add  | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
1232             N_Op_Expon     | N_Op_Mod      | N_Op_Rem      =>
1233                Resolve_Intrinsic_Operator (N, Typ);
1234
1235             when N_Op_Plus | N_Op_Minus    | N_Op_Abs      =>
1236                Resolve_Intrinsic_Unary_Operator (N, Typ);
1237
1238             when others =>
1239                Resolve (N, Typ);
1240          end case;
1241       else
1242          Resolve (N, Typ);
1243       end if;
1244
1245       --  For predefined operators on literals, the operation freezes
1246       --  their type.
1247
1248       if Present (Orig_Type) then
1249          Set_Etype (Act1, Orig_Type);
1250          Freeze_Expression (Act1);
1251       end if;
1252    end Make_Call_Into_Operator;
1253
1254    -------------------
1255    -- Operator_Kind --
1256    -------------------
1257
1258    function Operator_Kind
1259      (Op_Name   : Name_Id;
1260       Is_Binary : Boolean) return Node_Kind
1261    is
1262       Kind : Node_Kind;
1263
1264    begin
1265       if Is_Binary then
1266          if    Op_Name =  Name_Op_And      then Kind := N_Op_And;
1267          elsif Op_Name =  Name_Op_Or       then Kind := N_Op_Or;
1268          elsif Op_Name =  Name_Op_Xor      then Kind := N_Op_Xor;
1269          elsif Op_Name =  Name_Op_Eq       then Kind := N_Op_Eq;
1270          elsif Op_Name =  Name_Op_Ne       then Kind := N_Op_Ne;
1271          elsif Op_Name =  Name_Op_Lt       then Kind := N_Op_Lt;
1272          elsif Op_Name =  Name_Op_Le       then Kind := N_Op_Le;
1273          elsif Op_Name =  Name_Op_Gt       then Kind := N_Op_Gt;
1274          elsif Op_Name =  Name_Op_Ge       then Kind := N_Op_Ge;
1275          elsif Op_Name =  Name_Op_Add      then Kind := N_Op_Add;
1276          elsif Op_Name =  Name_Op_Subtract then Kind := N_Op_Subtract;
1277          elsif Op_Name =  Name_Op_Concat   then Kind := N_Op_Concat;
1278          elsif Op_Name =  Name_Op_Multiply then Kind := N_Op_Multiply;
1279          elsif Op_Name =  Name_Op_Divide   then Kind := N_Op_Divide;
1280          elsif Op_Name =  Name_Op_Mod      then Kind := N_Op_Mod;
1281          elsif Op_Name =  Name_Op_Rem      then Kind := N_Op_Rem;
1282          elsif Op_Name =  Name_Op_Expon    then Kind := N_Op_Expon;
1283          else
1284             raise Program_Error;
1285          end if;
1286
1287       --  Unary operators
1288
1289       else
1290          if    Op_Name =  Name_Op_Add      then Kind := N_Op_Plus;
1291          elsif Op_Name =  Name_Op_Subtract then Kind := N_Op_Minus;
1292          elsif Op_Name =  Name_Op_Abs      then Kind := N_Op_Abs;
1293          elsif Op_Name =  Name_Op_Not      then Kind := N_Op_Not;
1294          else
1295             raise Program_Error;
1296          end if;
1297       end if;
1298
1299       return Kind;
1300    end Operator_Kind;
1301
1302    -----------------------------
1303    -- Pre_Analyze_And_Resolve --
1304    -----------------------------
1305
1306    procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is
1307       Save_Full_Analysis : constant Boolean := Full_Analysis;
1308
1309    begin
1310       Full_Analysis := False;
1311       Expander_Mode_Save_And_Set (False);
1312
1313       --  We suppress all checks for this analysis, since the checks will
1314       --  be applied properly, and in the right location, when the default
1315       --  expression is reanalyzed and reexpanded later on.
1316
1317       Analyze_And_Resolve (N, T, Suppress => All_Checks);
1318
1319       Expander_Mode_Restore;
1320       Full_Analysis := Save_Full_Analysis;
1321    end Pre_Analyze_And_Resolve;
1322
1323    --  Version without context type.
1324
1325    procedure Pre_Analyze_And_Resolve (N : Node_Id) is
1326       Save_Full_Analysis : constant Boolean := Full_Analysis;
1327
1328    begin
1329       Full_Analysis := False;
1330       Expander_Mode_Save_And_Set (False);
1331
1332       Analyze (N);
1333       Resolve (N, Etype (N), Suppress => All_Checks);
1334
1335       Expander_Mode_Restore;
1336       Full_Analysis := Save_Full_Analysis;
1337    end Pre_Analyze_And_Resolve;
1338
1339    ----------------------------------
1340    -- Replace_Actual_Discriminants --
1341    ----------------------------------
1342
1343    procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is
1344       Loc : constant Source_Ptr := Sloc (N);
1345       Tsk : Node_Id := Empty;
1346
1347       function Process_Discr (Nod : Node_Id) return Traverse_Result;
1348
1349       -------------------
1350       -- Process_Discr --
1351       -------------------
1352
1353       function Process_Discr (Nod : Node_Id) return Traverse_Result is
1354          Ent : Entity_Id;
1355
1356       begin
1357          if Nkind (Nod) = N_Identifier then
1358             Ent := Entity (Nod);
1359
1360             if Present (Ent)
1361               and then Ekind (Ent) = E_Discriminant
1362             then
1363                Rewrite (Nod,
1364                  Make_Selected_Component (Loc,
1365                    Prefix        => New_Copy_Tree (Tsk, New_Sloc => Loc),
1366                    Selector_Name => Make_Identifier (Loc, Chars (Ent))));
1367
1368                Set_Etype (Nod, Etype (Ent));
1369             end if;
1370
1371          end if;
1372
1373          return OK;
1374       end Process_Discr;
1375
1376       procedure Replace_Discrs is new Traverse_Proc (Process_Discr);
1377
1378    --  Start of processing for Replace_Actual_Discriminants
1379
1380    begin
1381       if not Expander_Active then
1382          return;
1383       end if;
1384
1385       if Nkind (Name (N)) = N_Selected_Component then
1386          Tsk := Prefix (Name (N));
1387
1388       elsif Nkind (Name (N)) = N_Indexed_Component then
1389          Tsk := Prefix (Prefix (Name (N)));
1390       end if;
1391
1392       if No (Tsk) then
1393          return;
1394       else
1395          Replace_Discrs (Default);
1396       end if;
1397    end Replace_Actual_Discriminants;
1398
1399    -------------
1400    -- Resolve --
1401    -------------
1402
1403    procedure Resolve (N : Node_Id; Typ : Entity_Id) is
1404       I         : Interp_Index;
1405       I1        : Interp_Index := 0; -- prevent junk warning
1406       It        : Interp;
1407       It1       : Interp;
1408       Found     : Boolean   := False;
1409       Seen      : Entity_Id := Empty; -- prevent junk warning
1410       Ctx_Type  : Entity_Id := Typ;
1411       Expr_Type : Entity_Id := Empty; -- prevent junk warning
1412       Err_Type  : Entity_Id := Empty;
1413       Ambiguous : Boolean   := False;
1414
1415       procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
1416       --  Try and fix up a literal so that it matches its expected type. New
1417       --  literals are manufactured if necessary to avoid cascaded errors.
1418
1419       procedure Resolution_Failed;
1420       --  Called when attempt at resolving current expression fails
1421
1422       --------------------
1423       -- Patch_Up_Value --
1424       --------------------
1425
1426       procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is
1427       begin
1428          if Nkind (N) = N_Integer_Literal
1429            and then Is_Real_Type (Typ)
1430          then
1431             Rewrite (N,
1432               Make_Real_Literal (Sloc (N),
1433                 Realval => UR_From_Uint (Intval (N))));
1434             Set_Etype (N, Universal_Real);
1435             Set_Is_Static_Expression (N);
1436
1437          elsif Nkind (N) = N_Real_Literal
1438            and then Is_Integer_Type (Typ)
1439          then
1440             Rewrite (N,
1441               Make_Integer_Literal (Sloc (N),
1442                 Intval => UR_To_Uint (Realval (N))));
1443             Set_Etype (N, Universal_Integer);
1444             Set_Is_Static_Expression (N);
1445          elsif Nkind (N) = N_String_Literal
1446            and then Is_Character_Type (Typ)
1447          then
1448             Set_Character_Literal_Name (Char_Code (Character'Pos ('A')));
1449             Rewrite (N,
1450               Make_Character_Literal (Sloc (N),
1451                 Chars => Name_Find,
1452                 Char_Literal_Value => Char_Code (Character'Pos ('A'))));
1453             Set_Etype (N, Any_Character);
1454             Set_Is_Static_Expression (N);
1455
1456          elsif Nkind (N) /= N_String_Literal
1457            and then Is_String_Type (Typ)
1458          then
1459             Rewrite (N,
1460               Make_String_Literal (Sloc (N),
1461                 Strval => End_String));
1462
1463          elsif Nkind (N) = N_Range then
1464             Patch_Up_Value (Low_Bound (N), Typ);
1465             Patch_Up_Value (High_Bound (N), Typ);
1466          end if;
1467       end Patch_Up_Value;
1468
1469       -----------------------
1470       -- Resolution_Failed --
1471       -----------------------
1472
1473       procedure Resolution_Failed is
1474       begin
1475          Patch_Up_Value (N, Typ);
1476          Set_Etype (N, Typ);
1477          Debug_A_Exit ("resolving  ", N, " (done, resolution failed)");
1478          Set_Is_Overloaded (N, False);
1479
1480          --  The caller will return without calling the expander, so we need
1481          --  to set the analyzed flag. Note that it is fine to set Analyzed
1482          --  to True even if we are in the middle of a shallow analysis,
1483          --  (see the spec of sem for more details) since this is an error
1484          --  situation anyway, and there is no point in repeating the
1485          --  analysis later (indeed it won't work to repeat it later, since
1486          --  we haven't got a clear resolution of which entity is being
1487          --  referenced.)
1488
1489          Set_Analyzed (N, True);
1490          return;
1491       end Resolution_Failed;
1492
1493    --  Start of processing for Resolve
1494
1495    begin
1496       if N = Error then
1497          return;
1498       end if;
1499
1500       --  Access attribute on remote subprogram cannot be used for
1501       --  a non-remote access-to-subprogram type.
1502
1503       if Nkind (N) = N_Attribute_Reference
1504         and then (Attribute_Name (N) = Name_Access
1505           or else Attribute_Name (N) = Name_Unrestricted_Access
1506           or else Attribute_Name (N) = Name_Unchecked_Access)
1507         and then Comes_From_Source (N)
1508         and then Is_Entity_Name (Prefix (N))
1509         and then Is_Subprogram (Entity (Prefix (N)))
1510         and then Is_Remote_Call_Interface (Entity (Prefix (N)))
1511         and then not Is_Remote_Access_To_Subprogram_Type (Typ)
1512       then
1513          Error_Msg_N
1514            ("prefix must statically denote a non-remote subprogram", N);
1515       end if;
1516
1517       --  If the context is a Remote_Access_To_Subprogram, access attributes
1518       --  must be resolved with the corresponding fat pointer. There is no need
1519       --  to check for the attribute name since the return type of an
1520       --  attribute is never a remote type.
1521
1522       if Nkind (N) = N_Attribute_Reference
1523         and then Comes_From_Source (N)
1524         and then (Is_Remote_Call_Interface (Typ)
1525                     or else Is_Remote_Types (Typ))
1526       then
1527          declare
1528             Attr      : constant Attribute_Id :=
1529                           Get_Attribute_Id (Attribute_Name (N));
1530             Pref      : constant Node_Id      := Prefix (N);
1531             Decl      : Node_Id;
1532             Spec      : Node_Id;
1533             Is_Remote : Boolean := True;
1534
1535          begin
1536             --  Check that Typ is a fat pointer with a reference to a RAS as
1537             --  original access type.
1538
1539             if
1540               (Ekind (Typ) = E_Access_Subprogram_Type
1541                  and then Present (Equivalent_Type (Typ)))
1542               or else
1543                 (Ekind (Typ) = E_Record_Type
1544                    and then Present (Corresponding_Remote_Type (Typ)))
1545
1546             then
1547                --  Prefix (N) must statically denote a remote subprogram
1548                --  declared in a package specification.
1549
1550                if Attr = Attribute_Access then
1551                   Decl := Unit_Declaration_Node (Entity (Pref));
1552
1553                   if Nkind (Decl) = N_Subprogram_Body then
1554                      Spec := Corresponding_Spec (Decl);
1555
1556                      if not No (Spec) then
1557                         Decl := Unit_Declaration_Node (Spec);
1558                      end if;
1559                   end if;
1560
1561                   Spec := Parent (Decl);
1562
1563                   if not Is_Entity_Name (Prefix (N))
1564                     or else Nkind (Spec) /= N_Package_Specification
1565                     or else
1566                       not Is_Remote_Call_Interface (Defining_Entity (Spec))
1567                   then
1568                      Is_Remote := False;
1569                      Error_Msg_N
1570                        ("prefix must statically denote a remote subprogram ",
1571                         N);
1572                   end if;
1573                end if;
1574
1575                --   If we are generating code for a distributed program.
1576                --   perform semantic checks against the corresponding
1577                --   remote entities.
1578
1579                if (Attr = Attribute_Access
1580                     or else Attr = Attribute_Unchecked_Access
1581                     or else Attr = Attribute_Unrestricted_Access)
1582                  and then Expander_Active
1583                then
1584                   Check_Subtype_Conformant
1585                     (New_Id  => Entity (Prefix (N)),
1586                      Old_Id  => Designated_Type
1587                        (Corresponding_Remote_Type (Typ)),
1588                      Err_Loc => N);
1589                   if Is_Remote then
1590                      Process_Remote_AST_Attribute (N, Typ);
1591                   end if;
1592                end if;
1593             end if;
1594          end;
1595       end if;
1596
1597       Debug_A_Entry ("resolving  ", N);
1598
1599       if Comes_From_Source (N) then
1600          if Is_Fixed_Point_Type (Typ) then
1601             Check_Restriction (No_Fixed_Point, N);
1602
1603          elsif Is_Floating_Point_Type (Typ)
1604            and then Typ /= Universal_Real
1605            and then Typ /= Any_Real
1606          then
1607             Check_Restriction (No_Floating_Point, N);
1608          end if;
1609       end if;
1610
1611       --  Return if already analyzed
1612
1613       if Analyzed (N) then
1614          Debug_A_Exit ("resolving  ", N, "  (done, already analyzed)");
1615          return;
1616
1617       --  Return if type = Any_Type (previous error encountered)
1618
1619       elsif Etype (N) = Any_Type then
1620          Debug_A_Exit ("resolving  ", N, "  (done, Etype = Any_Type)");
1621          return;
1622       end if;
1623
1624       Check_Parameterless_Call (N);
1625
1626       --  If not overloaded, then we know the type, and all that needs doing
1627       --  is to check that this type is compatible with the context.
1628
1629       if not Is_Overloaded (N) then
1630          Found := Covers (Typ, Etype (N));
1631          Expr_Type := Etype (N);
1632
1633       --  In the overloaded case, we must select the interpretation that
1634       --  is compatible with the context (i.e. the type passed to Resolve)
1635
1636       else
1637          Get_First_Interp (N, I, It);
1638
1639          --  Loop through possible interpretations
1640
1641          Interp_Loop : while Present (It.Typ) loop
1642
1643             --  We are only interested in interpretations that are compatible
1644             --  with the expected type, any other interpretations are ignored
1645
1646             if not Covers (Typ, It.Typ) then
1647                if Debug_Flag_V then
1648                   Write_Str ("    interpretation incompatible with context");
1649                   Write_Eol;
1650                end if;
1651
1652             else
1653                --  First matching interpretation
1654
1655                if not Found then
1656                   Found := True;
1657                   I1    := I;
1658                   Seen  := It.Nam;
1659                   Expr_Type := It.Typ;
1660
1661                --  Matching interpretation that is not the first, maybe an
1662                --  error, but there are some cases where preference rules are
1663                --  used to choose between the two possibilities. These and
1664                --  some more obscure cases are handled in Disambiguate.
1665
1666                else
1667                   Error_Msg_Sloc := Sloc (Seen);
1668                   It1 := Disambiguate (N, I1, I, Typ);
1669
1670                   --  Disambiguation has succeeded. Skip the remaining
1671                   --  interpretations.
1672
1673                   if It1 /= No_Interp then
1674                      Seen := It1.Nam;
1675                      Expr_Type := It1.Typ;
1676
1677                      while Present (It.Typ) loop
1678                         Get_Next_Interp (I, It);
1679                      end loop;
1680
1681                   else
1682                      --  Before we issue an ambiguity complaint, check for
1683                      --  the case of a subprogram call where at least one
1684                      --  of the arguments is Any_Type, and if so, suppress
1685                      --  the message, since it is a cascaded error.
1686
1687                      if Nkind (N) = N_Function_Call
1688                        or else Nkind (N) = N_Procedure_Call_Statement
1689                      then
1690                         declare
1691                            A : Node_Id := First_Actual (N);
1692                            E : Node_Id;
1693
1694                         begin
1695                            while Present (A) loop
1696                               E := A;
1697
1698                               if Nkind (E) = N_Parameter_Association then
1699                                  E := Explicit_Actual_Parameter (E);
1700                               end if;
1701
1702                               if Etype (E) = Any_Type then
1703                                  if Debug_Flag_V then
1704                                     Write_Str ("Any_Type in call");
1705                                     Write_Eol;
1706                                  end if;
1707
1708                                  exit Interp_Loop;
1709                               end if;
1710
1711                               Next_Actual (A);
1712                            end loop;
1713                         end;
1714
1715                      elsif Nkind (N) in  N_Binary_Op
1716                        and then (Etype (Left_Opnd (N)) = Any_Type
1717                                   or else Etype (Right_Opnd (N)) = Any_Type)
1718                      then
1719                         exit Interp_Loop;
1720
1721                      elsif Nkind (N) in  N_Unary_Op
1722                        and then Etype (Right_Opnd (N)) = Any_Type
1723                      then
1724                         exit Interp_Loop;
1725                      end if;
1726
1727                      --  Not that special case, so issue message using the
1728                      --  flag Ambiguous to control printing of the header
1729                      --  message only at the start of an ambiguous set.
1730
1731                      if not Ambiguous then
1732                         Error_Msg_NE
1733                           ("ambiguous expression (cannot resolve&)!",
1734                            N, It.Nam);
1735
1736                         Error_Msg_N
1737                           ("possible interpretation#!", N);
1738                         Ambiguous := True;
1739                      end if;
1740
1741                      Error_Msg_Sloc := Sloc (It.Nam);
1742
1743                      --  By default, the error message refers to the candidate
1744                      --  interpretation. But if it is a  predefined operator,
1745                      --  it is implicitly declared at the declaration of
1746                      --  the type of the operand. Recover the sloc of that
1747                      --  declaration for the error message.
1748
1749                      if Nkind (N) in N_Op
1750                        and then Scope (It.Nam) = Standard_Standard
1751                        and then not Is_Overloaded (Right_Opnd (N))
1752                        and then  Scope (Base_Type (Etype (Right_Opnd (N))))
1753                             /= Standard_Standard
1754                      then
1755                         Err_Type := First_Subtype (Etype (Right_Opnd (N)));
1756
1757                         if Comes_From_Source (Err_Type)
1758                           and then Present (Parent (Err_Type))
1759                         then
1760                            Error_Msg_Sloc := Sloc (Parent (Err_Type));
1761                         end if;
1762
1763                      elsif Nkind (N) in N_Binary_Op
1764                        and then Scope (It.Nam) = Standard_Standard
1765                        and then not Is_Overloaded (Left_Opnd (N))
1766                        and then  Scope (Base_Type (Etype (Left_Opnd (N))))
1767                             /= Standard_Standard
1768                      then
1769                         Err_Type := First_Subtype (Etype (Left_Opnd (N)));
1770
1771                         if Comes_From_Source (Err_Type)
1772                           and then Present (Parent (Err_Type))
1773                         then
1774                            Error_Msg_Sloc := Sloc (Parent (Err_Type));
1775                         end if;
1776                      else
1777                         Err_Type := Empty;
1778                      end if;
1779
1780                      if Nkind (N) in N_Op
1781                        and then Scope (It.Nam) = Standard_Standard
1782                        and then Present (Err_Type)
1783                      then
1784                         Error_Msg_N
1785                           ("possible interpretation (predefined)#!", N);
1786                      else
1787                         Error_Msg_N ("possible interpretation#!", N);
1788                      end if;
1789
1790                   end if;
1791                end if;
1792
1793                --  We have a matching interpretation, Expr_Type is the
1794                --  type from this interpretation, and Seen is the entity.
1795
1796                --  For an operator, just set the entity name. The type will
1797                --  be set by the specific operator resolution routine.
1798
1799                if Nkind (N) in N_Op then
1800                   Set_Entity (N, Seen);
1801                   Generate_Reference (Seen, N);
1802
1803                elsif Nkind (N) = N_Character_Literal then
1804                   Set_Etype (N, Expr_Type);
1805
1806                --  For an explicit dereference, attribute reference, range,
1807                --  short-circuit form (which is not an operator node),
1808                --  or a call with a name that is an explicit dereference,
1809                --  there is nothing to be done at this point.
1810
1811                elsif     Nkind (N) = N_Explicit_Dereference
1812                  or else Nkind (N) = N_Attribute_Reference
1813                  or else Nkind (N) = N_And_Then
1814                  or else Nkind (N) = N_Indexed_Component
1815                  or else Nkind (N) = N_Or_Else
1816                  or else Nkind (N) = N_Range
1817                  or else Nkind (N) = N_Selected_Component
1818                  or else Nkind (N) = N_Slice
1819                  or else Nkind (Name (N)) = N_Explicit_Dereference
1820                then
1821                   null;
1822
1823                --  For procedure or function calls, set the type of the
1824                --  name, and also the entity pointer for the prefix
1825
1826                elsif (Nkind (N) = N_Procedure_Call_Statement
1827                        or else Nkind (N) = N_Function_Call)
1828                  and then (Is_Entity_Name (Name (N))
1829                             or else Nkind (Name (N)) = N_Operator_Symbol)
1830                then
1831                   Set_Etype  (Name (N), Expr_Type);
1832                   Set_Entity (Name (N), Seen);
1833                   Generate_Reference (Seen, Name (N));
1834
1835                elsif Nkind (N) = N_Function_Call
1836                  and then Nkind (Name (N)) = N_Selected_Component
1837                then
1838                   Set_Etype (Name (N), Expr_Type);
1839                   Set_Entity (Selector_Name (Name (N)), Seen);
1840                   Generate_Reference (Seen, Selector_Name (Name (N)));
1841
1842                --  For all other cases, just set the type of the Name
1843
1844                else
1845                   Set_Etype (Name (N), Expr_Type);
1846                end if;
1847
1848             end if;
1849
1850             --  Move to next interpretation
1851
1852             exit Interp_Loop when not Present (It.Typ);
1853
1854             Get_Next_Interp (I, It);
1855          end loop Interp_Loop;
1856       end if;
1857
1858       --  At this stage Found indicates whether or not an acceptable
1859       --  interpretation exists. If not, then we have an error, except
1860       --  that if the context is Any_Type as a result of some other error,
1861       --  then we suppress the error report.
1862
1863       if not Found then
1864          if Typ /= Any_Type then
1865
1866             --  If type we are looking for is Void, then this is the
1867             --  procedure call case, and the error is simply that what
1868             --  we gave is not a procedure name (we think of procedure
1869             --  calls as expressions with types internally, but the user
1870             --  doesn't think of them this way!)
1871
1872             if Typ = Standard_Void_Type then
1873
1874                --  Special case message if function used as a procedure
1875
1876                if Nkind (N) = N_Procedure_Call_Statement
1877                  and then Is_Entity_Name (Name (N))
1878                  and then Ekind (Entity (Name (N))) = E_Function
1879                then
1880                   Error_Msg_NE
1881                     ("cannot use function & in a procedure call",
1882                      Name (N), Entity (Name (N)));
1883
1884                --  Otherwise give general message (not clear what cases
1885                --  this covers, but no harm in providing for them!)
1886
1887                else
1888                   Error_Msg_N ("expect procedure name in procedure call", N);
1889                end if;
1890
1891                Found := True;
1892
1893             --  Otherwise we do have a subexpression with the wrong type
1894
1895             --  Check for the case of an allocator which uses an access
1896             --  type instead of the designated type. This is a common
1897             --  error and we specialize the message, posting an error
1898             --  on the operand of the allocator, complaining that we
1899             --  expected the designated type of the allocator.
1900
1901             elsif Nkind (N) = N_Allocator
1902               and then Ekind (Typ) in Access_Kind
1903               and then Ekind (Etype (N)) in Access_Kind
1904               and then Designated_Type (Etype (N)) = Typ
1905             then
1906                Wrong_Type (Expression (N), Designated_Type (Typ));
1907                Found := True;
1908
1909             --  Check for view mismatch on Null in instances, for
1910             --  which the view-swapping mechanism has no identifier.
1911
1912             elsif (In_Instance or else In_Inlined_Body)
1913               and then (Nkind (N) = N_Null)
1914               and then Is_Private_Type (Typ)
1915               and then Is_Access_Type (Full_View (Typ))
1916             then
1917                Resolve (N, Full_View (Typ));
1918                Set_Etype (N, Typ);
1919                return;
1920
1921             --  Check for an aggregate. Sometimes we can get bogus
1922             --  aggregates from misuse of parentheses, and we are
1923             --  about to complain about the aggregate without even
1924             --  looking inside it.
1925
1926             --  Instead, if we have an aggregate of type Any_Composite,
1927             --  then analyze and resolve the component fields, and then
1928             --  only issue another message if we get no errors doing
1929             --  this (otherwise assume that the errors in the aggregate
1930             --  caused the problem).
1931
1932             elsif Nkind (N) = N_Aggregate
1933               and then Etype (N) = Any_Composite
1934             then
1935                --  Disable expansion in any case. If there is a type mismatch
1936                --  it may be fatal to try to expand the aggregate. The flag
1937                --  would otherwise be set to false when the error is posted.
1938
1939                Expander_Active := False;
1940
1941                declare
1942                   procedure Check_Aggr (Aggr : Node_Id);
1943                   --  Check one aggregate, and set Found to True if we
1944                   --  have a definite error in any of its elements
1945
1946                   procedure Check_Elmt (Aelmt : Node_Id);
1947                   --  Check one element of aggregate and set Found to
1948                   --  True if we definitely have an error in the element.
1949
1950                   procedure Check_Aggr (Aggr : Node_Id) is
1951                      Elmt : Node_Id;
1952
1953                   begin
1954                      if Present (Expressions (Aggr)) then
1955                         Elmt := First (Expressions (Aggr));
1956                         while Present (Elmt) loop
1957                            Check_Elmt (Elmt);
1958                            Next (Elmt);
1959                         end loop;
1960                      end if;
1961
1962                      if Present (Component_Associations (Aggr)) then
1963                         Elmt := First (Component_Associations (Aggr));
1964                         while Present (Elmt) loop
1965                            Check_Elmt (Expression (Elmt));
1966                            Next (Elmt);
1967                         end loop;
1968                      end if;
1969                   end Check_Aggr;
1970
1971                   ----------------
1972                   -- Check_Elmt --
1973                   ----------------
1974
1975                   procedure Check_Elmt (Aelmt : Node_Id) is
1976                   begin
1977                      --  If we have a nested aggregate, go inside it (to
1978                      --  attempt a naked analyze-resolve of the aggregate
1979                      --  can cause undesirable cascaded errors). Do not
1980                      --  resolve expression if it needs a type from context,
1981                      --  as for integer * fixed expression.
1982
1983                      if Nkind (Aelmt) = N_Aggregate then
1984                         Check_Aggr (Aelmt);
1985
1986                      else
1987                         Analyze (Aelmt);
1988
1989                         if not Is_Overloaded (Aelmt)
1990                           and then Etype (Aelmt) /= Any_Fixed
1991                         then
1992                            Resolve (Aelmt);
1993                         end if;
1994
1995                         if Etype (Aelmt) = Any_Type then
1996                            Found := True;
1997                         end if;
1998                      end if;
1999                   end Check_Elmt;
2000
2001                begin
2002                   Check_Aggr (N);
2003                end;
2004             end if;
2005
2006             --  If an error message was issued already, Found got reset
2007             --  to True, so if it is still False, issue the standard
2008             --  Wrong_Type message.
2009
2010             if not Found then
2011                if Is_Overloaded (N)
2012                  and then Nkind (N) = N_Function_Call
2013                then
2014                   declare
2015                      Subp_Name : Node_Id;
2016                   begin
2017                      if Is_Entity_Name (Name (N)) then
2018                         Subp_Name := Name (N);
2019
2020                      elsif Nkind (Name (N)) = N_Selected_Component then
2021
2022                         --  Protected operation: retrieve operation name.
2023
2024                         Subp_Name := Selector_Name (Name (N));
2025                      else
2026                         raise Program_Error;
2027                      end if;
2028
2029                      Error_Msg_Node_2 := Typ;
2030                      Error_Msg_NE ("no visible interpretation of&" &
2031                        " matches expected type&", N, Subp_Name);
2032                   end;
2033
2034                   if All_Errors_Mode then
2035                      declare
2036                         Index : Interp_Index;
2037                         It    : Interp;
2038
2039                      begin
2040                         Error_Msg_N ("\possible interpretations:", N);
2041                         Get_First_Interp (Name (N), Index, It);
2042
2043                         while Present (It.Nam) loop
2044
2045                               Error_Msg_Sloc := Sloc (It.Nam);
2046                               Error_Msg_Node_2 := It.Typ;
2047                               Error_Msg_NE ("\&  declared#, type&",
2048                                 N, It.Nam);
2049
2050                            Get_Next_Interp (Index, It);
2051                         end loop;
2052                      end;
2053                   else
2054                      Error_Msg_N ("\use -gnatf for details", N);
2055                   end if;
2056                else
2057                   Wrong_Type (N, Typ);
2058                end if;
2059             end if;
2060          end if;
2061
2062          Resolution_Failed;
2063          return;
2064
2065       --  Test if we have more than one interpretation for the context
2066
2067       elsif Ambiguous then
2068          Resolution_Failed;
2069          return;
2070
2071       --  Here we have an acceptable interpretation for the context
2072
2073       else
2074          --  Propagate type information and normalize tree for various
2075          --  predefined operations. If the context only imposes a class of
2076          --  types, rather than a specific type, propagate the actual type
2077          --  downward.
2078
2079          if Typ = Any_Integer
2080            or else Typ = Any_Boolean
2081            or else Typ = Any_Modular
2082            or else Typ = Any_Real
2083            or else Typ = Any_Discrete
2084          then
2085             Ctx_Type := Expr_Type;
2086
2087             --  Any_Fixed is legal in a real context only if a specific
2088             --  fixed point type is imposed. If Norman Cohen can be
2089             --  confused by this, it deserves a separate message.
2090
2091             if Typ = Any_Real
2092               and then Expr_Type = Any_Fixed
2093             then
2094                Error_Msg_N ("Illegal context for mixed mode operation", N);
2095                Set_Etype (N, Universal_Real);
2096                Ctx_Type := Universal_Real;
2097             end if;
2098          end if;
2099
2100          --  A user-defined operator is tranformed into a function call at
2101          --  this point, so that further processing knows that operators are
2102          --  really operators (i.e. are predefined operators). User-defined
2103          --  operators that are intrinsic are just renamings of the predefined
2104          --  ones, and need not be turned into calls either, but if they rename
2105          --  a different operator, we must transform the node accordingly.
2106          --  Instantiations of Unchecked_Conversion are intrinsic but are
2107          --  treated as functions, even if given an operator designator.
2108
2109          if Nkind (N) in N_Op
2110            and then Present (Entity (N))
2111            and then Ekind (Entity (N)) /= E_Operator
2112          then
2113
2114             if not Is_Predefined_Op (Entity (N)) then
2115                Rewrite_Operator_As_Call (N, Entity (N));
2116
2117             elsif Present (Alias (Entity (N)))
2118               and then
2119                 Nkind (Parent (Parent (Entity (N))))
2120                   = N_Subprogram_Renaming_Declaration
2121             then
2122                Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
2123
2124                --  If the node is rewritten, it will be fully resolved in
2125                --  Rewrite_Renamed_Operator.
2126
2127                if Analyzed (N) then
2128                   return;
2129                end if;
2130             end if;
2131          end if;
2132
2133          case N_Subexpr'(Nkind (N)) is
2134
2135             when N_Aggregate => Resolve_Aggregate                (N, Ctx_Type);
2136
2137             when N_Allocator => Resolve_Allocator                (N, Ctx_Type);
2138
2139             when N_And_Then | N_Or_Else
2140                              => Resolve_Short_Circuit            (N, Ctx_Type);
2141
2142             when N_Attribute_Reference
2143                              => Resolve_Attribute                (N, Ctx_Type);
2144
2145             when N_Character_Literal
2146                              => Resolve_Character_Literal        (N, Ctx_Type);
2147
2148             when N_Conditional_Expression
2149                              => Resolve_Conditional_Expression   (N, Ctx_Type);
2150
2151             when N_Expanded_Name
2152                              => Resolve_Entity_Name              (N, Ctx_Type);
2153
2154             when N_Extension_Aggregate
2155                              => Resolve_Extension_Aggregate      (N, Ctx_Type);
2156
2157             when N_Explicit_Dereference
2158                              => Resolve_Explicit_Dereference     (N, Ctx_Type);
2159
2160             when N_Function_Call
2161                              => Resolve_Call                     (N, Ctx_Type);
2162
2163             when N_Identifier
2164                              => Resolve_Entity_Name              (N, Ctx_Type);
2165
2166             when N_In | N_Not_In
2167                              => Resolve_Membership_Op            (N, Ctx_Type);
2168
2169             when N_Indexed_Component
2170                              => Resolve_Indexed_Component        (N, Ctx_Type);
2171
2172             when N_Integer_Literal
2173                              => Resolve_Integer_Literal          (N, Ctx_Type);
2174
2175             when N_Null      => Resolve_Null                     (N, Ctx_Type);
2176
2177             when N_Op_And | N_Op_Or | N_Op_Xor
2178                              => Resolve_Logical_Op               (N, Ctx_Type);
2179
2180             when N_Op_Eq | N_Op_Ne
2181                              => Resolve_Equality_Op              (N, Ctx_Type);
2182
2183             when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
2184                              => Resolve_Comparison_Op            (N, Ctx_Type);
2185
2186             when N_Op_Not    => Resolve_Op_Not                   (N, Ctx_Type);
2187
2188             when N_Op_Add    | N_Op_Subtract | N_Op_Multiply |
2189                  N_Op_Divide | N_Op_Mod      | N_Op_Rem
2190
2191                              => Resolve_Arithmetic_Op            (N, Ctx_Type);
2192
2193             when N_Op_Concat => Resolve_Op_Concat                (N, Ctx_Type);
2194
2195             when N_Op_Expon  => Resolve_Op_Expon                 (N, Ctx_Type);
2196
2197             when N_Op_Plus | N_Op_Minus  | N_Op_Abs
2198                              => Resolve_Unary_Op                 (N, Ctx_Type);
2199
2200             when N_Op_Shift  => Resolve_Shift                    (N, Ctx_Type);
2201
2202             when N_Procedure_Call_Statement
2203                              => Resolve_Call                     (N, Ctx_Type);
2204
2205             when N_Operator_Symbol
2206                              => Resolve_Operator_Symbol          (N, Ctx_Type);
2207
2208             when N_Qualified_Expression
2209                              => Resolve_Qualified_Expression     (N, Ctx_Type);
2210
2211             when N_Raise_xxx_Error
2212                              => Set_Etype (N, Ctx_Type);
2213
2214             when N_Range     => Resolve_Range                    (N, Ctx_Type);
2215
2216             when N_Real_Literal
2217                              => Resolve_Real_Literal             (N, Ctx_Type);
2218
2219             when N_Reference => Resolve_Reference                (N, Ctx_Type);
2220
2221             when N_Selected_Component
2222                              => Resolve_Selected_Component       (N, Ctx_Type);
2223
2224             when N_Slice     => Resolve_Slice                    (N, Ctx_Type);
2225
2226             when N_String_Literal
2227                              => Resolve_String_Literal           (N, Ctx_Type);
2228
2229             when N_Subprogram_Info
2230                              => Resolve_Subprogram_Info          (N, Ctx_Type);
2231
2232             when N_Type_Conversion
2233                              => Resolve_Type_Conversion          (N, Ctx_Type);
2234
2235             when N_Unchecked_Expression =>
2236                Resolve_Unchecked_Expression                      (N, Ctx_Type);
2237
2238             when N_Unchecked_Type_Conversion =>
2239                Resolve_Unchecked_Type_Conversion                 (N, Ctx_Type);
2240
2241          end case;
2242
2243          --  If the subexpression was replaced by a non-subexpression, then
2244          --  all we do is to expand it. The only legitimate case we know of
2245          --  is converting procedure call statement to entry call statements,
2246          --  but there may be others, so we are making this test general.
2247
2248          if Nkind (N) not in N_Subexpr then
2249             Debug_A_Exit ("resolving  ", N, "  (done)");
2250             Expand (N);
2251             return;
2252          end if;
2253
2254          --  The expression is definitely NOT overloaded at this point, so
2255          --  we reset the Is_Overloaded flag to avoid any confusion when
2256          --  reanalyzing the node.
2257
2258          Set_Is_Overloaded (N, False);
2259
2260          --  Freeze expression type, entity if it is a name, and designated
2261          --  type if it is an allocator (RM 13.14(10,11,13)).
2262
2263          --  Now that the resolution of the type of the node is complete,
2264          --  and we did not detect an error, we can expand this node. We
2265          --  skip the expand call if we are in a default expression, see
2266          --  section "Handling of Default Expressions" in Sem spec.
2267
2268          Debug_A_Exit ("resolving  ", N, "  (done)");
2269
2270          --  We unconditionally freeze the expression, even if we are in
2271          --  default expression mode (the Freeze_Expression routine tests
2272          --  this flag and only freezes static types if it is set).
2273
2274          Freeze_Expression (N);
2275
2276          --  Now we can do the expansion
2277
2278          Expand (N);
2279       end if;
2280    end Resolve;
2281
2282    -------------
2283    -- Resolve --
2284    -------------
2285
2286    --  Version with check(s) suppressed
2287
2288    procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
2289    begin
2290       if Suppress = All_Checks then
2291          declare
2292             Svg : constant Suppress_Array := Scope_Suppress;
2293
2294          begin
2295             Scope_Suppress := (others => True);
2296             Resolve (N, Typ);
2297             Scope_Suppress := Svg;
2298          end;
2299
2300       else
2301          declare
2302             Svg : constant Boolean := Scope_Suppress (Suppress);
2303
2304          begin
2305             Scope_Suppress (Suppress) := True;
2306             Resolve (N, Typ);
2307             Scope_Suppress (Suppress) := Svg;
2308          end;
2309       end if;
2310    end Resolve;
2311
2312    -------------
2313    -- Resolve --
2314    -------------
2315
2316    --  Version with implicit type
2317
2318    procedure Resolve (N : Node_Id) is
2319    begin
2320       Resolve (N, Etype (N));
2321    end Resolve;
2322
2323    ---------------------
2324    -- Resolve_Actuals --
2325    ---------------------
2326
2327    procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
2328       Loc    : constant Source_Ptr := Sloc (N);
2329       A      : Node_Id;
2330       F      : Entity_Id;
2331       A_Typ  : Entity_Id;
2332       F_Typ  : Entity_Id;
2333       Prev   : Node_Id := Empty;
2334
2335       procedure Insert_Default;
2336       --  If the actual is missing in a call, insert in the actuals list
2337       --  an instance of the default expression. The insertion is always
2338       --  a named association.
2339
2340       function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
2341       --  Check whether T1 and T2, or their full views, are derived from a
2342       --  common type. Used to enforce the restrictions on array conversions
2343       --  of AI95-00246.
2344
2345       --------------------
2346       -- Insert_Default --
2347       --------------------
2348
2349       procedure Insert_Default is
2350          Actval : Node_Id;
2351          Assoc  : Node_Id;
2352
2353       begin
2354          --  Missing argument in call, nothing to insert
2355
2356          if No (Default_Value (F)) then
2357             return;
2358
2359          else
2360             --  Note that we do a full New_Copy_Tree, so that any associated
2361             --  Itypes are properly copied. This may not be needed any more,
2362             --  but it does no harm as a safety measure! Defaults of a generic
2363             --  formal may be out of bounds of the corresponding actual (see
2364             --  cc1311b) and an additional check may be required.
2365
2366             Actval := New_Copy_Tree (Default_Value (F),
2367                         New_Scope => Current_Scope, New_Sloc => Loc);
2368
2369             if Is_Concurrent_Type (Scope (Nam))
2370               and then Has_Discriminants (Scope (Nam))
2371             then
2372                Replace_Actual_Discriminants (N, Actval);
2373             end if;
2374
2375             if Is_Overloadable (Nam)
2376               and then Present (Alias (Nam))
2377             then
2378                if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
2379                  and then not Is_Tagged_Type (Etype (F))
2380                then
2381                   --  If default is a real literal, do not introduce a
2382                   --  conversion whose effect may depend on the run-time
2383                   --  size of universal real.
2384
2385                   if Nkind (Actval) = N_Real_Literal then
2386                      Set_Etype (Actval, Base_Type (Etype (F)));
2387                   else
2388                      Actval := Unchecked_Convert_To (Etype (F), Actval);
2389                   end if;
2390                end if;
2391
2392                if Is_Scalar_Type (Etype (F)) then
2393                   Enable_Range_Check (Actval);
2394                end if;
2395
2396                Set_Parent (Actval, N);
2397
2398                --  Resolve aggregates with their base type, to avoid scope
2399                --  anomalies: the subtype was first built in the suprogram
2400                --  declaration, and the current call may be nested.
2401
2402                if Nkind (Actval) = N_Aggregate
2403                  and then Has_Discriminants (Etype (Actval))
2404                then
2405                   Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
2406                else
2407                   Analyze_And_Resolve (Actval, Etype (Actval));
2408                end if;
2409
2410             else
2411                Set_Parent (Actval, N);
2412
2413                --  See note above concerning aggregates.
2414
2415                if Nkind (Actval) = N_Aggregate
2416                  and then Has_Discriminants (Etype (Actval))
2417                then
2418                   Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
2419
2420                --  Resolve entities with their own type, which may differ
2421                --  from the type of a reference in a generic context (the
2422                --  view swapping mechanism did not anticipate the re-analysis
2423                --  of default values in calls).
2424
2425                elsif Is_Entity_Name (Actval) then
2426                   Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
2427
2428                else
2429                   Analyze_And_Resolve (Actval, Etype (Actval));
2430                end if;
2431             end if;
2432
2433             --  If default is a tag indeterminate function call, propagate
2434             --  tag to obtain proper dispatching.
2435
2436             if Is_Controlling_Formal (F)
2437               and then Nkind (Default_Value (F)) = N_Function_Call
2438             then
2439                Set_Is_Controlling_Actual (Actval);
2440             end if;
2441
2442          end if;
2443
2444          --  If the default expression raises constraint error, then just
2445          --  silently replace it with an N_Raise_Constraint_Error node,
2446          --  since we already gave the warning on the subprogram spec.
2447
2448          if Raises_Constraint_Error (Actval) then
2449             Rewrite (Actval,
2450               Make_Raise_Constraint_Error (Loc,
2451                 Reason => CE_Range_Check_Failed));
2452             Set_Raises_Constraint_Error (Actval);
2453             Set_Etype (Actval, Etype (F));
2454          end if;
2455
2456          Assoc :=
2457            Make_Parameter_Association (Loc,
2458              Explicit_Actual_Parameter => Actval,
2459              Selector_Name => Make_Identifier (Loc, Chars (F)));
2460
2461          --  Case of insertion is first named actual
2462
2463          if No (Prev) or else
2464             Nkind (Parent (Prev)) /= N_Parameter_Association
2465          then
2466             Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
2467             Set_First_Named_Actual (N, Actval);
2468
2469             if No (Prev) then
2470                if not Present (Parameter_Associations (N)) then
2471                   Set_Parameter_Associations (N, New_List (Assoc));
2472                else
2473                   Append (Assoc, Parameter_Associations (N));
2474                end if;
2475
2476             else
2477                Insert_After (Prev, Assoc);
2478             end if;
2479
2480          --  Case of insertion is not first named actual
2481
2482          else
2483             Set_Next_Named_Actual
2484               (Assoc, Next_Named_Actual (Parent (Prev)));
2485             Set_Next_Named_Actual (Parent (Prev), Actval);
2486             Append (Assoc, Parameter_Associations (N));
2487          end if;
2488
2489          Mark_Rewrite_Insertion (Assoc);
2490          Mark_Rewrite_Insertion (Actval);
2491
2492          Prev := Actval;
2493       end Insert_Default;
2494
2495       -------------------
2496       -- Same_Ancestor --
2497       -------------------
2498
2499       function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is
2500          FT1 : Entity_Id := T1;
2501          FT2 : Entity_Id := T2;
2502
2503       begin
2504          if Is_Private_Type (T1)
2505            and then Present (Full_View (T1))
2506          then
2507             FT1 := Full_View (T1);
2508          end if;
2509
2510          if Is_Private_Type (T2)
2511            and then Present (Full_View (T2))
2512          then
2513             FT2 := Full_View (T2);
2514          end if;
2515
2516          return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
2517       end Same_Ancestor;
2518
2519    --  Start of processing for Resolve_Actuals
2520
2521    begin
2522       A := First_Actual (N);
2523       F := First_Formal (Nam);
2524
2525       while Present (F) loop
2526          if No (A) and then Needs_No_Actuals (Nam) then
2527             null;
2528
2529          --  If we have an error in any actual or formal, indicated by
2530          --  a type of Any_Type, then abandon resolution attempt, and
2531          --  set result type to Any_Type.
2532
2533          elsif (Present (A) and then Etype (A) = Any_Type)
2534            or else Etype (F) = Any_Type
2535          then
2536             Set_Etype (N, Any_Type);
2537             return;
2538          end if;
2539
2540          if Present (A)
2541            and then (Nkind (Parent (A)) /= N_Parameter_Association
2542                        or else
2543                      Chars (Selector_Name (Parent (A))) = Chars (F))
2544          then
2545             --  If the formal is Out or In_Out, do not resolve and expand the
2546             --  conversion, because it is subsequently expanded into explicit
2547             --  temporaries and assignments. However, the object of the
2548             --  conversion can be resolved. An exception is the case of
2549             --  a tagged type conversion with a class-wide actual. In that
2550             --  case we want the tag check to occur and no temporary will
2551             --  will be needed (no representation change can occur) and
2552             --  the parameter is passed by reference, so we go ahead and
2553             --  resolve the type conversion.
2554
2555             if Ekind (F) /= E_In_Parameter
2556               and then Nkind (A) = N_Type_Conversion
2557               and then not Is_Class_Wide_Type (Etype (Expression (A)))
2558             then
2559                if Ekind (F) = E_In_Out_Parameter
2560                  and then Is_Array_Type (Etype (F))
2561                then
2562                   if Has_Aliased_Components (Etype (Expression (A)))
2563                     /= Has_Aliased_Components (Etype (F))
2564                   then
2565                      Error_Msg_N
2566                        ("both component types in a view conversion must be"
2567                          & " aliased, or neither", A);
2568
2569                   elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
2570                     and then
2571                      (Is_By_Reference_Type (Etype (F))
2572                         or else Is_By_Reference_Type (Etype (Expression (A))))
2573                   then
2574                      Error_Msg_N
2575                        ("view conversion between unrelated by_reference "
2576                          & "array types not allowed (\A\I-00246)?", A);
2577                   end if;
2578                end if;
2579
2580                if Conversion_OK (A)
2581                  or else Valid_Conversion (A, Etype (A), Expression (A))
2582                then
2583                   Resolve (Expression (A));
2584                end if;
2585
2586             else
2587                if Nkind (A) = N_Type_Conversion
2588                  and then Is_Array_Type (Etype (F))
2589                  and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
2590                  and then
2591                   (Is_Limited_Type (Etype (F))
2592                      or else Is_Limited_Type (Etype (Expression (A))))
2593                then
2594                   Error_Msg_N
2595                     ("Conversion between unrelated limited array types "
2596                         & "not allowed (\A\I-00246)?", A);
2597
2598                   --  Disable explanation (which produces additional errors)
2599                   --  until AI is approved and warning becomes an error.
2600
2601                   --  if Is_Limited_Type (Etype (F)) then
2602                   --     Explain_Limited_Type (Etype (F), A);
2603                   --  end if;
2604
2605                   --  if Is_Limited_Type (Etype (Expression (A))) then
2606                   --     Explain_Limited_Type (Etype (Expression (A)), A);
2607                   --  end if;
2608                end if;
2609
2610                Resolve (A, Etype (F));
2611             end if;
2612
2613             A_Typ := Etype (A);
2614             F_Typ := Etype (F);
2615
2616             --  Perform error checks for IN and IN OUT parameters
2617
2618             if Ekind (F) /= E_Out_Parameter then
2619
2620                --  Check unset reference. For scalar parameters, it is clearly
2621                --  wrong to pass an uninitialized value as either an IN or
2622                --  IN-OUT parameter. For composites, it is also clearly an
2623                --  error to pass a completely uninitialized value as an IN
2624                --  parameter, but the case of IN OUT is trickier. We prefer
2625                --  not to give a warning here. For example, suppose there is
2626                --  a routine that sets some component of a record to False.
2627                --  It is perfectly reasonable to make this IN-OUT and allow
2628                --  either initialized or uninitialized records to be passed
2629                --  in this case.
2630
2631                --  For partially initialized composite values, we also avoid
2632                --  warnings, since it is quite likely that we are passing a
2633                --  partially initialized value and only the initialized fields
2634                --  will in fact be read in the subprogram.
2635
2636                if Is_Scalar_Type (A_Typ)
2637                  or else (Ekind (F) = E_In_Parameter
2638                             and then not Is_Partially_Initialized_Type (A_Typ))
2639                then
2640                   Check_Unset_Reference (A);
2641                end if;
2642
2643                --  In Ada 83 we cannot pass an OUT parameter as an IN
2644                --  or IN OUT actual to a nested call, since this is a
2645                --  case of reading an out parameter, which is not allowed.
2646
2647                if Ada_Version = Ada_83
2648                  and then Is_Entity_Name (A)
2649                  and then Ekind (Entity (A)) = E_Out_Parameter
2650                then
2651                   Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
2652                end if;
2653             end if;
2654
2655             if Ekind (F) /= E_In_Parameter
2656               and then not Is_OK_Variable_For_Out_Formal (A)
2657             then
2658                Error_Msg_NE ("actual for& must be a variable", A, F);
2659
2660                if Is_Entity_Name (A) then
2661                   Kill_Checks (Entity (A));
2662                else
2663                   Kill_All_Checks;
2664                end if;
2665             end if;
2666
2667             if Etype (A) = Any_Type then
2668                Set_Etype (N, Any_Type);
2669                return;
2670             end if;
2671
2672             --  Apply appropriate range checks for in, out, and in-out
2673             --  parameters. Out and in-out parameters also need a separate
2674             --  check, if there is a type conversion, to make sure the return
2675             --  value meets the constraints of the variable before the
2676             --  conversion.
2677
2678             --  Gigi looks at the check flag and uses the appropriate types.
2679             --  For now since one flag is used there is an optimization which
2680             --  might not be done in the In Out case since Gigi does not do
2681             --  any analysis. More thought required about this ???
2682
2683             if Ekind (F) = E_In_Parameter
2684               or else Ekind (F) = E_In_Out_Parameter
2685             then
2686                if Is_Scalar_Type (Etype (A)) then
2687                   Apply_Scalar_Range_Check (A, F_Typ);
2688
2689                elsif Is_Array_Type (Etype (A)) then
2690                   Apply_Length_Check (A, F_Typ);
2691
2692                elsif Is_Record_Type (F_Typ)
2693                  and then Has_Discriminants (F_Typ)
2694                  and then Is_Constrained (F_Typ)
2695                  and then (not Is_Derived_Type (F_Typ)
2696                              or else Comes_From_Source (Nam))
2697                then
2698                   Apply_Discriminant_Check (A, F_Typ);
2699
2700                elsif Is_Access_Type (F_Typ)
2701                  and then Is_Array_Type (Designated_Type (F_Typ))
2702                  and then Is_Constrained (Designated_Type (F_Typ))
2703                then
2704                   Apply_Length_Check (A, F_Typ);
2705
2706                elsif Is_Access_Type (F_Typ)
2707                  and then Has_Discriminants (Designated_Type (F_Typ))
2708                  and then Is_Constrained (Designated_Type (F_Typ))
2709                then
2710                   Apply_Discriminant_Check (A, F_Typ);
2711
2712                else
2713                   Apply_Range_Check (A, F_Typ);
2714                end if;
2715
2716                --  Ada 2005 (AI-231)
2717
2718                if Ada_Version >= Ada_05
2719                  and then Is_Access_Type (F_Typ)
2720                  and then (Can_Never_Be_Null (F)
2721                            or else Can_Never_Be_Null (F_Typ))
2722                then
2723                   if Nkind (A) = N_Null then
2724                      Error_Msg_NE
2725                        ("(Ada 2005) not allowed for " &
2726                         "null-exclusion formal", A, F_Typ);
2727                   end if;
2728                end if;
2729             end if;
2730
2731             if Ekind (F) = E_Out_Parameter
2732               or else Ekind (F) = E_In_Out_Parameter
2733             then
2734                if Nkind (A) = N_Type_Conversion then
2735                   if Is_Scalar_Type (A_Typ) then
2736                      Apply_Scalar_Range_Check
2737                        (Expression (A), Etype (Expression (A)), A_Typ);
2738                   else
2739                      Apply_Range_Check
2740                        (Expression (A), Etype (Expression (A)), A_Typ);
2741                   end if;
2742
2743                else
2744                   if Is_Scalar_Type (F_Typ) then
2745                      Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
2746
2747                   elsif Is_Array_Type (F_Typ)
2748                     and then Ekind (F) = E_Out_Parameter
2749                   then
2750                      Apply_Length_Check (A, F_Typ);
2751
2752                   else
2753                      Apply_Range_Check (A, A_Typ, F_Typ);
2754                   end if;
2755                end if;
2756             end if;
2757
2758             --  An actual associated with an access parameter is implicitly
2759             --  converted to the anonymous access type of the formal and
2760             --  must satisfy the legality checks for access conversions.
2761
2762             if Ekind (F_Typ) = E_Anonymous_Access_Type then
2763                if not Valid_Conversion (A, F_Typ, A) then
2764                   Error_Msg_N
2765                     ("invalid implicit conversion for access parameter", A);
2766                end if;
2767             end if;
2768
2769             --  Check bad case of atomic/volatile argument (RM C.6(12))
2770
2771             if Is_By_Reference_Type (Etype (F))
2772               and then Comes_From_Source (N)
2773             then
2774                if Is_Atomic_Object (A)
2775                  and then not Is_Atomic (Etype (F))
2776                then
2777                   Error_Msg_N
2778                     ("cannot pass atomic argument to non-atomic formal",
2779                      N);
2780
2781                elsif Is_Volatile_Object (A)
2782                  and then not Is_Volatile (Etype (F))
2783                then
2784                   Error_Msg_N
2785                     ("cannot pass volatile argument to non-volatile formal",
2786                      N);
2787                end if;
2788             end if;
2789
2790             --  Check that subprograms don't have improper controlling
2791             --  arguments (RM 3.9.2 (9))
2792
2793             if Is_Controlling_Formal (F) then
2794                Set_Is_Controlling_Actual (A);
2795             elsif Nkind (A) = N_Explicit_Dereference then
2796                Validate_Remote_Access_To_Class_Wide_Type (A);
2797             end if;
2798
2799             if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
2800               and then not Is_Class_Wide_Type (F_Typ)
2801               and then not Is_Controlling_Formal (F)
2802             then
2803                Error_Msg_N ("class-wide argument not allowed here!", A);
2804
2805                if Is_Subprogram (Nam)
2806                  and then Comes_From_Source (Nam)
2807                then
2808                   Error_Msg_Node_2 := F_Typ;
2809                   Error_Msg_NE
2810                     ("& is not a primitive operation of &!", A, Nam);
2811                end if;
2812
2813             elsif Is_Access_Type (A_Typ)
2814               and then Is_Access_Type (F_Typ)
2815               and then Ekind (F_Typ) /= E_Access_Subprogram_Type
2816               and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
2817                          or else (Nkind (A) = N_Attribute_Reference
2818                                    and then
2819                                   Is_Class_Wide_Type (Etype (Prefix (A)))))
2820               and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
2821               and then not Is_Controlling_Formal (F)
2822             then
2823                Error_Msg_N
2824                  ("access to class-wide argument not allowed here!", A);
2825
2826                if Is_Subprogram (Nam)
2827                  and then Comes_From_Source (Nam)
2828                then
2829                   Error_Msg_Node_2 := Designated_Type (F_Typ);
2830                   Error_Msg_NE
2831                     ("& is not a primitive operation of &!", A, Nam);
2832                end if;
2833             end if;
2834
2835             Eval_Actual (A);
2836
2837             --  If it is a named association, treat the selector_name as
2838             --  a proper identifier, and mark the corresponding entity.
2839
2840             if Nkind (Parent (A)) = N_Parameter_Association then
2841                Set_Entity (Selector_Name (Parent (A)), F);
2842                Generate_Reference (F, Selector_Name (Parent (A)));
2843                Set_Etype (Selector_Name (Parent (A)), F_Typ);
2844                Generate_Reference (F_Typ, N, ' ');
2845             end if;
2846
2847             Prev := A;
2848
2849             if Ekind (F) /= E_Out_Parameter then
2850                Check_Unset_Reference (A);
2851             end if;
2852
2853             Next_Actual (A);
2854
2855          --  Case where actual is not present
2856
2857          else
2858             Insert_Default;
2859          end if;
2860
2861          Next_Formal (F);
2862       end loop;
2863    end Resolve_Actuals;
2864
2865    -----------------------
2866    -- Resolve_Allocator --
2867    -----------------------
2868
2869    procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
2870       E        : constant Node_Id := Expression (N);
2871       Subtyp   : Entity_Id;
2872       Discrim  : Entity_Id;
2873       Constr   : Node_Id;
2874       Disc_Exp : Node_Id;
2875
2876       function In_Dispatching_Context return Boolean;
2877       --  If the allocator is an actual in a call, it is allowed to be
2878       --  class-wide when the context is not because it is a controlling
2879       --  actual.
2880
2881       ----------------------------
2882       -- In_Dispatching_Context --
2883       ----------------------------
2884
2885       function In_Dispatching_Context return Boolean is
2886          Par : constant Node_Id := Parent (N);
2887
2888       begin
2889          return (Nkind (Par) = N_Function_Call
2890                    or else Nkind (Par) = N_Procedure_Call_Statement)
2891            and then Is_Entity_Name (Name (Par))
2892            and then Is_Dispatching_Operation (Entity (Name (Par)));
2893       end In_Dispatching_Context;
2894
2895    --  Start of processing for Resolve_Allocator
2896
2897    begin
2898       --  Replace general access with specific type
2899
2900       if Ekind (Etype (N)) = E_Allocator_Type then
2901          Set_Etype (N, Base_Type (Typ));
2902       end if;
2903
2904       if Is_Abstract (Typ) then
2905          Error_Msg_N ("type of allocator cannot be abstract",  N);
2906       end if;
2907
2908       --  For qualified expression, resolve the expression using the
2909       --  given subtype (nothing to do for type mark, subtype indication)
2910
2911       if Nkind (E) = N_Qualified_Expression then
2912          if Is_Class_Wide_Type (Etype (E))
2913            and then not Is_Class_Wide_Type (Designated_Type (Typ))
2914            and then not In_Dispatching_Context
2915          then
2916             Error_Msg_N
2917               ("class-wide allocator not allowed for this access type", N);
2918          end if;
2919
2920          Resolve (Expression (E), Etype (E));
2921          Check_Unset_Reference (Expression (E));
2922
2923          --  A qualified expression requires an exact match of the type,
2924          --  class-wide matching is not allowed.
2925
2926          if (Is_Class_Wide_Type (Etype (Expression (E)))
2927               or else Is_Class_Wide_Type (Etype (E)))
2928            and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
2929          then
2930             Wrong_Type (Expression (E), Etype (E));
2931          end if;
2932
2933       --  For a subtype mark or subtype indication, freeze the subtype
2934
2935       else
2936          Freeze_Expression (E);
2937
2938          if Is_Access_Constant (Typ) and then not No_Initialization (N) then
2939             Error_Msg_N
2940               ("initialization required for access-to-constant allocator", N);
2941          end if;
2942
2943          --  A special accessibility check is needed for allocators that
2944          --  constrain access discriminants. The level of the type of the
2945          --  expression used to contrain an access discriminant cannot be
2946          --  deeper than the type of the allocator (in constrast to access
2947          --  parameters, where the level of the actual can be arbitrary).
2948          --  We can't use Valid_Conversion to perform this check because
2949          --  in general the type of the allocator is unrelated to the type
2950          --  of the access discriminant. Note that specialized checks are
2951          --  needed for the cases of a constraint expression which is an
2952          --  access attribute or an access discriminant.
2953
2954          if Nkind (Original_Node (E)) = N_Subtype_Indication
2955            and then Ekind (Typ) /= E_Anonymous_Access_Type
2956          then
2957             Subtyp := Entity (Subtype_Mark (Original_Node (E)));
2958
2959             if Has_Discriminants (Subtyp) then
2960                Discrim := First_Discriminant (Base_Type (Subtyp));
2961                Constr := First (Constraints (Constraint (Original_Node (E))));
2962
2963                while Present (Discrim) and then Present (Constr) loop
2964                   if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
2965                      if Nkind (Constr) = N_Discriminant_Association then
2966                         Disc_Exp := Original_Node (Expression (Constr));
2967                      else
2968                         Disc_Exp := Original_Node (Constr);
2969                      end if;
2970
2971                      if Type_Access_Level (Etype (Disc_Exp))
2972                        > Type_Access_Level (Typ)
2973                      then
2974                         Error_Msg_N
2975                           ("operand type has deeper level than allocator type",
2976                            Disc_Exp);
2977
2978                      elsif Nkind (Disc_Exp) = N_Attribute_Reference
2979                        and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
2980                                   = Attribute_Access
2981                        and then Object_Access_Level (Prefix (Disc_Exp))
2982                                   > Type_Access_Level (Typ)
2983                      then
2984                         Error_Msg_N
2985                           ("prefix of attribute has deeper level than"
2986                               & " allocator type", Disc_Exp);
2987
2988                      --  When the operand is an access discriminant the check
2989                      --  is against the level of the prefix object.
2990
2991                      elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
2992                        and then Nkind (Disc_Exp) = N_Selected_Component
2993                        and then Object_Access_Level (Prefix (Disc_Exp))
2994                                   > Type_Access_Level (Typ)
2995                      then
2996                         Error_Msg_N
2997                           ("access discriminant has deeper level than"
2998                               & " allocator type", Disc_Exp);
2999                      end if;
3000                   end if;
3001                   Next_Discriminant (Discrim);
3002                   Next (Constr);
3003                end loop;
3004             end if;
3005          end if;
3006       end if;
3007
3008       --  Check for allocation from an empty storage pool
3009
3010       if No_Pool_Assigned (Typ) then
3011          declare
3012             Loc : constant Source_Ptr := Sloc (N);
3013
3014          begin
3015             Error_Msg_N ("?allocation from empty storage pool!", N);
3016             Error_Msg_N ("?Storage_Error will be raised at run time!", N);
3017             Insert_Action (N,
3018               Make_Raise_Storage_Error (Loc,
3019                 Reason => SE_Empty_Storage_Pool));
3020          end;
3021       end if;
3022    end Resolve_Allocator;
3023
3024    ---------------------------
3025    -- Resolve_Arithmetic_Op --
3026    ---------------------------
3027
3028    --  Used for resolving all arithmetic operators except exponentiation
3029
3030    procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
3031       L   : constant Node_Id := Left_Opnd (N);
3032       R   : constant Node_Id := Right_Opnd (N);
3033       TL  : constant Entity_Id := Base_Type (Etype (L));
3034       TR  : constant Entity_Id := Base_Type (Etype (R));
3035       T   : Entity_Id;
3036       Rop : Node_Id;
3037
3038       B_Typ : constant Entity_Id := Base_Type (Typ);
3039       --  We do the resolution using the base type, because intermediate values
3040       --  in expressions always are of the base type, not a subtype of it.
3041
3042       function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
3043       --  Return True iff given type is Integer or universal real/integer
3044
3045       procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
3046       --  Choose type of integer literal in fixed-point operation to conform
3047       --  to available fixed-point type. T is the type of the other operand,
3048       --  which is needed to determine the expected type of N.
3049
3050       procedure Set_Operand_Type (N : Node_Id);
3051       --  Set operand type to T if universal
3052
3053       -----------------------------
3054       -- Is_Integer_Or_Universal --
3055       -----------------------------
3056
3057       function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
3058          T     : Entity_Id;
3059          Index : Interp_Index;
3060          It    : Interp;
3061
3062       begin
3063          if not Is_Overloaded (N) then
3064             T := Etype (N);
3065             return Base_Type (T) = Base_Type (Standard_Integer)
3066               or else T = Universal_Integer
3067               or else T = Universal_Real;
3068          else
3069             Get_First_Interp (N, Index, It);
3070
3071             while Present (It.Typ) loop
3072
3073                if Base_Type (It.Typ) = Base_Type (Standard_Integer)
3074                  or else It.Typ = Universal_Integer
3075                  or else It.Typ = Universal_Real
3076                then
3077                   return True;
3078                end if;
3079
3080                Get_Next_Interp (Index, It);
3081             end loop;
3082          end if;
3083
3084          return False;
3085       end Is_Integer_Or_Universal;
3086
3087       ----------------------------
3088       -- Set_Mixed_Mode_Operand --
3089       ----------------------------
3090
3091       procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
3092          Index : Interp_Index;
3093          It    : Interp;
3094
3095       begin
3096          if Universal_Interpretation (N) = Universal_Integer then
3097
3098             --  A universal integer literal is resolved as standard integer
3099             --  except in the case of a fixed-point result, where we leave
3100             --  it as universal (to be handled by Exp_Fixd later on)
3101
3102             if Is_Fixed_Point_Type (T) then
3103                Resolve (N, Universal_Integer);
3104             else
3105                Resolve (N, Standard_Integer);
3106             end if;
3107
3108          elsif Universal_Interpretation (N) = Universal_Real
3109            and then (T = Base_Type (Standard_Integer)
3110                       or else T = Universal_Integer
3111                       or else T = Universal_Real)
3112          then
3113             --  A universal real can appear in a fixed-type context. We resolve
3114             --  the literal with that context, even though this might raise an
3115             --  exception prematurely (the other operand may be zero).
3116
3117             Resolve (N, B_Typ);
3118
3119          elsif Etype (N) = Base_Type (Standard_Integer)
3120            and then T = Universal_Real
3121            and then Is_Overloaded (N)
3122          then
3123             --  Integer arg in mixed-mode operation. Resolve with universal
3124             --  type, in case preference rule must be applied.
3125
3126             Resolve (N, Universal_Integer);
3127
3128          elsif Etype (N) = T
3129            and then B_Typ /= Universal_Fixed
3130          then
3131             --  Not a mixed-mode operation. Resolve with context.
3132
3133             Resolve (N, B_Typ);
3134
3135          elsif Etype (N) = Any_Fixed then
3136
3137             --  N may itself be a mixed-mode operation, so use context type.
3138
3139             Resolve (N, B_Typ);
3140
3141          elsif Is_Fixed_Point_Type (T)
3142            and then B_Typ = Universal_Fixed
3143            and then Is_Overloaded (N)
3144          then
3145             --  Must be (fixed * fixed) operation, operand must have one
3146             --  compatible interpretation.
3147
3148             Resolve (N, Any_Fixed);
3149
3150          elsif Is_Fixed_Point_Type (B_Typ)
3151            and then (T = Universal_Real
3152                       or else Is_Fixed_Point_Type (T))
3153            and then Is_Overloaded (N)
3154          then
3155             --  C * F(X) in a fixed context, where C is a real literal or a
3156             --  fixed-point expression. F must have either a fixed type
3157             --  interpretation or an integer interpretation, but not both.
3158
3159             Get_First_Interp (N, Index, It);
3160
3161             while Present (It.Typ) loop
3162                if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
3163
3164                   if Analyzed (N) then
3165                      Error_Msg_N ("ambiguous operand in fixed operation", N);
3166                   else
3167                      Resolve (N, Standard_Integer);
3168                   end if;
3169
3170                elsif Is_Fixed_Point_Type (It.Typ) then
3171
3172                   if Analyzed (N) then
3173                      Error_Msg_N ("ambiguous operand in fixed operation", N);
3174                   else
3175                      Resolve (N, It.Typ);
3176                   end if;
3177                end if;
3178
3179                Get_Next_Interp (Index, It);
3180             end loop;
3181
3182             --  Reanalyze the literal with the fixed type of the context.
3183             --  If context is Universal_Fixed, we are within a conversion,
3184             --  leave the literal as a universal real because there is no
3185             --  usable fixed type, and the target of the conversion plays
3186             --  no role in the resolution.
3187
3188             declare
3189                Op2 : Node_Id;
3190                T2  : Entity_Id;
3191
3192             begin
3193                if N = L then
3194                   Op2 := R;
3195                else
3196                   Op2 := L;
3197                end if;
3198
3199                if B_Typ = Universal_Fixed
3200                   and then Nkind (Op2) = N_Real_Literal
3201                then
3202                   T2 := Universal_Real;
3203                else
3204                   T2 := B_Typ;
3205                end if;
3206
3207                Set_Analyzed (Op2, False);
3208                Resolve (Op2, T2);
3209             end;
3210
3211          else
3212             Resolve (N);
3213          end if;
3214       end Set_Mixed_Mode_Operand;
3215
3216       ----------------------
3217       -- Set_Operand_Type --
3218       ----------------------
3219
3220       procedure Set_Operand_Type (N : Node_Id) is
3221       begin
3222          if Etype (N) = Universal_Integer
3223            or else Etype (N) = Universal_Real
3224          then
3225             Set_Etype (N, T);
3226          end if;
3227       end Set_Operand_Type;
3228
3229    --  Start of processing for Resolve_Arithmetic_Op
3230
3231    begin
3232       if Comes_From_Source (N)
3233         and then Ekind (Entity (N)) = E_Function
3234         and then Is_Imported (Entity (N))
3235         and then Is_Intrinsic_Subprogram (Entity (N))
3236       then
3237          Resolve_Intrinsic_Operator (N, Typ);
3238          return;
3239
3240       --  Special-case for mixed-mode universal expressions or fixed point
3241       --  type operation: each argument is resolved separately. The same
3242       --  treatment is required if one of the operands of a fixed point
3243       --  operation is universal real, since in this case we don't do a
3244       --  conversion to a specific fixed-point type (instead the expander
3245       --  takes care of the case).
3246
3247       elsif (B_Typ = Universal_Integer
3248            or else B_Typ = Universal_Real)
3249         and then Present (Universal_Interpretation (L))
3250         and then Present (Universal_Interpretation (R))
3251       then
3252          Resolve (L, Universal_Interpretation (L));
3253          Resolve (R, Universal_Interpretation (R));
3254          Set_Etype (N, B_Typ);
3255
3256       elsif (B_Typ = Universal_Real
3257            or else Etype (N) = Universal_Fixed
3258            or else (Etype (N) = Any_Fixed
3259                      and then Is_Fixed_Point_Type (B_Typ))
3260            or else (Is_Fixed_Point_Type (B_Typ)
3261                      and then (Is_Integer_Or_Universal (L)
3262                                  or else
3263                                Is_Integer_Or_Universal (R))))
3264         and then (Nkind (N) = N_Op_Multiply or else
3265                   Nkind (N) = N_Op_Divide)
3266       then
3267          if TL = Universal_Integer or else TR = Universal_Integer then
3268             Check_For_Visible_Operator (N, B_Typ);
3269          end if;
3270
3271          --  If context is a fixed type and one operand is integer, the
3272          --  other is resolved with the type of the context.
3273
3274          if Is_Fixed_Point_Type (B_Typ)
3275            and then (Base_Type (TL) = Base_Type (Standard_Integer)
3276                       or else TL = Universal_Integer)
3277          then
3278             Resolve (R, B_Typ);
3279             Resolve (L, TL);
3280
3281          elsif Is_Fixed_Point_Type (B_Typ)
3282            and then (Base_Type (TR) = Base_Type (Standard_Integer)
3283                       or else TR = Universal_Integer)
3284          then
3285             Resolve (L, B_Typ);
3286             Resolve (R, TR);
3287
3288          else
3289             Set_Mixed_Mode_Operand (L, TR);
3290             Set_Mixed_Mode_Operand (R, TL);
3291          end if;
3292
3293          if Etype (N) = Universal_Fixed
3294            or else Etype (N) = Any_Fixed
3295          then
3296             if B_Typ = Universal_Fixed
3297               and then Nkind (Parent (N)) /= N_Type_Conversion
3298               and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
3299             then
3300                Error_Msg_N
3301                  ("type cannot be determined from context!", N);
3302                Error_Msg_N
3303                  ("\explicit conversion to result type required", N);
3304
3305                Set_Etype (L, Any_Type);
3306                Set_Etype (R, Any_Type);
3307
3308             else
3309                if Ada_Version = Ada_83
3310                   and then Etype (N) = Universal_Fixed
3311                   and then Nkind (Parent (N)) /= N_Type_Conversion
3312                   and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
3313                then
3314                   Error_Msg_N
3315                     ("(Ada 83) fixed-point operation " &
3316                      "needs explicit conversion",
3317                      N);
3318                end if;
3319
3320                Set_Etype (N, B_Typ);
3321             end if;
3322
3323          elsif Is_Fixed_Point_Type (B_Typ)
3324            and then (Is_Integer_Or_Universal (L)
3325                        or else Nkind (L) = N_Real_Literal
3326                        or else Nkind (R) = N_Real_Literal
3327                        or else
3328                      Is_Integer_Or_Universal (R))
3329          then
3330             Set_Etype (N, B_Typ);
3331
3332          elsif Etype (N) = Any_Fixed then
3333
3334             --  If no previous errors, this is only possible if one operand
3335             --  is overloaded and the context is universal. Resolve as such.
3336
3337             Set_Etype (N, B_Typ);
3338          end if;
3339
3340       else
3341          if (TL = Universal_Integer or else TL = Universal_Real)
3342            and then (TR = Universal_Integer or else TR = Universal_Real)
3343          then
3344             Check_For_Visible_Operator (N, B_Typ);
3345          end if;
3346
3347          --  If the context is Universal_Fixed and the operands are also
3348          --  universal fixed, this is an error, unless there is only one
3349          --  applicable fixed_point type (usually duration).
3350
3351          if B_Typ = Universal_Fixed
3352            and then Etype (L) = Universal_Fixed
3353          then
3354             T := Unique_Fixed_Point_Type (N);
3355
3356             if T  = Any_Type then
3357                Set_Etype (N, T);
3358                return;
3359             else
3360                Resolve (L, T);
3361                Resolve (R, T);
3362             end if;
3363
3364          else
3365             Resolve (L, B_Typ);
3366             Resolve (R, B_Typ);
3367          end if;
3368
3369          --  If one of the arguments was resolved to a non-universal type.
3370          --  label the result of the operation itself with the same type.
3371          --  Do the same for the universal argument, if any.
3372
3373          T := Intersect_Types (L, R);
3374          Set_Etype (N, Base_Type (T));
3375          Set_Operand_Type (L);
3376          Set_Operand_Type (R);
3377       end if;
3378
3379       Generate_Operator_Reference (N, Typ);
3380       Eval_Arithmetic_Op (N);
3381
3382       --  Set overflow and division checking bit. Much cleverer code needed
3383       --  here eventually and perhaps the Resolve routines should be separated
3384       --  for the various arithmetic operations, since they will need
3385       --  different processing. ???
3386
3387       if Nkind (N) in N_Op then
3388          if not Overflow_Checks_Suppressed (Etype (N)) then
3389             Enable_Overflow_Check (N);
3390          end if;
3391
3392          --  Give warning if explicit division by zero
3393
3394          if (Nkind (N) = N_Op_Divide
3395              or else Nkind (N) = N_Op_Rem
3396              or else Nkind (N) = N_Op_Mod)
3397            and then not Division_Checks_Suppressed (Etype (N))
3398          then
3399             Rop := Right_Opnd (N);
3400
3401             if Compile_Time_Known_Value (Rop)
3402               and then ((Is_Integer_Type (Etype (Rop))
3403                                 and then Expr_Value (Rop) = Uint_0)
3404                           or else
3405                         (Is_Real_Type (Etype (Rop))
3406                                 and then Expr_Value_R (Rop) = Ureal_0))
3407             then
3408                Apply_Compile_Time_Constraint_Error
3409                  (N, "division by zero?", CE_Divide_By_Zero,
3410                   Loc => Sloc (Right_Opnd (N)));
3411
3412             --  Otherwise just set the flag to check at run time
3413
3414             else
3415                Set_Do_Division_Check (N);
3416             end if;
3417          end if;
3418       end if;
3419
3420       Check_Unset_Reference (L);
3421       Check_Unset_Reference (R);
3422    end Resolve_Arithmetic_Op;
3423
3424    ------------------
3425    -- Resolve_Call --
3426    ------------------
3427
3428    procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
3429       Loc     : constant Source_Ptr := Sloc (N);
3430       Subp    : constant Node_Id    := Name (N);
3431       Nam     : Entity_Id;
3432       I       : Interp_Index;
3433       It      : Interp;
3434       Norm_OK : Boolean;
3435       Scop    : Entity_Id;
3436       Decl    : Node_Id;
3437
3438    begin
3439       --  The context imposes a unique interpretation with type Typ on
3440       --  a procedure or function call. Find the entity of the subprogram
3441       --  that yields the expected type, and propagate the corresponding
3442       --  formal constraints on the actuals. The caller has established
3443       --  that an interpretation exists, and emitted an error if not unique.
3444
3445       --  First deal with the case of a call to an access-to-subprogram,
3446       --  dereference made explicit in Analyze_Call.
3447
3448       if Ekind (Etype (Subp)) = E_Subprogram_Type then
3449          if not Is_Overloaded (Subp) then
3450             Nam := Etype (Subp);
3451
3452          else
3453             --  Find the interpretation whose type (a subprogram type)
3454             --  has a return type that is compatible with the context.
3455             --  Analysis of the node has established that one exists.
3456
3457             Get_First_Interp (Subp,  I, It);
3458             Nam := Empty;
3459
3460             while Present (It.Typ) loop
3461                if Covers (Typ, Etype (It.Typ)) then
3462                   Nam := It.Typ;
3463                   exit;
3464                end if;
3465
3466                Get_Next_Interp (I, It);
3467             end loop;
3468
3469             if No (Nam) then
3470                raise Program_Error;
3471             end if;
3472          end if;
3473
3474          --  If the prefix is not an entity, then resolve it
3475
3476          if not Is_Entity_Name (Subp) then
3477             Resolve (Subp, Nam);
3478          end if;
3479
3480          --  For an indirect call, we always invalidate checks, since we
3481          --  do not know whether the subprogram is local or global. Yes
3482          --  we could do better here, e.g. by knowing that there are no
3483          --  local subprograms, but it does not seem worth the effort.
3484          --  Similarly, we kill al knowledge of current constant values.
3485
3486          Kill_Current_Values;
3487
3488       --  If this is a procedure call which is really an entry call, do
3489       --  the conversion of the procedure call to an entry call. Protected
3490       --  operations use the same circuitry because the name in the call
3491       --  can be an arbitrary expression with special resolution rules.
3492
3493       elsif Nkind (Subp) = N_Selected_Component
3494         or else Nkind (Subp) = N_Indexed_Component
3495         or else (Is_Entity_Name (Subp)
3496                   and then Ekind (Entity (Subp)) = E_Entry)
3497       then
3498          Resolve_Entry_Call (N, Typ);
3499          Check_Elab_Call (N);
3500
3501          --  Kill checks and constant values, as above for indirect case
3502          --  Who knows what happens when another task is activated?
3503
3504          Kill_Current_Values;
3505          return;
3506
3507       --  Normal subprogram call with name established in Resolve
3508
3509       elsif not (Is_Type (Entity (Subp))) then
3510          Nam := Entity (Subp);
3511          Set_Entity_With_Style_Check (Subp, Nam);
3512          Generate_Reference (Nam, Subp);
3513
3514       --  Otherwise we must have the case of an overloaded call
3515
3516       else
3517          pragma Assert (Is_Overloaded (Subp));
3518          Nam := Empty;  --  We know that it will be assigned in loop below.
3519
3520          Get_First_Interp (Subp,  I, It);
3521
3522          while Present (It.Typ) loop
3523             if Covers (Typ, It.Typ) then
3524                Nam := It.Nam;
3525                Set_Entity_With_Style_Check (Subp, Nam);
3526                Generate_Reference (Nam, Subp);
3527                exit;
3528             end if;
3529
3530             Get_Next_Interp (I, It);
3531          end loop;
3532       end if;
3533
3534       --  Check that a call to Current_Task does not occur in an entry body
3535
3536       if Is_RTE (Nam, RE_Current_Task) then
3537          declare
3538             P : Node_Id;
3539
3540          begin
3541             P := N;
3542             loop
3543                P := Parent (P);
3544                exit when No (P);
3545
3546                if Nkind (P) = N_Entry_Body then
3547                   Error_Msg_NE
3548                     ("& should not be used in entry body ('R'M C.7(17))",
3549                      N, Nam);
3550                   exit;
3551                end if;
3552             end loop;
3553          end;
3554       end if;
3555
3556       --  Cannot call thread body directly
3557
3558       if Is_Thread_Body (Nam) then
3559          Error_Msg_N ("cannot call thread body directly", N);
3560       end if;
3561
3562       --  If the subprogram is not global, then kill all checks. This is
3563       --  a bit conservative, since in many cases we could do better, but
3564       --  it is not worth the effort. Similarly, we kill constant values.
3565       --  However we do not need to do this for internal entities (unless
3566       --  they are inherited user-defined subprograms), since they are not
3567       --  in the business of molesting global values.
3568
3569       if not Is_Library_Level_Entity (Nam)
3570         and then (Comes_From_Source (Nam)
3571                    or else (Present (Alias (Nam))
3572                              and then Comes_From_Source (Alias (Nam))))
3573       then
3574          Kill_Current_Values;
3575       end if;
3576
3577       --  Check for call to obsolescent subprogram
3578
3579       if Warn_On_Obsolescent_Feature then
3580          Decl := Parent (Parent (Nam));
3581
3582          if Nkind (Decl) = N_Subprogram_Declaration
3583            and then Is_List_Member (Decl)
3584            and then Nkind (Next (Decl)) = N_Pragma
3585          then
3586             declare
3587                P : constant Node_Id := Next (Decl);
3588
3589             begin
3590                if Chars (P) = Name_Obsolescent then
3591                   Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
3592
3593                   if Pragma_Argument_Associations (P) /= No_List then
3594                      Name_Buffer (1) := '|';
3595                      Name_Buffer (2) := '?';
3596                      Name_Len := 2;
3597                      Add_String_To_Name_Buffer
3598                        (Strval (Expression
3599                                  (First (Pragma_Argument_Associations (P)))));
3600                      Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
3601                   end if;
3602                end if;
3603             end;
3604          end if;
3605       end if;
3606
3607       --  Check that a procedure call does not occur in the context
3608       --  of the entry call statement of a conditional or timed
3609       --  entry call. Note that the case of a call to a subprogram
3610       --  renaming of an entry will also be rejected. The test
3611       --  for N not being an N_Entry_Call_Statement is defensive,
3612       --  covering the possibility that the processing of entry
3613       --  calls might reach this point due to later modifications
3614       --  of the code above.
3615
3616       if Nkind (Parent (N)) = N_Entry_Call_Alternative
3617         and then Nkind (N) /= N_Entry_Call_Statement
3618         and then Entry_Call_Statement (Parent (N)) = N
3619       then
3620          Error_Msg_N ("entry call required in select statement", N);
3621       end if;
3622
3623       --  Check that this is not a call to a protected procedure or
3624       --  entry from within a protected function.
3625
3626       if Ekind (Current_Scope) = E_Function
3627         and then Ekind (Scope (Current_Scope)) = E_Protected_Type
3628         and then Ekind (Nam) /= E_Function
3629         and then Scope (Nam) = Scope (Current_Scope)
3630       then
3631          Error_Msg_N ("within protected function, protected " &
3632            "object is constant", N);
3633          Error_Msg_N ("\cannot call operation that may modify it", N);
3634       end if;
3635
3636       --  Freeze the subprogram name if not in default expression. Note
3637       --  that we freeze procedure calls as well as function calls.
3638       --  Procedure calls are not frozen according to the rules (RM
3639       --  13.14(14)) because it is impossible to have a procedure call to
3640       --  a non-frozen procedure in pure Ada, but in the code that we
3641       --  generate in the expander, this rule needs extending because we
3642       --  can generate procedure calls that need freezing.
3643
3644       if Is_Entity_Name (Subp) and then not In_Default_Expression then
3645          Freeze_Expression (Subp);
3646       end if;
3647
3648       --  For a predefined operator, the type of the result is the type
3649       --  imposed by context, except for a predefined operation on universal
3650       --  fixed. Otherwise The type of the call is the type returned by the
3651       --  subprogram being called.
3652
3653       if Is_Predefined_Op (Nam) then
3654          if Etype (N) /= Universal_Fixed then
3655             Set_Etype (N, Typ);
3656          end if;
3657
3658       --  If the subprogram returns an array type, and the context
3659       --  requires the component type of that array type, the node is
3660       --  really an indexing of the parameterless call. Resolve as such.
3661       --  A pathological case occurs when the type of the component is
3662       --  an access to the array type. In this case the call is truly
3663       --  ambiguous.
3664
3665       elsif Needs_No_Actuals (Nam)
3666         and then
3667           ((Is_Array_Type (Etype (Nam))
3668                    and then Covers (Typ, Component_Type (Etype (Nam))))
3669              or else (Is_Access_Type (Etype (Nam))
3670                         and then Is_Array_Type (Designated_Type (Etype (Nam)))
3671                         and then
3672                           Covers (Typ,
3673                             Component_Type (Designated_Type (Etype (Nam))))))
3674       then
3675          declare
3676             Index_Node : Node_Id;
3677             New_Subp   : Node_Id;
3678             Ret_Type   : constant Entity_Id := Etype (Nam);
3679
3680          begin
3681             if Is_Access_Type (Ret_Type)
3682               and then Ret_Type = Component_Type (Designated_Type (Ret_Type))
3683             then
3684                Error_Msg_N
3685                  ("cannot disambiguate function call and indexing", N);
3686             else
3687                New_Subp := Relocate_Node (Subp);
3688                Set_Entity (Subp, Nam);
3689
3690                if Component_Type (Ret_Type) /= Any_Type then
3691                   Index_Node :=
3692                     Make_Indexed_Component (Loc,
3693                       Prefix =>
3694                         Make_Function_Call (Loc,
3695                           Name => New_Subp),
3696                       Expressions => Parameter_Associations (N));
3697
3698                   --  Since we are correcting a node classification error made
3699                   --  by the parser, we call Replace rather than Rewrite.
3700
3701                   Replace (N, Index_Node);
3702                   Set_Etype (Prefix (N), Ret_Type);
3703                   Set_Etype (N, Typ);
3704                   Resolve_Indexed_Component (N, Typ);
3705                   Check_Elab_Call (Prefix (N));
3706                end if;
3707             end if;
3708
3709             return;
3710          end;
3711
3712       else
3713          Set_Etype (N, Etype (Nam));
3714       end if;
3715
3716       --  In the case where the call is to an overloaded subprogram, Analyze
3717       --  calls Normalize_Actuals once per overloaded subprogram. Therefore in
3718       --  such a case Normalize_Actuals needs to be called once more to order
3719       --  the actuals correctly. Otherwise the call will have the ordering
3720       --  given by the last overloaded subprogram whether this is the correct
3721       --  one being called or not.
3722
3723       if Is_Overloaded (Subp) then
3724          Normalize_Actuals (N, Nam, False, Norm_OK);
3725          pragma Assert (Norm_OK);
3726       end if;
3727
3728       --  In any case, call is fully resolved now. Reset Overload flag, to
3729       --  prevent subsequent overload resolution if node is analyzed again
3730
3731       Set_Is_Overloaded (Subp, False);
3732       Set_Is_Overloaded (N, False);
3733
3734       --  If we are calling the current subprogram from immediately within
3735       --  its body, then that is the case where we can sometimes detect
3736       --  cases of infinite recursion statically. Do not try this in case
3737       --  restriction No_Recursion is in effect anyway.
3738
3739       Scop := Current_Scope;
3740
3741       if Nam = Scop
3742         and then not Restriction_Active (No_Recursion)
3743         and then Check_Infinite_Recursion (N)
3744       then
3745          --  Here we detected and flagged an infinite recursion, so we do
3746          --  not need to test the case below for further warnings.
3747
3748          null;
3749
3750       --  If call is to immediately containing subprogram, then check for
3751       --  the case of a possible run-time detectable infinite recursion.
3752
3753       else
3754          while Scop /= Standard_Standard loop
3755             if Nam = Scop then
3756                --  Although in general recursion is not statically checkable,
3757                --  the case of calling an immediately containing subprogram
3758                --  is easy to catch.
3759
3760                Check_Restriction (No_Recursion, N);
3761
3762                --  If the recursive call is to a parameterless procedure, then
3763                --  even if we can't statically detect infinite recursion, this
3764                --  is pretty suspicious, and we output a warning. Furthermore,
3765                --  we will try later to detect some cases here at run time by
3766                --  expanding checking code (see Detect_Infinite_Recursion in
3767                --  package Exp_Ch6).
3768
3769                --  If the recursive call is within a handler we do not emit a
3770                --  warning, because this is a common idiom: loop until input
3771                --  is correct, catch illegal input in handler and restart.
3772
3773                if No (First_Formal (Nam))
3774                  and then Etype (Nam) = Standard_Void_Type
3775                  and then not Error_Posted (N)
3776                  and then Nkind (Parent (N)) /= N_Exception_Handler
3777                then
3778                   Set_Has_Recursive_Call (Nam);
3779                   Error_Msg_N ("possible infinite recursion?", N);
3780                   Error_Msg_N ("Storage_Error may be raised at run time?", N);
3781                end if;
3782
3783                exit;
3784             end if;
3785
3786             Scop := Scope (Scop);
3787          end loop;
3788       end if;
3789
3790       --  If subprogram name is a predefined operator, it was given in
3791       --  functional notation. Replace call node with operator node, so
3792       --  that actuals can be resolved appropriately.
3793
3794       if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
3795          Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
3796          return;
3797
3798       elsif Present (Alias (Nam))
3799         and then Is_Predefined_Op (Alias (Nam))
3800       then
3801          Resolve_Actuals (N, Nam);
3802          Make_Call_Into_Operator (N, Typ, Alias (Nam));
3803          return;
3804       end if;
3805
3806       --  Create a transient scope if the resulting type requires it
3807
3808       --  There are 3 notable exceptions: in init procs, the transient scope
3809       --  overhead is not needed and even incorrect due to the actual expansion
3810       --  of adjust calls; the second case is enumeration literal pseudo calls,
3811       --  the other case is intrinsic subprograms (Unchecked_Conversion and
3812       --  source information functions) that do not use the secondary stack
3813       --  even though the return type is unconstrained.
3814
3815       --  If this is an initialization call for a type whose initialization
3816       --  uses the secondary stack, we also need to create a transient scope
3817       --  for it, precisely because we will not do it within the init proc
3818       --  itself.
3819
3820       if Expander_Active
3821         and then Is_Type (Etype (Nam))
3822         and then Requires_Transient_Scope (Etype (Nam))
3823         and then Ekind (Nam) /= E_Enumeration_Literal
3824         and then not Within_Init_Proc
3825         and then not Is_Intrinsic_Subprogram (Nam)
3826       then
3827          Establish_Transient_Scope
3828            (N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
3829
3830          --  If the call appears within the bounds of a loop, it will
3831          --  be rewritten and reanalyzed, nothing left to do here.
3832
3833          if Nkind (N) /= N_Function_Call then
3834             return;
3835          end if;
3836
3837       elsif Is_Init_Proc (Nam)
3838         and then not Within_Init_Proc
3839       then
3840          Check_Initialization_Call (N, Nam);
3841       end if;
3842
3843       --  A protected function cannot be called within the definition of the
3844       --  enclosing protected type.
3845
3846       if Is_Protected_Type (Scope (Nam))
3847         and then In_Open_Scopes (Scope (Nam))
3848         and then not Has_Completion (Scope (Nam))
3849       then
3850          Error_Msg_NE
3851            ("& cannot be called before end of protected definition", N, Nam);
3852       end if;
3853
3854       --  Propagate interpretation to actuals, and add default expressions
3855       --  where needed.
3856
3857       if Present (First_Formal (Nam)) then
3858          Resolve_Actuals (N, Nam);
3859
3860          --  Overloaded literals are rewritten as function calls, for
3861          --  purpose of resolution. After resolution, we can replace
3862          --  the call with the literal itself.
3863
3864       elsif Ekind (Nam) = E_Enumeration_Literal then
3865          Copy_Node (Subp, N);
3866          Resolve_Entity_Name (N, Typ);
3867
3868          --  Avoid validation, since it is a static function call
3869
3870          return;
3871       end if;
3872
3873       --  If the subprogram is a primitive operation, check whether or not
3874       --  it is a correct dispatching call.
3875
3876       if Is_Overloadable (Nam)
3877         and then Is_Dispatching_Operation (Nam)
3878       then
3879          Check_Dispatching_Call (N);
3880
3881       elsif Is_Abstract (Nam)
3882         and then not In_Instance
3883       then
3884          Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
3885       end if;
3886
3887       if Is_Intrinsic_Subprogram (Nam) then
3888          Check_Intrinsic_Call (N);
3889       end if;
3890
3891       Eval_Call (N);
3892       Check_Elab_Call (N);
3893    end Resolve_Call;
3894
3895    -------------------------------
3896    -- Resolve_Character_Literal --
3897    -------------------------------
3898
3899    procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
3900       B_Typ : constant Entity_Id := Base_Type (Typ);
3901       C     : Entity_Id;
3902
3903    begin
3904       --  Verify that the character does belong to the type of the context
3905
3906       Set_Etype (N, B_Typ);
3907       Eval_Character_Literal (N);
3908
3909       --  Wide_Character literals must always be defined, since the set of
3910       --  wide character literals is complete, i.e. if a character literal
3911       --  is accepted by the parser, then it is OK for wide character.
3912
3913       if Root_Type (B_Typ) = Standard_Wide_Character then
3914          return;
3915
3916       --  Always accept character literal for type Any_Character, which
3917       --  occurs in error situations and in comparisons of literals, both
3918       --  of which should accept all literals.
3919
3920       elsif B_Typ = Any_Character then
3921          return;
3922
3923       --  For Standard.Character or a type derived from it, check that
3924       --  the literal is in range
3925
3926       elsif Root_Type (B_Typ) = Standard_Character then
3927          if In_Character_Range (Char_Literal_Value (N)) then
3928             return;
3929          end if;
3930
3931       --  If the entity is already set, this has already been resolved in
3932       --  a generic context, or comes from expansion. Nothing else to do.
3933
3934       elsif Present (Entity (N)) then
3935          return;
3936
3937       --  Otherwise we have a user defined character type, and we can use
3938       --  the standard visibility mechanisms to locate the referenced entity
3939
3940       else
3941          C := Current_Entity (N);
3942
3943          while Present (C) loop
3944             if Etype (C) = B_Typ then
3945                Set_Entity_With_Style_Check (N, C);
3946                Generate_Reference (C, N);
3947                return;
3948             end if;
3949
3950             C := Homonym (C);
3951          end loop;
3952       end if;
3953
3954       --  If we fall through, then the literal does not match any of the
3955       --  entries of the enumeration type. This isn't just a constraint
3956       --  error situation, it is an illegality (see RM 4.2).
3957
3958       Error_Msg_NE
3959         ("character not defined for }", N, First_Subtype (B_Typ));
3960    end Resolve_Character_Literal;
3961
3962    ---------------------------
3963    -- Resolve_Comparison_Op --
3964    ---------------------------
3965
3966    --  Context requires a boolean type, and plays no role in resolution.
3967    --  Processing identical to that for equality operators. The result
3968    --  type is the base type, which matters when pathological subtypes of
3969    --  booleans with limited ranges are used.
3970
3971    procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
3972       L : constant Node_Id := Left_Opnd (N);
3973       R : constant Node_Id := Right_Opnd (N);
3974       T : Entity_Id;
3975
3976    begin
3977       Check_Direct_Boolean_Op (N);
3978
3979       --  If this is an intrinsic operation which is not predefined, use
3980       --  the types of its declared arguments to resolve the possibly
3981       --  overloaded operands. Otherwise the operands are unambiguous and
3982       --  specify the expected type.
3983
3984       if Scope (Entity (N)) /= Standard_Standard then
3985          T := Etype (First_Entity (Entity (N)));
3986       else
3987          T := Find_Unique_Type (L, R);
3988
3989          if T = Any_Fixed then
3990             T := Unique_Fixed_Point_Type (L);
3991          end if;
3992       end if;
3993
3994       Set_Etype (N, Base_Type (Typ));
3995       Generate_Reference (T, N, ' ');
3996
3997       if T /= Any_Type then
3998          if T = Any_String
3999            or else T = Any_Composite
4000            or else T = Any_Character
4001          then
4002             if T = Any_Character then
4003                Ambiguous_Character (L);
4004             else
4005                Error_Msg_N ("ambiguous operands for comparison", N);
4006             end if;
4007
4008             Set_Etype (N, Any_Type);
4009             return;
4010
4011          else
4012             Resolve (L, T);
4013             Resolve (R, T);
4014             Check_Unset_Reference (L);
4015             Check_Unset_Reference (R);
4016             Generate_Operator_Reference (N, T);
4017             Eval_Relational_Op (N);
4018          end if;
4019       end if;
4020    end Resolve_Comparison_Op;
4021
4022    ------------------------------------
4023    -- Resolve_Conditional_Expression --
4024    ------------------------------------
4025
4026    procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
4027       Condition : constant Node_Id := First (Expressions (N));
4028       Then_Expr : constant Node_Id := Next (Condition);
4029       Else_Expr : constant Node_Id := Next (Then_Expr);
4030
4031    begin
4032       Resolve (Condition, Standard_Boolean);
4033       Resolve (Then_Expr, Typ);
4034       Resolve (Else_Expr, Typ);
4035
4036       Set_Etype (N, Typ);
4037       Eval_Conditional_Expression (N);
4038    end Resolve_Conditional_Expression;
4039
4040    -----------------------------------------
4041    -- Resolve_Discrete_Subtype_Indication --
4042    -----------------------------------------
4043
4044    procedure Resolve_Discrete_Subtype_Indication
4045      (N   : Node_Id;
4046       Typ : Entity_Id)
4047    is
4048       R : Node_Id;
4049       S : Entity_Id;
4050
4051    begin
4052       Analyze (Subtype_Mark (N));
4053       S := Entity (Subtype_Mark (N));
4054
4055       if Nkind (Constraint (N)) /= N_Range_Constraint then
4056          Error_Msg_N ("expect range constraint for discrete type", N);
4057          Set_Etype (N, Any_Type);
4058
4059       else
4060          R := Range_Expression (Constraint (N));
4061
4062          if R = Error then
4063             return;
4064          end if;
4065
4066          Analyze (R);
4067
4068          if Base_Type (S) /= Base_Type (Typ) then
4069             Error_Msg_NE
4070               ("expect subtype of }", N, First_Subtype (Typ));
4071
4072             --  Rewrite the constraint as a range of Typ
4073             --  to allow compilation to proceed further.
4074
4075             Set_Etype (N, Typ);
4076             Rewrite (Low_Bound (R),
4077               Make_Attribute_Reference (Sloc (Low_Bound (R)),
4078                 Prefix =>         New_Occurrence_Of (Typ, Sloc (R)),
4079                 Attribute_Name => Name_First));
4080             Rewrite (High_Bound (R),
4081               Make_Attribute_Reference (Sloc (High_Bound (R)),
4082                 Prefix =>         New_Occurrence_Of (Typ, Sloc (R)),
4083                 Attribute_Name => Name_First));
4084
4085          else
4086             Resolve (R, Typ);
4087             Set_Etype (N, Etype (R));
4088
4089             --  Additionally, we must check that the bounds are compatible
4090             --  with the given subtype, which might be different from the
4091             --  type of the context.
4092
4093             Apply_Range_Check (R, S);
4094
4095             --  ??? If the above check statically detects a Constraint_Error
4096             --  it replaces the offending bound(s) of the range R with a
4097             --  Constraint_Error node. When the itype which uses these bounds
4098             --  is frozen the resulting call to Duplicate_Subexpr generates
4099             --  a new temporary for the bounds.
4100
4101             --  Unfortunately there are other itypes that are also made depend
4102             --  on these bounds, so when Duplicate_Subexpr is called they get
4103             --  a forward reference to the newly created temporaries and Gigi
4104             --  aborts on such forward references. This is probably sign of a
4105             --  more fundamental problem somewhere else in either the order of
4106             --  itype freezing or the way certain itypes are constructed.
4107
4108             --  To get around this problem we call Remove_Side_Effects right
4109             --  away if either bounds of R are a Constraint_Error.
4110
4111             declare
4112                L : constant Node_Id := Low_Bound (R);
4113                H : constant Node_Id := High_Bound (R);
4114
4115             begin
4116                if Nkind (L) = N_Raise_Constraint_Error then
4117                   Remove_Side_Effects (L);
4118                end if;
4119
4120                if Nkind (H) = N_Raise_Constraint_Error then
4121                   Remove_Side_Effects (H);
4122                end if;
4123             end;
4124
4125             Check_Unset_Reference (Low_Bound  (R));
4126             Check_Unset_Reference (High_Bound (R));
4127          end if;
4128       end if;
4129    end Resolve_Discrete_Subtype_Indication;
4130
4131    -------------------------
4132    -- Resolve_Entity_Name --
4133    -------------------------
4134
4135    --  Used to resolve identifiers and expanded names
4136
4137    procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
4138       E : constant Entity_Id := Entity (N);
4139
4140    begin
4141       --  If garbage from errors, set to Any_Type and return
4142
4143       if No (E) and then Total_Errors_Detected /= 0 then
4144          Set_Etype (N, Any_Type);
4145          return;
4146       end if;
4147
4148       --  Replace named numbers by corresponding literals. Note that this is
4149       --  the one case where Resolve_Entity_Name must reset the Etype, since
4150       --  it is currently marked as universal.
4151
4152       if Ekind (E) = E_Named_Integer then
4153          Set_Etype (N, Typ);
4154          Eval_Named_Integer (N);
4155
4156       elsif Ekind (E) = E_Named_Real then
4157          Set_Etype (N, Typ);
4158          Eval_Named_Real (N);
4159
4160       --  Allow use of subtype only if it is a concurrent type where we are
4161       --  currently inside the body. This will eventually be expanded
4162       --  into a call to Self (for tasks) or _object (for protected
4163       --  objects). Any other use of a subtype is invalid.
4164
4165       elsif Is_Type (E) then
4166          if Is_Concurrent_Type (E)
4167            and then In_Open_Scopes (E)
4168          then
4169             null;
4170          else
4171             Error_Msg_N
4172                ("Invalid use of subtype mark in expression or call", N);
4173          end if;
4174
4175       --  Check discriminant use if entity is discriminant in current scope,
4176       --  i.e. discriminant of record or concurrent type currently being
4177       --  analyzed. Uses in corresponding body are unrestricted.
4178
4179       elsif Ekind (E) = E_Discriminant
4180         and then Scope (E) = Current_Scope
4181         and then not Has_Completion (Current_Scope)
4182       then
4183          Check_Discriminant_Use (N);
4184
4185       --  A parameterless generic function cannot appear in a context that
4186       --  requires resolution.
4187
4188       elsif Ekind (E) = E_Generic_Function then
4189          Error_Msg_N ("illegal use of generic function", N);
4190
4191       elsif Ekind (E) = E_Out_Parameter
4192         and then Ada_Version = Ada_83
4193         and then (Nkind (Parent (N)) in N_Op
4194                     or else (Nkind (Parent (N)) = N_Assignment_Statement
4195                               and then N = Expression (Parent (N)))
4196                     or else Nkind (Parent (N)) = N_Explicit_Dereference)
4197       then
4198          Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
4199
4200       --  In all other cases, just do the possible static evaluation
4201
4202       else
4203          --  A deferred constant that appears in an expression must have
4204          --  a completion, unless it has been removed by in-place expansion
4205          --  of an aggregate.
4206
4207          if Ekind (E) = E_Constant
4208            and then Comes_From_Source (E)
4209            and then No (Constant_Value (E))
4210            and then Is_Frozen (Etype (E))
4211            and then not In_Default_Expression
4212            and then not Is_Imported (E)
4213          then
4214
4215             if No_Initialization (Parent (E))
4216               or else (Present (Full_View (E))
4217                         and then No_Initialization (Parent (Full_View (E))))
4218             then
4219                null;
4220             else
4221                Error_Msg_N (
4222                  "deferred constant is frozen before completion", N);
4223             end if;
4224          end if;
4225
4226          Eval_Entity_Name (N);
4227       end if;
4228    end Resolve_Entity_Name;
4229
4230    -------------------
4231    -- Resolve_Entry --
4232    -------------------
4233
4234    procedure Resolve_Entry (Entry_Name : Node_Id) is
4235       Loc    : constant Source_Ptr := Sloc (Entry_Name);
4236       Nam    : Entity_Id;
4237       New_N  : Node_Id;
4238       S      : Entity_Id;
4239       Tsk    : Entity_Id;
4240       E_Name : Node_Id;
4241       Index  : Node_Id;
4242
4243       function Actual_Index_Type (E : Entity_Id) return Entity_Id;
4244       --  If the bounds of the entry family being called depend on task
4245       --  discriminants, build a new index subtype where a discriminant is
4246       --  replaced with the value of the discriminant of the target task.
4247       --  The target task is the prefix of the entry name in the call.
4248
4249       -----------------------
4250       -- Actual_Index_Type --
4251       -----------------------
4252
4253       function Actual_Index_Type (E : Entity_Id) return Entity_Id is
4254          Typ   : constant Entity_Id := Entry_Index_Type (E);
4255          Tsk   : constant Entity_Id := Scope (E);
4256          Lo    : constant Node_Id   := Type_Low_Bound  (Typ);
4257          Hi    : constant Node_Id   := Type_High_Bound (Typ);
4258          New_T : Entity_Id;
4259
4260          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
4261          --  If the bound is given by a discriminant, replace with a reference
4262          --  to the discriminant of the same name in the target task.
4263          --  If the entry name is the target of a requeue statement and the
4264          --  entry is in the current protected object, the bound to be used
4265          --  is the discriminal of the object (see apply_range_checks for
4266          --  details of the transformation).
4267
4268          -----------------------------
4269          -- Actual_Discriminant_Ref --
4270          -----------------------------
4271
4272          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
4273             Typ : constant Entity_Id := Etype (Bound);
4274             Ref : Node_Id;
4275
4276          begin
4277             Remove_Side_Effects (Bound);
4278
4279             if not Is_Entity_Name (Bound)
4280               or else Ekind (Entity (Bound)) /= E_Discriminant
4281             then
4282                return Bound;
4283
4284             elsif Is_Protected_Type (Tsk)
4285               and then In_Open_Scopes (Tsk)
4286               and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
4287             then
4288                return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
4289
4290             else
4291                Ref :=
4292                  Make_Selected_Component (Loc,
4293                    Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
4294                    Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
4295                Analyze (Ref);
4296                Resolve (Ref, Typ);
4297                return Ref;
4298             end if;
4299          end Actual_Discriminant_Ref;
4300
4301       --  Start of processing for Actual_Index_Type
4302
4303       begin
4304          if not Has_Discriminants (Tsk)
4305            or else (not Is_Entity_Name (Lo)
4306                      and then not Is_Entity_Name (Hi))
4307          then
4308             return Entry_Index_Type (E);
4309
4310          else
4311             New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
4312             Set_Etype        (New_T, Base_Type (Typ));
4313             Set_Size_Info    (New_T, Typ);
4314             Set_RM_Size      (New_T, RM_Size (Typ));
4315             Set_Scalar_Range (New_T,
4316               Make_Range (Sloc (Entry_Name),
4317                 Low_Bound  => Actual_Discriminant_Ref (Lo),
4318                 High_Bound => Actual_Discriminant_Ref (Hi)));
4319
4320             return New_T;
4321          end if;
4322       end Actual_Index_Type;
4323
4324    --  Start of processing of Resolve_Entry
4325
4326    begin
4327       --  Find name of entry being called, and resolve prefix of name
4328       --  with its own type. The prefix can be overloaded, and the name
4329       --  and signature of the entry must be taken into account.
4330
4331       if Nkind (Entry_Name) = N_Indexed_Component then
4332
4333          --  Case of dealing with entry family within the current tasks
4334
4335          E_Name := Prefix (Entry_Name);
4336
4337       else
4338          E_Name := Entry_Name;
4339       end if;
4340
4341       if Is_Entity_Name (E_Name) then
4342          --  Entry call to an entry (or entry family) in the current task.
4343          --  This is legal even though the task will deadlock. Rewrite as
4344          --  call to current task.
4345
4346          --  This can also be a call to an entry in  an enclosing task.
4347          --  If this is a single task, we have to retrieve its name,
4348          --  because the scope of the entry is the task type, not the
4349          --  object. If the enclosing task is a task type, the identity
4350          --  of the task is given by its own self variable.
4351
4352          --  Finally this can be a requeue on an entry of the same task
4353          --  or protected object.
4354
4355          S := Scope (Entity (E_Name));
4356
4357          for J in reverse 0 .. Scope_Stack.Last loop
4358
4359             if Is_Task_Type (Scope_Stack.Table (J).Entity)
4360               and then not Comes_From_Source (S)
4361             then
4362                --  S is an enclosing task or protected object. The concurrent
4363                --  declaration has been converted into a type declaration, and
4364                --  the object itself has an object declaration that follows
4365                --  the type in the same declarative part.
4366
4367                Tsk := Next_Entity (S);
4368
4369                while Etype (Tsk) /= S loop
4370                   Next_Entity (Tsk);
4371                end loop;
4372
4373                S := Tsk;
4374                exit;
4375
4376             elsif S = Scope_Stack.Table (J).Entity then
4377
4378                --  Call to current task. Will be transformed into call to Self
4379
4380                exit;
4381
4382             end if;
4383          end loop;
4384
4385          New_N :=
4386            Make_Selected_Component (Loc,
4387              Prefix => New_Occurrence_Of (S, Loc),
4388              Selector_Name =>
4389                New_Occurrence_Of (Entity (E_Name), Loc));
4390          Rewrite (E_Name, New_N);
4391          Analyze (E_Name);
4392
4393       elsif Nkind (Entry_Name) = N_Selected_Component
4394         and then Is_Overloaded (Prefix (Entry_Name))
4395       then
4396          --  Use the entry name (which must be unique at this point) to
4397          --  find the prefix that returns the corresponding task type or
4398          --  protected type.
4399
4400          declare
4401             Pref : constant Node_Id := Prefix (Entry_Name);
4402             Ent  : constant Entity_Id :=  Entity (Selector_Name (Entry_Name));
4403             I    : Interp_Index;
4404             It   : Interp;
4405
4406          begin
4407             Get_First_Interp (Pref, I, It);
4408
4409             while Present (It.Typ) loop
4410
4411                if Scope (Ent) = It.Typ then
4412                   Set_Etype (Pref, It.Typ);
4413                   exit;
4414                end if;
4415
4416                Get_Next_Interp (I, It);
4417             end loop;
4418          end;
4419       end if;
4420
4421       if Nkind (Entry_Name) = N_Selected_Component then
4422          Resolve (Prefix (Entry_Name));
4423
4424       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
4425          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
4426          Resolve (Prefix (Prefix (Entry_Name)));
4427          Index :=  First (Expressions (Entry_Name));
4428          Resolve (Index, Entry_Index_Type (Nam));
4429
4430          --  Up to this point the expression could have been the actual
4431          --  in a simple entry call, and be given by a named association.
4432
4433          if Nkind (Index) = N_Parameter_Association then
4434             Error_Msg_N ("expect expression for entry index", Index);
4435          else
4436             Apply_Range_Check (Index, Actual_Index_Type (Nam));
4437          end if;
4438       end if;
4439    end Resolve_Entry;
4440
4441    ------------------------
4442    -- Resolve_Entry_Call --
4443    ------------------------
4444
4445    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
4446       Entry_Name  : constant Node_Id    := Name (N);
4447       Loc         : constant Source_Ptr := Sloc (Entry_Name);
4448       Actuals     : List_Id;
4449       First_Named : Node_Id;
4450       Nam         : Entity_Id;
4451       Norm_OK     : Boolean;
4452       Obj         : Node_Id;
4453       Was_Over    : Boolean;
4454
4455    begin
4456       --  We kill all checks here, because it does not seem worth the
4457       --  effort to do anything better, an entry call is a big operation.
4458
4459       Kill_All_Checks;
4460
4461       --  Processing of the name is similar for entry calls and protected
4462       --  operation calls. Once the entity is determined, we can complete
4463       --  the resolution of the actuals.
4464
4465       --  The selector may be overloaded, in the case of a protected object
4466       --  with overloaded functions. The type of the context is used for
4467       --  resolution.
4468
4469       if Nkind (Entry_Name) = N_Selected_Component
4470         and then Is_Overloaded (Selector_Name (Entry_Name))
4471         and then Typ /= Standard_Void_Type
4472       then
4473          declare
4474             I  : Interp_Index;
4475             It : Interp;
4476
4477          begin
4478             Get_First_Interp (Selector_Name (Entry_Name), I, It);
4479
4480             while Present (It.Typ) loop
4481
4482                if Covers (Typ, It.Typ) then
4483                   Set_Entity (Selector_Name (Entry_Name), It.Nam);
4484                   Set_Etype  (Entry_Name, It.Typ);
4485
4486                   Generate_Reference (It.Typ, N, ' ');
4487                end if;
4488
4489                Get_Next_Interp (I, It);
4490             end loop;
4491          end;
4492       end if;
4493
4494       Resolve_Entry (Entry_Name);
4495
4496       if Nkind (Entry_Name) = N_Selected_Component then
4497
4498          --  Simple entry call.
4499
4500          Nam := Entity (Selector_Name (Entry_Name));
4501          Obj := Prefix (Entry_Name);
4502          Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
4503
4504       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
4505
4506          --  Call to member of entry family.
4507
4508          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
4509          Obj := Prefix (Prefix (Entry_Name));
4510          Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
4511       end if;
4512
4513       --  We cannot in general check the maximum depth of protected entry
4514       --  calls at compile time. But we can tell that any protected entry
4515       --  call at all violates a specified nesting depth of zero.
4516
4517       if Is_Protected_Type (Scope (Nam)) then
4518          Check_Restriction (Max_Entry_Queue_Length, N);
4519       end if;
4520
4521       --  Use context type to disambiguate a protected function that can be
4522       --  called without actuals and that returns an array type, and where
4523       --  the argument list may be an indexing of the returned value.
4524
4525       if Ekind (Nam) = E_Function
4526         and then Needs_No_Actuals (Nam)
4527         and then Present (Parameter_Associations (N))
4528         and then
4529           ((Is_Array_Type (Etype (Nam))
4530              and then Covers (Typ, Component_Type (Etype (Nam))))
4531
4532             or else (Is_Access_Type (Etype (Nam))
4533                       and then Is_Array_Type (Designated_Type (Etype (Nam)))
4534                       and then Covers (Typ,
4535                         Component_Type (Designated_Type (Etype (Nam))))))
4536       then
4537          declare
4538             Index_Node : Node_Id;
4539
4540          begin
4541             Index_Node :=
4542               Make_Indexed_Component (Loc,
4543                 Prefix =>
4544                   Make_Function_Call (Loc,
4545                     Name => Relocate_Node (Entry_Name)),
4546                 Expressions => Parameter_Associations (N));
4547
4548             --  Since we are correcting a node classification error made by
4549             --  the parser, we call Replace rather than Rewrite.
4550
4551             Replace (N, Index_Node);
4552             Set_Etype (Prefix (N), Etype (Nam));
4553             Set_Etype (N, Typ);
4554             Resolve_Indexed_Component (N, Typ);
4555             return;
4556          end;
4557       end if;
4558
4559       --  The operation name may have been overloaded. Order the actuals
4560       --  according to the formals of the resolved entity, and set the
4561       --  return type to that of the operation.
4562
4563       if Was_Over then
4564          Normalize_Actuals (N, Nam, False, Norm_OK);
4565          pragma Assert (Norm_OK);
4566          Set_Etype (N, Etype (Nam));
4567       end if;
4568
4569       Resolve_Actuals (N, Nam);
4570       Generate_Reference (Nam, Entry_Name);
4571
4572       if Ekind (Nam) = E_Entry
4573         or else Ekind (Nam) = E_Entry_Family
4574       then
4575          Check_Potentially_Blocking_Operation (N);
4576       end if;
4577
4578       --  Verify that a procedure call cannot masquerade as an entry
4579       --  call where an entry call is expected.
4580
4581       if Ekind (Nam) = E_Procedure then
4582          if Nkind (Parent (N)) = N_Entry_Call_Alternative
4583            and then N = Entry_Call_Statement (Parent (N))
4584          then
4585             Error_Msg_N ("entry call required in select statement", N);
4586
4587          elsif Nkind (Parent (N)) = N_Triggering_Alternative
4588            and then N = Triggering_Statement (Parent (N))
4589          then
4590             Error_Msg_N ("triggering statement cannot be procedure call", N);
4591
4592          elsif Ekind (Scope (Nam)) = E_Task_Type
4593            and then not In_Open_Scopes (Scope (Nam))
4594          then
4595             Error_Msg_N ("Task has no entry with this name", Entry_Name);
4596          end if;
4597       end if;
4598
4599       --  After resolution, entry calls and protected procedure calls
4600       --  are changed into entry calls, for expansion. The structure
4601       --  of the node does not change, so it can safely be done in place.
4602       --  Protected function calls must keep their structure because they
4603       --  are subexpressions.
4604
4605       if Ekind (Nam) /= E_Function then
4606
4607          --  A protected operation that is not a function may modify the
4608          --  corresponding object, and cannot apply to a constant.
4609          --  If this is an internal call, the prefix is the type itself.
4610
4611          if Is_Protected_Type (Scope (Nam))
4612            and then not Is_Variable (Obj)
4613            and then (not Is_Entity_Name (Obj)
4614                        or else not Is_Type (Entity (Obj)))
4615          then
4616             Error_Msg_N
4617               ("prefix of protected procedure or entry call must be variable",
4618                Entry_Name);
4619          end if;
4620
4621          Actuals := Parameter_Associations (N);
4622          First_Named := First_Named_Actual (N);
4623
4624          Rewrite (N,
4625            Make_Entry_Call_Statement (Loc,
4626              Name                   => Entry_Name,
4627              Parameter_Associations => Actuals));
4628
4629          Set_First_Named_Actual (N, First_Named);
4630          Set_Analyzed (N, True);
4631
4632       --  Protected functions can return on the secondary stack, in which
4633       --  case we must trigger the transient scope mechanism
4634
4635       elsif Expander_Active
4636         and then Requires_Transient_Scope (Etype (Nam))
4637       then
4638          Establish_Transient_Scope (N,
4639            Sec_Stack => not Functions_Return_By_DSP_On_Target);
4640       end if;
4641    end Resolve_Entry_Call;
4642
4643    -------------------------
4644    -- Resolve_Equality_Op --
4645    -------------------------
4646
4647    --  Both arguments must have the same type, and the boolean context
4648    --  does not participate in the resolution. The first pass verifies
4649    --  that the interpretation is not ambiguous, and the type of the left
4650    --  argument is correctly set, or is Any_Type in case of ambiguity.
4651    --  If both arguments are strings or aggregates, allocators, or Null,
4652    --  they are ambiguous even though they carry a single (universal) type.
4653    --  Diagnose this case here.
4654
4655    procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
4656       L : constant Node_Id   := Left_Opnd (N);
4657       R : constant Node_Id   := Right_Opnd (N);
4658       T : Entity_Id := Find_Unique_Type (L, R);
4659
4660       function Find_Unique_Access_Type return Entity_Id;
4661       --  In the case of allocators, make a last-ditch attempt to find a single
4662       --  access type with the right designated type. This is semantically
4663       --  dubious, and of no interest to any real code, but c48008a makes it
4664       --  all worthwhile.
4665
4666       -----------------------------
4667       -- Find_Unique_Access_Type --
4668       -----------------------------
4669
4670       function Find_Unique_Access_Type return Entity_Id is
4671          Acc : Entity_Id;
4672          E   : Entity_Id;
4673          S   : Entity_Id := Current_Scope;
4674
4675       begin
4676          if Ekind (Etype (R)) =  E_Allocator_Type then
4677             Acc := Designated_Type (Etype (R));
4678
4679          elsif Ekind (Etype (L)) =  E_Allocator_Type then
4680             Acc := Designated_Type (Etype (L));
4681
4682          else
4683             return Empty;
4684          end if;
4685
4686          while S /= Standard_Standard loop
4687             E := First_Entity (S);
4688
4689             while Present (E) loop
4690
4691                if Is_Type (E)
4692                  and then Is_Access_Type (E)
4693                  and then Ekind (E) /= E_Allocator_Type
4694                  and then Designated_Type (E) = Base_Type (Acc)
4695                then
4696                   return E;
4697                end if;
4698
4699                Next_Entity (E);
4700             end loop;
4701
4702             S := Scope (S);
4703          end loop;
4704
4705          return Empty;
4706       end Find_Unique_Access_Type;
4707
4708    --  Start of processing for Resolve_Equality_Op
4709
4710    begin
4711       Check_Direct_Boolean_Op (N);
4712
4713       Set_Etype (N, Base_Type (Typ));
4714       Generate_Reference (T, N, ' ');
4715
4716       if T = Any_Fixed then
4717          T := Unique_Fixed_Point_Type (L);
4718       end if;
4719
4720       if T /= Any_Type then
4721
4722          if T = Any_String
4723            or else T = Any_Composite
4724            or else T = Any_Character
4725          then
4726
4727             if T = Any_Character then
4728                Ambiguous_Character (L);
4729             else
4730                Error_Msg_N ("ambiguous operands for equality", N);
4731             end if;
4732
4733             Set_Etype (N, Any_Type);
4734             return;
4735
4736          elsif T = Any_Access
4737            or else Ekind (T) = E_Allocator_Type
4738          then
4739             T := Find_Unique_Access_Type;
4740
4741             if No (T) then
4742                Error_Msg_N ("ambiguous operands for equality", N);
4743                Set_Etype (N, Any_Type);
4744                return;
4745             end if;
4746          end if;
4747
4748          Resolve (L, T);
4749          Resolve (R, T);
4750
4751          if Warn_On_Redundant_Constructs
4752            and then Comes_From_Source (N)
4753            and then Is_Entity_Name (R)
4754            and then Entity (R) = Standard_True
4755            and then Comes_From_Source (R)
4756          then
4757             Error_Msg_N ("comparison with True is redundant?", R);
4758          end if;
4759
4760          Check_Unset_Reference (L);
4761          Check_Unset_Reference (R);
4762          Generate_Operator_Reference (N, T);
4763
4764          --  If this is an inequality, it may be the implicit inequality
4765          --  created for a user-defined operation, in which case the corres-
4766          --  ponding equality operation is not intrinsic, and the operation
4767          --  cannot be constant-folded. Else fold.
4768
4769          if Nkind (N) = N_Op_Eq
4770            or else Comes_From_Source (Entity (N))
4771            or else Ekind (Entity (N)) = E_Operator
4772            or else Is_Intrinsic_Subprogram
4773              (Corresponding_Equality (Entity (N)))
4774          then
4775             Eval_Relational_Op (N);
4776          elsif Nkind (N) = N_Op_Ne
4777            and then Is_Abstract (Entity (N))
4778          then
4779             Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
4780          end if;
4781       end if;
4782    end Resolve_Equality_Op;
4783
4784    ----------------------------------
4785    -- Resolve_Explicit_Dereference --
4786    ----------------------------------
4787
4788    procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
4789       P  : constant Node_Id := Prefix (N);
4790       I  : Interp_Index;
4791       It : Interp;
4792
4793    begin
4794       --  Now that we know the type, check that this is not a
4795       --  dereference of an uncompleted type. Note that this
4796       --  is not entirely correct, because dereferences of
4797       --  private types are legal in default expressions.
4798       --  This consideration also applies to similar checks
4799       --  for allocators, qualified expressions, and type
4800       --  conversions. ???
4801
4802       Check_Fully_Declared (Typ, N);
4803
4804       if Is_Overloaded (P) then
4805
4806          --  Use the context type to select the prefix that has the
4807          --  correct designated type.
4808
4809          Get_First_Interp (P, I, It);
4810          while Present (It.Typ) loop
4811             exit when Is_Access_Type (It.Typ)
4812               and then Covers (Typ, Designated_Type (It.Typ));
4813
4814             Get_Next_Interp (I, It);
4815          end loop;
4816
4817          Resolve (P, It.Typ);
4818          Set_Etype (N, Designated_Type (It.Typ));
4819
4820       else
4821          Resolve (P);
4822       end if;
4823
4824       if Is_Access_Type (Etype (P)) then
4825          Apply_Access_Check (N);
4826       end if;
4827
4828       --  If the designated type is a packed unconstrained array type,
4829       --  and the explicit dereference is not in the context of an
4830       --  attribute reference, then we must compute and set the actual
4831       --  subtype, since it is needed by Gigi. The reason we exclude
4832       --  the attribute case is that this is handled fine by Gigi, and
4833       --  in fact we use such attributes to build the actual subtype.
4834       --  We also exclude generated code (which builds actual subtypes
4835       --  directly if they are needed).
4836
4837       if Is_Array_Type (Etype (N))
4838         and then Is_Packed (Etype (N))
4839         and then not Is_Constrained (Etype (N))
4840         and then Nkind (Parent (N)) /= N_Attribute_Reference
4841         and then Comes_From_Source (N)
4842       then
4843          Set_Etype (N, Get_Actual_Subtype (N));
4844       end if;
4845
4846       --  Note: there is no Eval processing required for an explicit
4847       --  deference, because the type is known to be an allocators, and
4848       --  allocator expressions can never be static.
4849
4850    end Resolve_Explicit_Dereference;
4851
4852    -------------------------------
4853    -- Resolve_Indexed_Component --
4854    -------------------------------
4855
4856    procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
4857       Name       : constant Node_Id := Prefix  (N);
4858       Expr       : Node_Id;
4859       Array_Type : Entity_Id := Empty; -- to prevent junk warning
4860       Index      : Node_Id;
4861
4862    begin
4863       if Is_Overloaded (Name) then
4864
4865          --  Use the context type to select the prefix that yields the
4866          --  correct component type.
4867
4868          declare
4869             I     : Interp_Index;
4870             It    : Interp;
4871             I1    : Interp_Index := 0;
4872             P     : constant Node_Id := Prefix (N);
4873             Found : Boolean := False;
4874
4875          begin
4876             Get_First_Interp (P, I, It);
4877
4878             while Present (It.Typ) loop
4879
4880                if (Is_Array_Type (It.Typ)
4881                      and then Covers (Typ, Component_Type (It.Typ)))
4882                  or else (Is_Access_Type (It.Typ)
4883                             and then Is_Array_Type (Designated_Type (It.Typ))
4884                             and then Covers
4885                               (Typ, Component_Type (Designated_Type (It.Typ))))
4886                then
4887                   if Found then
4888                      It := Disambiguate (P, I1, I, Any_Type);
4889
4890                      if It = No_Interp then
4891                         Error_Msg_N ("ambiguous prefix for indexing",  N);
4892                         Set_Etype (N, Typ);
4893                         return;
4894
4895                      else
4896                         Found := True;
4897                         Array_Type := It.Typ;
4898                         I1 := I;
4899                      end if;
4900
4901                   else
4902                      Found := True;
4903                      Array_Type := It.Typ;
4904                      I1 := I;
4905                   end if;
4906                end if;
4907
4908                Get_Next_Interp (I, It);
4909             end loop;
4910          end;
4911
4912       else
4913          Array_Type := Etype (Name);
4914       end if;
4915
4916       Resolve (Name, Array_Type);
4917       Array_Type := Get_Actual_Subtype_If_Available (Name);
4918
4919       --  If prefix is access type, dereference to get real array type.
4920       --  Note: we do not apply an access check because the expander always
4921       --  introduces an explicit dereference, and the check will happen there.
4922
4923       if Is_Access_Type (Array_Type) then
4924          Array_Type := Designated_Type (Array_Type);
4925       end if;
4926
4927       --  If name was overloaded, set component type correctly now.
4928
4929       Set_Etype (N, Component_Type (Array_Type));
4930
4931       Index := First_Index (Array_Type);
4932       Expr  := First (Expressions (N));
4933
4934       --  The prefix may have resolved to a string literal, in which case
4935       --  its etype has a special representation. This is only possible
4936       --  currently if the prefix is a static concatenation, written in
4937       --  functional notation.
4938
4939       if Ekind (Array_Type) = E_String_Literal_Subtype then
4940          Resolve (Expr, Standard_Positive);
4941
4942       else
4943          while Present (Index) and Present (Expr) loop
4944             Resolve (Expr, Etype (Index));
4945             Check_Unset_Reference (Expr);
4946
4947             if Is_Scalar_Type (Etype (Expr)) then
4948                Apply_Scalar_Range_Check (Expr, Etype (Index));
4949             else
4950                Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
4951             end if;
4952
4953             Next_Index (Index);
4954             Next (Expr);
4955          end loop;
4956       end if;
4957
4958       Eval_Indexed_Component (N);
4959    end Resolve_Indexed_Component;
4960
4961    -----------------------------
4962    -- Resolve_Integer_Literal --
4963    -----------------------------
4964
4965    procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
4966    begin
4967       Set_Etype (N, Typ);
4968       Eval_Integer_Literal (N);
4969    end Resolve_Integer_Literal;
4970
4971    --------------------------------
4972    -- Resolve_Intrinsic_Operator --
4973    --------------------------------
4974
4975    procedure Resolve_Intrinsic_Operator  (N : Node_Id; Typ : Entity_Id) is
4976       Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
4977       Op   : Entity_Id;
4978       Arg1 : Node_Id;
4979       Arg2 : Node_Id;
4980
4981    begin
4982       Op := Entity (N);
4983
4984       while Scope (Op) /= Standard_Standard loop
4985          Op := Homonym (Op);
4986          pragma Assert (Present (Op));
4987       end loop;
4988
4989       Set_Entity (N, Op);
4990       Set_Is_Overloaded (N, False);
4991
4992       --  If the operand type is private, rewrite with suitable
4993       --  conversions on the operands and the result, to expose
4994       --  the proper underlying numeric type.
4995
4996       if Is_Private_Type (Typ) then
4997          Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd  (N));
4998
4999          if Nkind (N) = N_Op_Expon then
5000             Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
5001          else
5002             Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
5003          end if;
5004
5005          Save_Interps (Left_Opnd (N),  Expression (Arg1));
5006          Save_Interps (Right_Opnd (N), Expression (Arg2));
5007
5008          Set_Left_Opnd  (N, Arg1);
5009          Set_Right_Opnd (N, Arg2);
5010
5011          Set_Etype (N, Btyp);
5012          Rewrite (N, Unchecked_Convert_To (Typ, N));
5013          Resolve (N, Typ);
5014
5015       elsif Typ /= Etype (Left_Opnd (N))
5016         or else Typ /= Etype (Right_Opnd (N))
5017       then
5018          --  Add explicit conversion where needed, and save interpretations
5019          --  in case operands are overloaded.
5020
5021          Arg1 := Convert_To (Typ, Left_Opnd  (N));
5022          Arg2 := Convert_To (Typ, Right_Opnd (N));
5023
5024          if Nkind (Arg1) = N_Type_Conversion then
5025             Save_Interps (Left_Opnd (N), Expression (Arg1));
5026          else
5027             Save_Interps (Left_Opnd (N), Arg1);
5028          end if;
5029
5030          if Nkind (Arg2) = N_Type_Conversion then
5031             Save_Interps (Right_Opnd (N), Expression (Arg2));
5032          else
5033             Save_Interps (Right_Opnd (N), Arg2);
5034          end if;
5035
5036          Rewrite (Left_Opnd  (N), Arg1);
5037          Rewrite (Right_Opnd (N), Arg2);
5038          Analyze (Arg1);
5039          Analyze (Arg2);
5040          Resolve_Arithmetic_Op (N, Typ);
5041
5042       else
5043          Resolve_Arithmetic_Op (N, Typ);
5044       end if;
5045    end Resolve_Intrinsic_Operator;
5046
5047    --------------------------------------
5048    -- Resolve_Intrinsic_Unary_Operator --
5049    --------------------------------------
5050
5051    procedure Resolve_Intrinsic_Unary_Operator
5052      (N   : Node_Id;
5053       Typ : Entity_Id)
5054    is
5055       Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
5056       Op   : Entity_Id;
5057       Arg2 : Node_Id;
5058
5059    begin
5060       Op := Entity (N);
5061
5062       while Scope (Op) /= Standard_Standard loop
5063          Op := Homonym (Op);
5064          pragma Assert (Present (Op));
5065       end loop;
5066
5067       Set_Entity (N, Op);
5068
5069       if Is_Private_Type (Typ) then
5070          Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
5071          Save_Interps (Right_Opnd (N), Expression (Arg2));
5072
5073          Set_Right_Opnd (N, Arg2);
5074
5075          Set_Etype (N, Btyp);
5076          Rewrite (N, Unchecked_Convert_To (Typ, N));
5077          Resolve (N, Typ);
5078
5079       else
5080          Resolve_Unary_Op (N, Typ);
5081       end if;
5082    end Resolve_Intrinsic_Unary_Operator;
5083
5084    ------------------------
5085    -- Resolve_Logical_Op --
5086    ------------------------
5087
5088    procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
5089       B_Typ : Entity_Id;
5090
5091    begin
5092       Check_Direct_Boolean_Op (N);
5093
5094       --  Predefined operations on scalar types yield the base type. On
5095       --  the other hand, logical operations on arrays yield the type of
5096       --  the arguments (and the context).
5097
5098       if Is_Array_Type (Typ) then
5099          B_Typ := Typ;
5100       else
5101          B_Typ := Base_Type (Typ);
5102       end if;
5103
5104       --  The following test is required because the operands of the operation
5105       --  may be literals, in which case the resulting type appears to be
5106       --  compatible with a signed integer type, when in fact it is compatible
5107       --  only with modular types. If the context itself is universal, the
5108       --  operation is illegal.
5109
5110       if not Valid_Boolean_Arg (Typ) then
5111          Error_Msg_N ("invalid context for logical operation", N);
5112          Set_Etype (N, Any_Type);
5113          return;
5114
5115       elsif Typ = Any_Modular then
5116          Error_Msg_N
5117            ("no modular type available in this context", N);
5118          Set_Etype (N, Any_Type);
5119          return;
5120       elsif Is_Modular_Integer_Type (Typ)
5121         and then Etype (Left_Opnd (N)) = Universal_Integer
5122         and then Etype (Right_Opnd (N)) = Universal_Integer
5123       then
5124          Check_For_Visible_Operator (N, B_Typ);
5125       end if;
5126
5127       Resolve (Left_Opnd (N), B_Typ);
5128       Resolve (Right_Opnd (N), B_Typ);
5129
5130       Check_Unset_Reference (Left_Opnd  (N));
5131       Check_Unset_Reference (Right_Opnd (N));
5132
5133       Set_Etype (N, B_Typ);
5134       Generate_Operator_Reference (N, B_Typ);
5135       Eval_Logical_Op (N);
5136    end Resolve_Logical_Op;
5137
5138    ---------------------------
5139    -- Resolve_Membership_Op --
5140    ---------------------------
5141
5142    --  The context can only be a boolean type, and does not determine
5143    --  the arguments. Arguments should be unambiguous, but the preference
5144    --  rule for universal types applies.
5145
5146    procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
5147       pragma Warnings (Off, Typ);
5148
5149       L : constant Node_Id   := Left_Opnd (N);
5150       R : constant Node_Id   := Right_Opnd (N);
5151       T : Entity_Id;
5152
5153    begin
5154       if L = Error or else R = Error then
5155          return;
5156       end if;
5157
5158       if not Is_Overloaded (R)
5159         and then
5160           (Etype (R) = Universal_Integer or else
5161            Etype (R) = Universal_Real)
5162         and then Is_Overloaded (L)
5163       then
5164          T := Etype (R);
5165       else
5166          T := Intersect_Types (L, R);
5167       end if;
5168
5169       Resolve (L, T);
5170       Check_Unset_Reference (L);
5171
5172       if Nkind (R) = N_Range
5173         and then not Is_Scalar_Type (T)
5174       then
5175          Error_Msg_N ("scalar type required for range", R);
5176       end if;
5177
5178       if Is_Entity_Name (R) then
5179          Freeze_Expression (R);
5180       else
5181          Resolve (R, T);
5182          Check_Unset_Reference (R);
5183       end if;
5184
5185       Eval_Membership_Op (N);
5186    end Resolve_Membership_Op;
5187
5188    ------------------
5189    -- Resolve_Null --
5190    ------------------
5191
5192    procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
5193    begin
5194       --  Handle restriction against anonymous null access values
5195       --  This restriction can be turned off using -gnatdh.
5196
5197       --  Ada 2005 (AI-231): Remove restriction
5198
5199       if Ada_Version < Ada_05
5200         and then not Debug_Flag_J
5201         and then Ekind (Typ) = E_Anonymous_Access_Type
5202         and then Comes_From_Source (N)
5203       then
5204          --  In the common case of a call which uses an explicitly null
5205          --  value for an access parameter, give specialized error msg
5206
5207          if Nkind (Parent (N)) = N_Procedure_Call_Statement
5208               or else
5209             Nkind (Parent (N)) = N_Function_Call
5210          then
5211             Error_Msg_N
5212               ("null is not allowed as argument for an access parameter", N);
5213
5214          --  Standard message for all other cases (are there any?)
5215
5216          else
5217             Error_Msg_N
5218               ("null cannot be of an anonymous access type", N);
5219          end if;
5220       end if;
5221
5222       --  In a distributed context, null for a remote access to subprogram
5223       --  may need to be replaced with a special record aggregate. In this
5224       --  case, return after having done the transformation.
5225
5226       if (Ekind (Typ) = E_Record_Type
5227            or else Is_Remote_Access_To_Subprogram_Type (Typ))
5228         and then Remote_AST_Null_Value (N, Typ)
5229       then
5230          return;
5231       end if;
5232
5233       --  The null literal takes its type from the context.
5234
5235       Set_Etype (N, Typ);
5236    end Resolve_Null;
5237
5238    -----------------------
5239    -- Resolve_Op_Concat --
5240    -----------------------
5241
5242    procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
5243       Btyp : constant Entity_Id := Base_Type (Typ);
5244       Op1  : constant Node_Id := Left_Opnd (N);
5245       Op2  : constant Node_Id := Right_Opnd (N);
5246
5247       procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
5248       --  Internal procedure to resolve one operand of concatenation operator.
5249       --  The operand is either of the array type or of the component type.
5250       --  If the operand is an aggregate, and the component type is composite,
5251       --  this is ambiguous if component type has aggregates.
5252
5253       -------------------------------
5254       -- Resolve_Concatenation_Arg --
5255       -------------------------------
5256
5257       procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
5258       begin
5259          if In_Instance then
5260             if Is_Comp
5261               or else (not Is_Overloaded (Arg)
5262                and then Etype (Arg) /= Any_Composite
5263                and then Covers (Component_Type (Typ), Etype (Arg)))
5264             then
5265                Resolve (Arg, Component_Type (Typ));
5266             else
5267                Resolve (Arg, Btyp);
5268             end if;
5269
5270          elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
5271
5272             if Nkind (Arg) = N_Aggregate
5273               and then Is_Composite_Type (Component_Type (Typ))
5274             then
5275                if Is_Private_Type (Component_Type (Typ)) then
5276                   Resolve (Arg, Btyp);
5277
5278                else
5279                   Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
5280                   Set_Etype (Arg, Any_Type);
5281                end if;
5282
5283             else
5284                if Is_Overloaded (Arg)
5285                  and then Has_Compatible_Type (Arg, Typ)
5286                  and then Etype (Arg) /= Any_Type
5287                then
5288                   Error_Msg_N ("ambiguous operand for concatenation!", Arg);
5289
5290                   declare
5291                      I  : Interp_Index;
5292                      It : Interp;
5293
5294                   begin
5295                      Get_First_Interp (Arg, I, It);
5296
5297                      while Present (It.Nam) loop
5298
5299                         if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
5300                           or else Base_Type (Etype (It.Nam)) =
5301                             Base_Type (Component_Type (Typ))
5302                         then
5303                            Error_Msg_Sloc := Sloc (It.Nam);
5304                            Error_Msg_N ("\possible interpretation#", Arg);
5305                         end if;
5306
5307                         Get_Next_Interp (I, It);
5308                      end loop;
5309                   end;
5310                end if;
5311
5312                Resolve (Arg, Component_Type (Typ));
5313
5314                if Nkind (Arg) = N_String_Literal then
5315                   Set_Etype (Arg, Component_Type (Typ));
5316                end if;
5317
5318                if Arg = Left_Opnd (N) then
5319                   Set_Is_Component_Left_Opnd (N);
5320                else
5321                   Set_Is_Component_Right_Opnd (N);
5322                end if;
5323             end if;
5324
5325          else
5326             Resolve (Arg, Btyp);
5327          end if;
5328
5329          Check_Unset_Reference (Arg);
5330       end Resolve_Concatenation_Arg;
5331
5332    --  Start of processing for Resolve_Op_Concat
5333
5334    begin
5335       Set_Etype (N, Btyp);
5336
5337       if Is_Limited_Composite (Btyp) then
5338          Error_Msg_N ("concatenation not available for limited array", N);
5339          Explain_Limited_Type (Btyp, N);
5340       end if;
5341
5342       --  If the operands are themselves concatenations, resolve them as
5343       --  such directly. This removes several layers of recursion and allows
5344       --  GNAT to handle larger multiple concatenations.
5345
5346       if Nkind (Op1) = N_Op_Concat
5347         and then not Is_Array_Type (Component_Type (Typ))
5348         and then Entity (Op1) = Entity (N)
5349       then
5350          Resolve_Op_Concat (Op1, Typ);
5351       else
5352          Resolve_Concatenation_Arg
5353            (Op1,  Is_Component_Left_Opnd  (N));
5354       end if;
5355
5356       if Nkind (Op2) = N_Op_Concat
5357         and then not Is_Array_Type (Component_Type (Typ))
5358         and then Entity (Op2) = Entity (N)
5359       then
5360          Resolve_Op_Concat (Op2, Typ);
5361       else
5362          Resolve_Concatenation_Arg
5363            (Op2, Is_Component_Right_Opnd  (N));
5364       end if;
5365
5366       Generate_Operator_Reference (N, Typ);
5367
5368       if Is_String_Type (Typ) then
5369          Eval_Concatenation (N);
5370       end if;
5371
5372       --  If this is not a static concatenation, but the result is a
5373       --  string type (and not an array of strings) insure that static
5374       --  string operands have their subtypes properly constructed.
5375
5376       if Nkind (N) /= N_String_Literal
5377         and then Is_Character_Type (Component_Type (Typ))
5378       then
5379          Set_String_Literal_Subtype (Op1, Typ);
5380          Set_String_Literal_Subtype (Op2, Typ);
5381       end if;
5382    end Resolve_Op_Concat;
5383
5384    ----------------------
5385    -- Resolve_Op_Expon --
5386    ----------------------
5387
5388    procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
5389       B_Typ : constant Entity_Id := Base_Type (Typ);
5390
5391    begin
5392       --  Catch attempts to do fixed-point exponentation with universal
5393       --  operands, which is a case where the illegality is not caught
5394       --  during normal operator analysis.
5395
5396       if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
5397          Error_Msg_N ("exponentiation not available for fixed point", N);
5398          return;
5399       end if;
5400
5401       if Comes_From_Source (N)
5402         and then Ekind (Entity (N)) = E_Function
5403         and then Is_Imported (Entity (N))
5404         and then Is_Intrinsic_Subprogram (Entity (N))
5405       then
5406          Resolve_Intrinsic_Operator (N, Typ);
5407          return;
5408       end if;
5409
5410       if Etype (Left_Opnd (N)) = Universal_Integer
5411         or else Etype (Left_Opnd (N)) = Universal_Real
5412       then
5413          Check_For_Visible_Operator (N, B_Typ);
5414       end if;
5415
5416       --  We do the resolution using the base type, because intermediate values
5417       --  in expressions always are of the base type, not a subtype of it.
5418
5419       Resolve (Left_Opnd (N), B_Typ);
5420       Resolve (Right_Opnd (N), Standard_Integer);
5421
5422       Check_Unset_Reference (Left_Opnd  (N));
5423       Check_Unset_Reference (Right_Opnd (N));
5424
5425       Set_Etype (N, B_Typ);
5426       Generate_Operator_Reference (N, B_Typ);
5427       Eval_Op_Expon (N);
5428
5429       --  Set overflow checking bit. Much cleverer code needed here eventually
5430       --  and perhaps the Resolve routines should be separated for the various
5431       --  arithmetic operations, since they will need different processing. ???
5432
5433       if Nkind (N) in N_Op then
5434          if not Overflow_Checks_Suppressed (Etype (N)) then
5435             Enable_Overflow_Check (N);
5436          end if;
5437       end if;
5438    end Resolve_Op_Expon;
5439
5440    --------------------
5441    -- Resolve_Op_Not --
5442    --------------------
5443
5444    procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
5445       B_Typ : Entity_Id;
5446
5447       function Parent_Is_Boolean return Boolean;
5448       --  This function determines if the parent node is a boolean operator
5449       --  or operation (comparison op, membership test, or short circuit form)
5450       --  and the not in question is the left operand of this operation.
5451       --  Note that if the not is in parens, then false is returned.
5452
5453       function Parent_Is_Boolean return Boolean is
5454       begin
5455          if Paren_Count (N) /= 0 then
5456             return False;
5457
5458          else
5459             case Nkind (Parent (N)) is
5460                when N_Op_And   |
5461                     N_Op_Eq    |
5462                     N_Op_Ge    |
5463                     N_Op_Gt    |
5464                     N_Op_Le    |
5465                     N_Op_Lt    |
5466                     N_Op_Ne    |
5467                     N_Op_Or    |
5468                     N_Op_Xor   |
5469                     N_In       |
5470                     N_Not_In   |
5471                     N_And_Then |
5472                     N_Or_Else =>
5473
5474                   return Left_Opnd (Parent (N)) = N;
5475
5476                when others =>
5477                   return False;
5478             end case;
5479          end if;
5480       end Parent_Is_Boolean;
5481
5482    --  Start of processing for Resolve_Op_Not
5483
5484    begin
5485       --  Predefined operations on scalar types yield the base type. On
5486       --  the other hand, logical operations on arrays yield the type of
5487       --  the arguments (and the context).
5488
5489       if Is_Array_Type (Typ) then
5490          B_Typ := Typ;
5491       else
5492          B_Typ := Base_Type (Typ);
5493       end if;
5494
5495       if not Valid_Boolean_Arg (Typ) then
5496          Error_Msg_N ("invalid operand type for operator&", N);
5497          Set_Etype (N, Any_Type);
5498          return;
5499
5500       elsif Typ = Universal_Integer or else Typ = Any_Modular then
5501          if Parent_Is_Boolean then
5502             Error_Msg_N
5503               ("operand of not must be enclosed in parentheses",
5504                Right_Opnd (N));
5505          else
5506             Error_Msg_N
5507               ("no modular type available in this context", N);
5508          end if;
5509
5510          Set_Etype (N, Any_Type);
5511          return;
5512
5513       else
5514          if not Is_Boolean_Type (Typ)
5515            and then Parent_Is_Boolean
5516          then
5517             Error_Msg_N ("?not expression should be parenthesized here", N);
5518          end if;
5519
5520          Resolve (Right_Opnd (N), B_Typ);
5521          Check_Unset_Reference (Right_Opnd (N));
5522          Set_Etype (N, B_Typ);
5523          Generate_Operator_Reference (N, B_Typ);
5524          Eval_Op_Not (N);
5525       end if;
5526    end Resolve_Op_Not;
5527
5528    -----------------------------
5529    -- Resolve_Operator_Symbol --
5530    -----------------------------
5531
5532    --  Nothing to be done, all resolved already
5533
5534    procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
5535       pragma Warnings (Off, N);
5536       pragma Warnings (Off, Typ);
5537
5538    begin
5539       null;
5540    end Resolve_Operator_Symbol;
5541
5542    ----------------------------------
5543    -- Resolve_Qualified_Expression --
5544    ----------------------------------
5545
5546    procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
5547       pragma Warnings (Off, Typ);
5548
5549       Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
5550       Expr       : constant Node_Id   := Expression (N);
5551
5552    begin
5553       Resolve (Expr, Target_Typ);
5554
5555       --  A qualified expression requires an exact match of the type,
5556       --  class-wide matching is not allowed.
5557
5558       if Is_Class_Wide_Type (Target_Typ)
5559         and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
5560       then
5561          Wrong_Type (Expr, Target_Typ);
5562       end if;
5563
5564       --  If the target type is unconstrained, then we reset the type of
5565       --  the result from the type of the expression. For other cases, the
5566       --  actual subtype of the expression is the target type.
5567
5568       if Is_Composite_Type (Target_Typ)
5569         and then not Is_Constrained (Target_Typ)
5570       then
5571          Set_Etype (N, Etype (Expr));
5572       end if;
5573
5574       Eval_Qualified_Expression (N);
5575    end Resolve_Qualified_Expression;
5576
5577    -------------------
5578    -- Resolve_Range --
5579    -------------------
5580
5581    procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
5582       L : constant Node_Id := Low_Bound (N);
5583       H : constant Node_Id := High_Bound (N);
5584
5585    begin
5586       Set_Etype (N, Typ);
5587       Resolve (L, Typ);
5588       Resolve (H, Typ);
5589
5590       Check_Unset_Reference (L);
5591       Check_Unset_Reference (H);
5592
5593       --  We have to check the bounds for being within the base range as
5594       --  required for a non-static context. Normally this is automatic
5595       --  and done as part of evaluating expressions, but the N_Range
5596       --  node is an exception, since in GNAT we consider this node to
5597       --  be a subexpression, even though in Ada it is not. The circuit
5598       --  in Sem_Eval could check for this, but that would put the test
5599       --  on the main evaluation path for expressions.
5600
5601       Check_Non_Static_Context (L);
5602       Check_Non_Static_Context (H);
5603
5604       --  If bounds are static, constant-fold them, so size computations
5605       --  are identical between front-end and back-end. Do not perform this
5606       --  transformation while analyzing generic units, as type information
5607       --  would then be lost when reanalyzing the constant node in the
5608       --  instance.
5609
5610       if Is_Discrete_Type (Typ) and then Expander_Active then
5611          if Is_OK_Static_Expression (L) then
5612             Fold_Uint  (L, Expr_Value (L), Is_Static_Expression (L));
5613          end if;
5614
5615          if Is_OK_Static_Expression (H) then
5616             Fold_Uint  (H, Expr_Value (H), Is_Static_Expression (H));
5617          end if;
5618       end if;
5619    end Resolve_Range;
5620
5621    --------------------------
5622    -- Resolve_Real_Literal --
5623    --------------------------
5624
5625    procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
5626       Actual_Typ : constant Entity_Id := Etype (N);
5627
5628    begin
5629       --  Special processing for fixed-point literals to make sure that the
5630       --  value is an exact multiple of small where this is required. We
5631       --  skip this for the universal real case, and also for generic types.
5632
5633       if Is_Fixed_Point_Type (Typ)
5634         and then Typ /= Universal_Fixed
5635         and then Typ /= Any_Fixed
5636         and then not Is_Generic_Type (Typ)
5637       then
5638          declare
5639             Val   : constant Ureal := Realval (N);
5640             Cintr : constant Ureal := Val / Small_Value (Typ);
5641             Cint  : constant Uint  := UR_Trunc (Cintr);
5642             Den   : constant Uint  := Norm_Den (Cintr);
5643             Stat  : Boolean;
5644
5645          begin
5646             --  Case of literal is not an exact multiple of the Small
5647
5648             if Den /= 1 then
5649
5650                --  For a source program literal for a decimal fixed-point
5651                --  type, this is statically illegal (RM 4.9(36)).
5652
5653                if Is_Decimal_Fixed_Point_Type (Typ)
5654                  and then Actual_Typ = Universal_Real
5655                  and then Comes_From_Source (N)
5656                then
5657                   Error_Msg_N ("value has extraneous low order digits", N);
5658                end if;
5659
5660                --  Replace literal by a value that is the exact representation
5661                --  of a value of the type, i.e. a multiple of the small value,
5662                --  by truncation, since Machine_Rounds is false for all GNAT
5663                --  fixed-point types (RM 4.9(38)).
5664
5665                Stat := Is_Static_Expression (N);
5666                Rewrite (N,
5667                  Make_Real_Literal (Sloc (N),
5668                    Realval => Small_Value (Typ) * Cint));
5669
5670                Set_Is_Static_Expression (N, Stat);
5671             end if;
5672
5673             --  In all cases, set the corresponding integer field
5674
5675             Set_Corresponding_Integer_Value (N, Cint);
5676          end;
5677       end if;
5678
5679       --  Now replace the actual type by the expected type as usual
5680
5681       Set_Etype (N, Typ);
5682       Eval_Real_Literal (N);
5683    end Resolve_Real_Literal;
5684
5685    -----------------------
5686    -- Resolve_Reference --
5687    -----------------------
5688
5689    procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
5690       P : constant Node_Id := Prefix (N);
5691
5692    begin
5693       --  Replace general access with specific type
5694
5695       if Ekind (Etype (N)) = E_Allocator_Type then
5696          Set_Etype (N, Base_Type (Typ));
5697       end if;
5698
5699       Resolve (P, Designated_Type (Etype (N)));
5700
5701       --  If we are taking the reference of a volatile entity, then treat
5702       --  it as a potential modification of this entity. This is much too
5703       --  conservative, but is necessary because remove side effects can
5704       --  result in transformations of normal assignments into reference
5705       --  sequences that otherwise fail to notice the modification.
5706
5707       if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
5708          Note_Possible_Modification (P);
5709       end if;
5710    end Resolve_Reference;
5711
5712    --------------------------------
5713    -- Resolve_Selected_Component --
5714    --------------------------------
5715
5716    procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
5717       Comp  : Entity_Id;
5718       Comp1 : Entity_Id        := Empty; -- prevent junk warning
5719       P     : constant Node_Id := Prefix  (N);
5720       S     : constant Node_Id := Selector_Name (N);
5721       T     : Entity_Id        := Etype (P);
5722       I     : Interp_Index;
5723       I1    : Interp_Index := 0; -- prevent junk warning
5724       It    : Interp;
5725       It1   : Interp;
5726       Found : Boolean;
5727
5728       function Init_Component return Boolean;
5729       --  Check whether this is the initialization of a component within an
5730       --  init proc (by assignment or call to another init proc). If true,
5731       --  there is no need for a discriminant check.
5732
5733       --------------------
5734       -- Init_Component --
5735       --------------------
5736
5737       function Init_Component return Boolean is
5738       begin
5739          return Inside_Init_Proc
5740            and then Nkind (Prefix (N)) = N_Identifier
5741            and then Chars (Prefix (N)) = Name_uInit
5742            and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
5743       end Init_Component;
5744
5745    --  Start of processing for Resolve_Selected_Component
5746
5747    begin
5748       if Is_Overloaded (P) then
5749
5750          --  Use the context type to select the prefix that has a selector
5751          --  of the correct name and type.
5752
5753          Found := False;
5754          Get_First_Interp (P, I, It);
5755
5756          Search : while Present (It.Typ) loop
5757             if Is_Access_Type (It.Typ) then
5758                T := Designated_Type (It.Typ);
5759             else
5760                T := It.Typ;
5761             end if;
5762
5763             if Is_Record_Type (T) then
5764                Comp := First_Entity (T);
5765
5766                while Present (Comp) loop
5767
5768                   if Chars (Comp) = Chars (S)
5769                     and then Covers (Etype (Comp), Typ)
5770                   then
5771                      if not Found then
5772                         Found := True;
5773                         I1  := I;
5774                         It1 := It;
5775                         Comp1 := Comp;
5776
5777                      else
5778                         It := Disambiguate (P, I1, I, Any_Type);
5779
5780                         if It = No_Interp then
5781                            Error_Msg_N
5782                              ("ambiguous prefix for selected component",  N);
5783                            Set_Etype (N, Typ);
5784                            return;
5785
5786                         else
5787                            It1 := It;
5788
5789                            if Scope (Comp1) /= It1.Typ then
5790
5791                               --  Resolution chooses the new interpretation.
5792                               --  Find the component with the right name.
5793
5794                               Comp1 := First_Entity (It1.Typ);
5795
5796                               while Present (Comp1)
5797                                 and then Chars (Comp1) /= Chars (S)
5798                               loop
5799                                  Comp1 := Next_Entity (Comp1);
5800                               end loop;
5801                            end if;
5802
5803                            exit Search;
5804                         end if;
5805                      end if;
5806                   end if;
5807
5808                   Comp := Next_Entity (Comp);
5809                end loop;
5810
5811             end if;
5812
5813             Get_Next_Interp (I, It);
5814          end loop Search;
5815
5816          Resolve (P, It1.Typ);
5817          Set_Etype (N, Typ);
5818          Set_Entity (S, Comp1);
5819
5820       else
5821          --  Resolve prefix with its type
5822
5823          Resolve (P, T);
5824       end if;
5825
5826       --  Deal with access type case
5827
5828       if Is_Access_Type (Etype (P)) then
5829          Apply_Access_Check (N);
5830          T := Designated_Type (Etype (P));
5831       else
5832          T := Etype (P);
5833       end if;
5834
5835       if Has_Discriminants (T)
5836         and then (Ekind (Entity (S)) = E_Component
5837                    or else
5838                   Ekind (Entity (S)) = E_Discriminant)
5839         and then Present (Original_Record_Component (Entity (S)))
5840         and then Ekind (Original_Record_Component (Entity (S))) = E_Component
5841         and then Present (Discriminant_Checking_Func
5842                            (Original_Record_Component (Entity (S))))
5843         and then not Discriminant_Checks_Suppressed (T)
5844         and then not Init_Component
5845       then
5846          Set_Do_Discriminant_Check (N);
5847       end if;
5848
5849       if Ekind (Entity (S)) = E_Void then
5850          Error_Msg_N ("premature use of component", S);
5851       end if;
5852
5853       --  If the prefix is a record conversion, this may be a renamed
5854       --  discriminant whose bounds differ from those of the original
5855       --  one, so we must ensure that a range check is performed.
5856
5857       if Nkind (P) = N_Type_Conversion
5858         and then Ekind (Entity (S)) = E_Discriminant
5859         and then Is_Discrete_Type (Typ)
5860       then
5861          Set_Etype (N, Base_Type (Typ));
5862       end if;
5863
5864       --  Note: No Eval processing is required, because the prefix is of a
5865       --  record type, or protected type, and neither can possibly be static.
5866
5867    end Resolve_Selected_Component;
5868
5869    -------------------
5870    -- Resolve_Shift --
5871    -------------------
5872
5873    procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
5874       B_Typ : constant Entity_Id := Base_Type (Typ);
5875       L     : constant Node_Id   := Left_Opnd  (N);
5876       R     : constant Node_Id   := Right_Opnd (N);
5877
5878    begin
5879       --  We do the resolution using the base type, because intermediate values
5880       --  in expressions always are of the base type, not a subtype of it.
5881
5882       Resolve (L, B_Typ);
5883       Resolve (R, Standard_Natural);
5884
5885       Check_Unset_Reference (L);
5886       Check_Unset_Reference (R);
5887
5888       Set_Etype (N, B_Typ);
5889       Generate_Operator_Reference (N, B_Typ);
5890       Eval_Shift (N);
5891    end Resolve_Shift;
5892
5893    ---------------------------
5894    -- Resolve_Short_Circuit --
5895    ---------------------------
5896
5897    procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
5898       B_Typ : constant Entity_Id := Base_Type (Typ);
5899       L     : constant Node_Id   := Left_Opnd  (N);
5900       R     : constant Node_Id   := Right_Opnd (N);
5901
5902    begin
5903       Resolve (L, B_Typ);
5904       Resolve (R, B_Typ);
5905
5906       Check_Unset_Reference (L);
5907       Check_Unset_Reference (R);
5908
5909       Set_Etype (N, B_Typ);
5910       Eval_Short_Circuit (N);
5911    end Resolve_Short_Circuit;
5912
5913    -------------------
5914    -- Resolve_Slice --
5915    -------------------
5916
5917    procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
5918       Name       : constant Node_Id := Prefix (N);
5919       Drange     : constant Node_Id := Discrete_Range (N);
5920       Array_Type : Entity_Id        := Empty;
5921       Index      : Node_Id;
5922
5923    begin
5924       if Is_Overloaded (Name) then
5925
5926          --  Use the context type to select the prefix that yields the
5927          --  correct array type.
5928
5929          declare
5930             I      : Interp_Index;
5931             I1     : Interp_Index := 0;
5932             It     : Interp;
5933             P      : constant Node_Id := Prefix (N);
5934             Found  : Boolean := False;
5935
5936          begin
5937             Get_First_Interp (P, I,  It);
5938
5939             while Present (It.Typ) loop
5940
5941                if (Is_Array_Type (It.Typ)
5942                     and then Covers (Typ,  It.Typ))
5943                  or else (Is_Access_Type (It.Typ)
5944                            and then Is_Array_Type (Designated_Type (It.Typ))
5945                            and then Covers (Typ, Designated_Type (It.Typ)))
5946                then
5947                   if Found then
5948                      It := Disambiguate (P, I1, I, Any_Type);
5949
5950                      if It = No_Interp then
5951                         Error_Msg_N ("ambiguous prefix for slicing",  N);
5952                         Set_Etype (N, Typ);
5953                         return;
5954                      else
5955                         Found := True;
5956                         Array_Type := It.Typ;
5957                         I1 := I;
5958                      end if;
5959                   else
5960                      Found := True;
5961                      Array_Type := It.Typ;
5962                      I1 := I;
5963                   end if;
5964                end if;
5965
5966                Get_Next_Interp (I, It);
5967             end loop;
5968          end;
5969
5970       else
5971          Array_Type := Etype (Name);
5972       end if;
5973
5974       Resolve (Name, Array_Type);
5975
5976       if Is_Access_Type (Array_Type) then
5977          Apply_Access_Check (N);
5978          Array_Type := Designated_Type (Array_Type);
5979
5980       elsif Is_Entity_Name (Name)
5981         or else (Nkind (Name) = N_Function_Call
5982                   and then not Is_Constrained (Etype (Name)))
5983       then
5984          Array_Type := Get_Actual_Subtype (Name);
5985       end if;
5986
5987       --  If name was overloaded, set slice type correctly now
5988
5989       Set_Etype (N, Array_Type);
5990
5991       --  If the range is specified by a subtype mark, no resolution
5992       --  is necessary.
5993
5994       if not Is_Entity_Name (Drange) then
5995          Index := First_Index (Array_Type);
5996          Resolve (Drange, Base_Type (Etype (Index)));
5997
5998          if Nkind (Drange) = N_Range then
5999             Apply_Range_Check (Drange, Etype (Index));
6000          end if;
6001       end if;
6002
6003       Set_Slice_Subtype (N);
6004       Eval_Slice (N);
6005    end Resolve_Slice;
6006
6007    ----------------------------
6008    -- Resolve_String_Literal --
6009    ----------------------------
6010
6011    procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
6012       C_Typ      : constant Entity_Id  := Component_Type (Typ);
6013       R_Typ      : constant Entity_Id  := Root_Type (C_Typ);
6014       Loc        : constant Source_Ptr := Sloc (N);
6015       Str        : constant String_Id  := Strval (N);
6016       Strlen     : constant Nat        := String_Length (Str);
6017       Subtype_Id : Entity_Id;
6018       Need_Check : Boolean;
6019
6020    begin
6021       --  For a string appearing in a concatenation, defer creation of the
6022       --  string_literal_subtype until the end of the resolution of the
6023       --  concatenation, because the literal may be constant-folded away.
6024       --  This is a useful optimization for long concatenation expressions.
6025
6026       --  If the string is an aggregate built for a single character  (which
6027       --  happens in a non-static context) or a is null string to which special
6028       --  checks may apply, we build the subtype. Wide strings must also get
6029       --  a string subtype if they come from a one character aggregate. Strings
6030       --  generated by attributes might be static, but it is often hard to
6031       --  determine whether the enclosing context is static, so we generate
6032       --  subtypes for them as well, thus losing some rarer optimizations ???
6033       --  Same for strings that come from a static conversion.
6034
6035       Need_Check :=
6036         (Strlen = 0 and then Typ /= Standard_String)
6037           or else Nkind (Parent (N)) /= N_Op_Concat
6038           or else (N /= Left_Opnd (Parent (N))
6039                     and then N /= Right_Opnd (Parent (N)))
6040           or else (Typ = Standard_Wide_String
6041                     and then Nkind (Original_Node (N)) /= N_String_Literal);
6042
6043       --  If the resolving type is itself a string literal subtype, we
6044       --  can just reuse it, since there is no point in creating another.
6045
6046       if Ekind (Typ) = E_String_Literal_Subtype then
6047          Subtype_Id := Typ;
6048
6049       elsif Nkind (Parent (N)) = N_Op_Concat
6050         and then not Need_Check
6051         and then Nkind (Original_Node (N)) /= N_Character_Literal
6052         and then Nkind (Original_Node (N)) /= N_Attribute_Reference
6053         and then Nkind (Original_Node (N)) /= N_Qualified_Expression
6054         and then Nkind (Original_Node (N)) /= N_Type_Conversion
6055       then
6056          Subtype_Id := Typ;
6057
6058       --  Otherwise we must create a string literal subtype. Note that the
6059       --  whole idea of string literal subtypes is simply to avoid the need
6060       --  for building a full fledged array subtype for each literal.
6061       else
6062          Set_String_Literal_Subtype (N, Typ);
6063          Subtype_Id := Etype (N);
6064       end if;
6065
6066       if Nkind (Parent (N)) /= N_Op_Concat
6067         or else Need_Check
6068       then
6069          Set_Etype (N, Subtype_Id);
6070          Eval_String_Literal (N);
6071       end if;
6072
6073       if Is_Limited_Composite (Typ)
6074         or else Is_Private_Composite (Typ)
6075       then
6076          Error_Msg_N ("string literal not available for private array", N);
6077          Set_Etype (N, Any_Type);
6078          return;
6079       end if;
6080
6081       --  The validity of a null string has been checked in the
6082       --  call to  Eval_String_Literal.
6083
6084       if Strlen = 0 then
6085          return;
6086
6087       --  Always accept string literal with component type Any_Character,
6088       --  which occurs in error situations and in comparisons of literals,
6089       --  both of which should accept all literals.
6090
6091       elsif R_Typ = Any_Character then
6092          return;
6093
6094       --  If the type is bit-packed, then we always tranform the string
6095       --  literal into a full fledged aggregate.
6096
6097       elsif Is_Bit_Packed_Array (Typ) then
6098          null;
6099
6100       --  Deal with cases of Wide_String and String
6101
6102       else
6103          --  For Standard.Wide_String, or any other type whose component
6104          --  type is Standard.Wide_Character, we know that all the
6105          --  characters in the string must be acceptable, since the parser
6106          --  accepted the characters as valid character literals.
6107
6108          if R_Typ = Standard_Wide_Character then
6109             null;
6110
6111          --  For the case of Standard.String, or any other type whose
6112          --  component type is Standard.Character, we must make sure that
6113          --  there are no wide characters in the string, i.e. that it is
6114          --  entirely composed of characters in range of type String.
6115
6116          --  If the string literal is the result of a static concatenation,
6117          --  the test has already been performed on the components, and need
6118          --  not be repeated.
6119
6120          elsif R_Typ = Standard_Character
6121            and then Nkind (Original_Node (N)) /= N_Op_Concat
6122          then
6123             for J in 1 .. Strlen loop
6124                if not In_Character_Range (Get_String_Char (Str, J)) then
6125
6126                   --  If we are out of range, post error. This is one of the
6127                   --  very few places that we place the flag in the middle of
6128                   --  a token, right under the offending wide character.
6129
6130                   Error_Msg
6131                     ("literal out of range of type Character",
6132                      Source_Ptr (Int (Loc) + J));
6133                   return;
6134                end if;
6135             end loop;
6136
6137          --  If the root type is not a standard character, then we will convert
6138          --  the string into an aggregate and will let the aggregate code do
6139          --  the checking.
6140
6141          else
6142             null;
6143
6144          end if;
6145
6146          --  See if the component type of the array corresponding to the
6147          --  string has compile time known bounds. If yes we can directly
6148          --  check whether the evaluation of the string will raise constraint
6149          --  error. Otherwise we need to transform the string literal into
6150          --  the corresponding character aggregate and let the aggregate
6151          --  code do the checking.
6152
6153          if R_Typ = Standard_Wide_Character
6154            or else R_Typ = Standard_Character
6155          then
6156             --  Check for the case of full range, where we are definitely OK
6157
6158             if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
6159                return;
6160             end if;
6161
6162             --  Here the range is not the complete base type range, so check
6163
6164             declare
6165                Comp_Typ_Lo : constant Node_Id :=
6166                                Type_Low_Bound (Component_Type (Typ));
6167                Comp_Typ_Hi : constant Node_Id :=
6168                                Type_High_Bound (Component_Type (Typ));
6169
6170                Char_Val : Uint;
6171
6172             begin
6173                if Compile_Time_Known_Value (Comp_Typ_Lo)
6174                  and then Compile_Time_Known_Value (Comp_Typ_Hi)
6175                then
6176                   for J in 1 .. Strlen loop
6177                      Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
6178
6179                      if Char_Val < Expr_Value (Comp_Typ_Lo)
6180                        or else Char_Val > Expr_Value (Comp_Typ_Hi)
6181                      then
6182                         Apply_Compile_Time_Constraint_Error
6183                           (N, "character out of range?", CE_Range_Check_Failed,
6184                            Loc => Source_Ptr (Int (Loc) + J));
6185                      end if;
6186                   end loop;
6187
6188                   return;
6189                end if;
6190             end;
6191          end if;
6192       end if;
6193
6194       --  If we got here we meed to transform the string literal into the
6195       --  equivalent qualified positional array aggregate. This is rather
6196       --  heavy artillery for this situation, but it is hard work to avoid.
6197
6198       declare
6199          Lits : constant List_Id    := New_List;
6200          P    : Source_Ptr := Loc + 1;
6201          C    : Char_Code;
6202
6203       begin
6204          --  Build the character literals, we give them source locations
6205          --  that correspond to the string positions, which is a bit tricky
6206          --  given the possible presence of wide character escape sequences.
6207
6208          for J in 1 .. Strlen loop
6209             C := Get_String_Char (Str, J);
6210             Set_Character_Literal_Name (C);
6211
6212             Append_To (Lits,
6213               Make_Character_Literal (P, Name_Find, C));
6214
6215             if In_Character_Range (C) then
6216                P := P + 1;
6217
6218             --  Should we have a call to Skip_Wide here ???
6219             --  ???     else
6220             --             Skip_Wide (P);
6221
6222             end if;
6223          end loop;
6224
6225          Rewrite (N,
6226            Make_Qualified_Expression (Loc,
6227              Subtype_Mark => New_Reference_To (Typ, Loc),
6228              Expression   =>
6229                Make_Aggregate (Loc, Expressions => Lits)));
6230
6231          Analyze_And_Resolve (N, Typ);
6232       end;
6233    end Resolve_String_Literal;
6234
6235    -----------------------------
6236    -- Resolve_Subprogram_Info --
6237    -----------------------------
6238
6239    procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
6240    begin
6241       Set_Etype (N, Typ);
6242    end Resolve_Subprogram_Info;
6243
6244    -----------------------------
6245    -- Resolve_Type_Conversion --
6246    -----------------------------
6247
6248    procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
6249       Target_Type : constant Entity_Id := Etype (N);
6250       Conv_OK     : constant Boolean   := Conversion_OK (N);
6251       Operand     : Node_Id;
6252       Opnd_Type   : Entity_Id;
6253       Rop         : Node_Id;
6254       Orig_N      : Node_Id;
6255       Orig_T      : Node_Id;
6256
6257    begin
6258       Operand := Expression (N);
6259
6260       if not Conv_OK
6261         and then not Valid_Conversion (N, Target_Type, Operand)
6262       then
6263          return;
6264       end if;
6265
6266       if Etype (Operand) = Any_Fixed then
6267
6268          --  Mixed-mode operation involving a literal. Context must be a fixed
6269          --  type which is applied to the literal subsequently.
6270
6271          if Is_Fixed_Point_Type (Typ) then
6272             Set_Etype (Operand, Universal_Real);
6273
6274          elsif Is_Numeric_Type (Typ)
6275            and then (Nkind (Operand) = N_Op_Multiply
6276                       or else Nkind (Operand) = N_Op_Divide)
6277            and then (Etype (Right_Opnd (Operand)) = Universal_Real
6278                      or else Etype (Left_Opnd (Operand)) = Universal_Real)
6279          then
6280             if Unique_Fixed_Point_Type (N) = Any_Type then
6281                return;    --  expression is ambiguous.
6282             else
6283                Set_Etype (Operand, Standard_Duration);
6284             end if;
6285
6286             if Etype (Right_Opnd (Operand)) = Universal_Real then
6287                Rop := New_Copy_Tree (Right_Opnd (Operand));
6288             else
6289                Rop := New_Copy_Tree (Left_Opnd (Operand));
6290             end if;
6291
6292             Resolve (Rop, Standard_Long_Long_Float);
6293
6294             if Realval (Rop) /= Ureal_0
6295               and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
6296             then
6297                Error_Msg_N ("universal real operand can only be interpreted?",
6298                  Rop);
6299                Error_Msg_N ("\as Duration, and will lose precision?", Rop);
6300             end if;
6301
6302          elsif Is_Numeric_Type (Typ)
6303            and then Nkind (Operand) in N_Op
6304            and then Unique_Fixed_Point_Type (N) /= Any_Type
6305          then
6306             Set_Etype (Operand, Standard_Duration);
6307
6308          else
6309             Error_Msg_N ("invalid context for mixed mode operation", N);
6310             Set_Etype (Operand, Any_Type);
6311             return;
6312          end if;
6313       end if;
6314
6315       Opnd_Type := Etype (Operand);
6316       Resolve (Operand);
6317
6318       --  Note: we do the Eval_Type_Conversion call before applying the
6319       --  required checks for a subtype conversion. This is important,
6320       --  since both are prepared under certain circumstances to change
6321       --  the type conversion to a constraint error node, but in the case
6322       --  of Eval_Type_Conversion this may reflect an illegality in the
6323       --  static case, and we would miss the illegality (getting only a
6324       --  warning message), if we applied the type conversion checks first.
6325
6326       Eval_Type_Conversion (N);
6327
6328       --  If after evaluation, we still have a type conversion, then we
6329       --  may need to apply checks required for a subtype conversion.
6330
6331       --  Skip these type conversion checks if universal fixed operands
6332       --  operands involved, since range checks are handled separately for
6333       --  these cases (in the appropriate Expand routines in unit Exp_Fixd).
6334
6335       if Nkind (N) = N_Type_Conversion
6336         and then not Is_Generic_Type (Root_Type (Target_Type))
6337         and then Target_Type /= Universal_Fixed
6338         and then Opnd_Type /= Universal_Fixed
6339       then
6340          Apply_Type_Conversion_Checks (N);
6341       end if;
6342
6343       --  Issue warning for conversion of simple object to its own type
6344       --  We have to test the original nodes, since they may have been
6345       --  rewritten by various optimizations.
6346
6347       Orig_N := Original_Node (N);
6348
6349       if Warn_On_Redundant_Constructs
6350         and then Comes_From_Source (Orig_N)
6351         and then Nkind (Orig_N) = N_Type_Conversion
6352         and then not In_Instance
6353       then
6354          Orig_N := Original_Node (Expression (Orig_N));
6355          Orig_T := Target_Type;
6356
6357          --  If the node is part of a larger expression, the Target_Type
6358          --  may not be the original type of the node if the context is a
6359          --  condition. Recover original type to see if conversion is needed.
6360
6361          if Is_Boolean_Type (Orig_T)
6362           and then Nkind (Parent (N)) in N_Op
6363          then
6364             Orig_T := Etype (Parent (N));
6365          end if;
6366
6367          if Is_Entity_Name (Orig_N)
6368            and then Etype (Entity (Orig_N)) = Orig_T
6369          then
6370             Error_Msg_NE
6371               ("?useless conversion, & has this type", N, Entity (Orig_N));
6372          end if;
6373       end if;
6374    end Resolve_Type_Conversion;
6375
6376    ----------------------
6377    -- Resolve_Unary_Op --
6378    ----------------------
6379
6380    procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
6381       B_Typ : constant Entity_Id := Base_Type (Typ);
6382       R     : constant Node_Id   := Right_Opnd (N);
6383       OK    : Boolean;
6384       Lo    : Uint;
6385       Hi    : Uint;
6386
6387    begin
6388       --  Generate warning for expressions like abs (x mod 2)
6389
6390       if Warn_On_Redundant_Constructs
6391         and then Nkind (N) = N_Op_Abs
6392       then
6393          Determine_Range (Right_Opnd (N), OK, Lo, Hi);
6394
6395          if OK and then Hi >= Lo and then Lo >= 0 then
6396             Error_Msg_N
6397              ("?abs applied to known non-negative value has no effect", N);
6398          end if;
6399       end if;
6400
6401       --  Generate warning for expressions like -5 mod 3
6402
6403       if Paren_Count (N) = 0
6404         and then Nkind (N) = N_Op_Minus
6405         and then Nkind (Right_Opnd (N)) = N_Op_Mod
6406         and then Comes_From_Source (N)
6407       then
6408          Error_Msg_N
6409            ("?unary minus expression should be parenthesized here", N);
6410       end if;
6411
6412       if Comes_From_Source (N)
6413         and then Ekind (Entity (N)) = E_Function
6414         and then Is_Imported (Entity (N))
6415         and then Is_Intrinsic_Subprogram (Entity (N))
6416       then
6417          Resolve_Intrinsic_Unary_Operator (N, Typ);
6418          return;
6419       end if;
6420
6421       if Etype (R) = Universal_Integer
6422            or else Etype (R) = Universal_Real
6423       then
6424          Check_For_Visible_Operator (N, B_Typ);
6425       end if;
6426
6427       Set_Etype (N, B_Typ);
6428       Resolve (R, B_Typ);
6429
6430       Check_Unset_Reference (R);
6431       Generate_Operator_Reference (N, B_Typ);
6432       Eval_Unary_Op (N);
6433
6434       --  Set overflow checking bit. Much cleverer code needed here eventually
6435       --  and perhaps the Resolve routines should be separated for the various
6436       --  arithmetic operations, since they will need different processing ???
6437
6438       if Nkind (N) in N_Op then
6439          if not Overflow_Checks_Suppressed (Etype (N)) then
6440             Enable_Overflow_Check (N);
6441          end if;
6442       end if;
6443    end Resolve_Unary_Op;
6444
6445    ----------------------------------
6446    -- Resolve_Unchecked_Expression --
6447    ----------------------------------
6448
6449    procedure Resolve_Unchecked_Expression
6450      (N   : Node_Id;
6451       Typ : Entity_Id)
6452    is
6453    begin
6454       Resolve (Expression (N), Typ, Suppress => All_Checks);
6455       Set_Etype (N, Typ);
6456    end Resolve_Unchecked_Expression;
6457
6458    ---------------------------------------
6459    -- Resolve_Unchecked_Type_Conversion --
6460    ---------------------------------------
6461
6462    procedure Resolve_Unchecked_Type_Conversion
6463      (N   : Node_Id;
6464       Typ : Entity_Id)
6465    is
6466       pragma Warnings (Off, Typ);
6467
6468       Operand   : constant Node_Id   := Expression (N);
6469       Opnd_Type : constant Entity_Id := Etype (Operand);
6470
6471    begin
6472       --  Resolve operand using its own type.
6473
6474       Resolve (Operand, Opnd_Type);
6475       Eval_Unchecked_Conversion (N);
6476
6477    end Resolve_Unchecked_Type_Conversion;
6478
6479    ------------------------------
6480    -- Rewrite_Operator_As_Call --
6481    ------------------------------
6482
6483    procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
6484       Loc     : constant Source_Ptr := Sloc (N);
6485       Actuals : constant List_Id    := New_List;
6486       New_N   : Node_Id;
6487
6488    begin
6489       if Nkind (N) in  N_Binary_Op then
6490          Append (Left_Opnd (N), Actuals);
6491       end if;
6492
6493       Append (Right_Opnd (N), Actuals);
6494
6495       New_N :=
6496         Make_Function_Call (Sloc => Loc,
6497           Name => New_Occurrence_Of (Nam, Loc),
6498           Parameter_Associations => Actuals);
6499
6500       Preserve_Comes_From_Source (New_N, N);
6501       Preserve_Comes_From_Source (Name (New_N), N);
6502       Rewrite (N, New_N);
6503       Set_Etype (N, Etype (Nam));
6504    end Rewrite_Operator_As_Call;
6505
6506    ------------------------------
6507    -- Rewrite_Renamed_Operator --
6508    ------------------------------
6509
6510    procedure Rewrite_Renamed_Operator
6511      (N   : Node_Id;
6512       Op  : Entity_Id;
6513       Typ : Entity_Id)
6514    is
6515       Nam       : constant Name_Id := Chars (Op);
6516       Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
6517       Op_Node   : Node_Id;
6518
6519    begin
6520       --  Rewrite the operator node using the real operator, not its
6521       --  renaming. Exclude user-defined intrinsic operations of the same
6522       --  name, which are treated separately and rewritten as calls.
6523
6524       if Ekind (Op) /= E_Function
6525         or else Chars (N) /= Nam
6526       then
6527          Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
6528          Set_Chars      (Op_Node, Nam);
6529          Set_Etype      (Op_Node, Etype (N));
6530          Set_Entity     (Op_Node, Op);
6531          Set_Right_Opnd (Op_Node, Right_Opnd (N));
6532
6533          --  Indicate that both the original entity and its renaming
6534          --  are referenced at this point.
6535
6536          Generate_Reference (Entity (N), N);
6537          Generate_Reference (Op, N);
6538
6539          if Is_Binary then
6540             Set_Left_Opnd  (Op_Node, Left_Opnd  (N));
6541          end if;
6542
6543          Rewrite (N, Op_Node);
6544
6545          --  If the context type is private, add the appropriate conversions
6546          --  so that the operator is applied to the full view. This is done
6547          --  in the routines that resolve intrinsic operators,
6548
6549          if Is_Intrinsic_Subprogram (Op)
6550            and then Is_Private_Type (Typ)
6551          then
6552             case Nkind (N) is
6553                when N_Op_Add   | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
6554                     N_Op_Expon | N_Op_Mod      | N_Op_Rem      =>
6555                   Resolve_Intrinsic_Operator (N, Typ);
6556
6557                when N_Op_Plus | N_Op_Minus    | N_Op_Abs      =>
6558                   Resolve_Intrinsic_Unary_Operator (N, Typ);
6559
6560                when others =>
6561                   Resolve (N, Typ);
6562             end case;
6563          end if;
6564
6565       elsif Ekind (Op) = E_Function
6566         and then Is_Intrinsic_Subprogram (Op)
6567       then
6568          --  Operator renames a user-defined operator of the same name. Use
6569          --  the original operator in the node, which is the one that gigi
6570          --  knows about.
6571
6572          Set_Entity (N, Op);
6573          Set_Is_Overloaded (N, False);
6574       end if;
6575    end Rewrite_Renamed_Operator;
6576
6577    -----------------------
6578    -- Set_Slice_Subtype --
6579    -----------------------
6580
6581    --  Build an implicit subtype declaration to represent the type delivered
6582    --  by the slice. This is an abbreviated version of an array subtype. We
6583    --  define an index subtype for the slice,  using either the subtype name
6584    --  or the discrete range of the slice. To be consistent with index usage
6585    --  elsewhere, we create a list header to hold the single index. This list
6586    --  is not otherwise attached to the syntax tree.
6587
6588    procedure Set_Slice_Subtype (N : Node_Id) is
6589       Loc           : constant Source_Ptr := Sloc (N);
6590       Index_List    : constant List_Id    := New_List;
6591       Index         : Node_Id;
6592       Index_Subtype : Entity_Id;
6593       Index_Type    : Entity_Id;
6594       Slice_Subtype : Entity_Id;
6595       Drange        : constant Node_Id := Discrete_Range (N);
6596
6597    begin
6598       if Is_Entity_Name (Drange) then
6599          Index_Subtype := Entity (Drange);
6600
6601       else
6602          --  We force the evaluation of a range. This is definitely needed in
6603          --  the renamed case, and seems safer to do unconditionally. Note in
6604          --  any case that since we will create and insert an Itype referring
6605          --  to this range, we must make sure any side effect removal actions
6606          --  are inserted before the Itype definition.
6607
6608          if Nkind (Drange) = N_Range then
6609             Force_Evaluation (Low_Bound (Drange));
6610             Force_Evaluation (High_Bound (Drange));
6611          end if;
6612
6613          Index_Type := Base_Type (Etype (Drange));
6614
6615          Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
6616
6617          Set_Scalar_Range (Index_Subtype, Drange);
6618          Set_Etype        (Index_Subtype, Index_Type);
6619          Set_Size_Info    (Index_Subtype, Index_Type);
6620          Set_RM_Size      (Index_Subtype, RM_Size (Index_Type));
6621       end if;
6622
6623       Slice_Subtype := Create_Itype (E_Array_Subtype, N);
6624
6625       Index := New_Occurrence_Of (Index_Subtype, Loc);
6626       Set_Etype (Index, Index_Subtype);
6627       Append (Index, Index_List);
6628
6629       Set_First_Index    (Slice_Subtype, Index);
6630       Set_Etype          (Slice_Subtype, Base_Type (Etype (N)));
6631       Set_Is_Constrained (Slice_Subtype, True);
6632       Init_Size_Align    (Slice_Subtype);
6633
6634       Check_Compile_Time_Size (Slice_Subtype);
6635
6636       --  The Etype of the existing Slice node is reset to this slice
6637       --  subtype. Its bounds are obtained from its first index.
6638
6639       Set_Etype (N, Slice_Subtype);
6640
6641       --  In the packed case, this must be immediately frozen
6642
6643       --  Couldn't we always freeze here??? and if we did, then the above
6644       --  call to Check_Compile_Time_Size could be eliminated, which would
6645       --  be nice, because then that routine could be made private to Freeze.
6646
6647       if Is_Packed (Slice_Subtype) and not In_Default_Expression then
6648          Freeze_Itype (Slice_Subtype, N);
6649       end if;
6650
6651    end Set_Slice_Subtype;
6652
6653    --------------------------------
6654    -- Set_String_Literal_Subtype --
6655    --------------------------------
6656
6657    procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
6658       Subtype_Id : Entity_Id;
6659
6660    begin
6661       if Nkind (N) /= N_String_Literal then
6662          return;
6663       else
6664          Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
6665       end if;
6666
6667       Set_String_Literal_Length (Subtype_Id, UI_From_Int
6668                                                (String_Length (Strval (N))));
6669       Set_Etype                 (Subtype_Id, Base_Type (Typ));
6670       Set_Is_Constrained        (Subtype_Id);
6671
6672       --  The low bound is set from the low bound of the corresponding
6673       --  index type. Note that we do not store the high bound in the
6674       --  string literal subtype, but it can be deduced if necssary
6675       --  from the length and the low bound.
6676
6677       Set_String_Literal_Low_Bound
6678         (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
6679
6680       Set_Etype (N, Subtype_Id);
6681    end Set_String_Literal_Subtype;
6682
6683    -----------------------------
6684    -- Unique_Fixed_Point_Type --
6685    -----------------------------
6686
6687    function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
6688       T1   : Entity_Id := Empty;
6689       T2   : Entity_Id;
6690       Item : Node_Id;
6691       Scop : Entity_Id;
6692
6693       procedure Fixed_Point_Error;
6694       --  If true ambiguity, give details.
6695
6696       procedure Fixed_Point_Error is
6697       begin
6698          Error_Msg_N ("ambiguous universal_fixed_expression", N);
6699          Error_Msg_NE ("\possible interpretation as}", N, T1);
6700          Error_Msg_NE ("\possible interpretation as}", N, T2);
6701       end Fixed_Point_Error;
6702
6703    begin
6704       --  The operations on Duration are visible, so Duration is always a
6705       --  possible interpretation.
6706
6707       T1 := Standard_Duration;
6708
6709       --  Look for fixed-point types in enclosing scopes.
6710
6711       Scop := Current_Scope;
6712       while Scop /= Standard_Standard loop
6713          T2 := First_Entity (Scop);
6714
6715          while Present (T2) loop
6716             if Is_Fixed_Point_Type (T2)
6717               and then Current_Entity (T2) = T2
6718               and then Scope (Base_Type (T2)) = Scop
6719             then
6720                if Present (T1) then
6721                   Fixed_Point_Error;
6722                   return Any_Type;
6723                else
6724                   T1 := T2;
6725                end if;
6726             end if;
6727
6728             Next_Entity (T2);
6729          end loop;
6730
6731          Scop := Scope (Scop);
6732       end loop;
6733
6734       --  Look for visible fixed type declarations in the context.
6735
6736       Item := First (Context_Items (Cunit (Current_Sem_Unit)));
6737       while Present (Item) loop
6738          if Nkind (Item) = N_With_Clause then
6739             Scop := Entity (Name (Item));
6740             T2 := First_Entity (Scop);
6741
6742             while Present (T2) loop
6743                if Is_Fixed_Point_Type (T2)
6744                  and then Scope (Base_Type (T2)) = Scop
6745                  and then (Is_Potentially_Use_Visible (T2)
6746                              or else In_Use (T2))
6747                then
6748                   if Present (T1) then
6749                      Fixed_Point_Error;
6750                      return Any_Type;
6751                   else
6752                      T1 := T2;
6753                   end if;
6754                end if;
6755
6756                Next_Entity (T2);
6757             end loop;
6758          end if;
6759
6760          Next (Item);
6761       end loop;
6762
6763       if Nkind (N) = N_Real_Literal then
6764          Error_Msg_NE ("real literal interpreted as }?", N, T1);
6765
6766       else
6767          Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1);
6768       end if;
6769
6770       return T1;
6771    end Unique_Fixed_Point_Type;
6772
6773    ----------------------
6774    -- Valid_Conversion --
6775    ----------------------
6776
6777    function Valid_Conversion
6778      (N       : Node_Id;
6779       Target  : Entity_Id;
6780       Operand : Node_Id) return Boolean
6781    is
6782       Target_Type : constant Entity_Id := Base_Type (Target);
6783       Opnd_Type   : Entity_Id := Etype (Operand);
6784
6785       function Conversion_Check
6786         (Valid : Boolean;
6787          Msg   : String) return Boolean;
6788       --  Little routine to post Msg if Valid is False, returns Valid value
6789
6790       function Valid_Tagged_Conversion
6791         (Target_Type : Entity_Id;
6792          Opnd_Type   : Entity_Id) return Boolean;
6793       --  Specifically test for validity of tagged conversions
6794
6795       ----------------------
6796       -- Conversion_Check --
6797       ----------------------
6798
6799       function Conversion_Check
6800         (Valid : Boolean;
6801          Msg   : String) return Boolean
6802       is
6803       begin
6804          if not Valid then
6805             Error_Msg_N (Msg, Operand);
6806          end if;
6807
6808          return Valid;
6809       end Conversion_Check;
6810
6811       -----------------------------
6812       -- Valid_Tagged_Conversion --
6813       -----------------------------
6814
6815       function Valid_Tagged_Conversion
6816         (Target_Type : Entity_Id;
6817          Opnd_Type   : Entity_Id) return Boolean
6818       is
6819       begin
6820          --  Upward conversions are allowed (RM 4.6(22)).
6821
6822          if Covers (Target_Type, Opnd_Type)
6823            or else Is_Ancestor (Target_Type, Opnd_Type)
6824          then
6825             return True;
6826
6827          --  Downward conversion are allowed if the operand is
6828          --  is class-wide (RM 4.6(23)).
6829
6830          elsif Is_Class_Wide_Type (Opnd_Type)
6831               and then Covers (Opnd_Type, Target_Type)
6832          then
6833             return True;
6834
6835          elsif Covers (Opnd_Type, Target_Type)
6836            or else Is_Ancestor (Opnd_Type, Target_Type)
6837          then
6838             return
6839               Conversion_Check (False,
6840                 "downward conversion of tagged objects not allowed");
6841          else
6842             Error_Msg_NE
6843               ("invalid tagged conversion, not compatible with}",
6844                N, First_Subtype (Opnd_Type));
6845             return False;
6846          end if;
6847       end Valid_Tagged_Conversion;
6848
6849    --  Start of processing for Valid_Conversion
6850
6851    begin
6852       Check_Parameterless_Call (Operand);
6853
6854       if Is_Overloaded (Operand) then
6855          declare
6856             I   : Interp_Index;
6857             I1  : Interp_Index;
6858             It  : Interp;
6859             It1 : Interp;
6860             N1  : Entity_Id;
6861
6862          begin
6863             --  Remove procedure calls, which syntactically cannot appear
6864             --  in this context, but which cannot be removed by type checking,
6865             --  because the context does not impose a type.
6866
6867             Get_First_Interp (Operand, I, It);
6868
6869             while Present (It.Typ) loop
6870
6871                if It.Typ = Standard_Void_Type then
6872                   Remove_Interp (I);
6873                end if;
6874
6875                Get_Next_Interp (I, It);
6876             end loop;
6877
6878             Get_First_Interp (Operand, I, It);
6879             I1  := I;
6880             It1 := It;
6881
6882             if No (It.Typ) then
6883                Error_Msg_N ("illegal operand in conversion", Operand);
6884                return False;
6885             end if;
6886
6887             Get_Next_Interp (I, It);
6888
6889             if Present (It.Typ) then
6890                N1  := It1.Nam;
6891                It1 :=  Disambiguate (Operand, I1, I, Any_Type);
6892
6893                if It1 = No_Interp then
6894                   Error_Msg_N ("ambiguous operand in conversion", Operand);
6895
6896                   Error_Msg_Sloc := Sloc (It.Nam);
6897                   Error_Msg_N ("possible interpretation#!", Operand);
6898
6899                   Error_Msg_Sloc := Sloc (N1);
6900                   Error_Msg_N ("possible interpretation#!", Operand);
6901
6902                   return False;
6903                end if;
6904             end if;
6905
6906             Set_Etype (Operand, It1.Typ);
6907             Opnd_Type := It1.Typ;
6908          end;
6909       end if;
6910
6911       if Chars (Current_Scope) = Name_Unchecked_Conversion then
6912
6913          --  This check is dubious, what if there were a user defined
6914          --  scope whose name was Unchecked_Conversion ???
6915
6916          return True;
6917
6918       elsif Is_Numeric_Type (Target_Type)  then
6919          if Opnd_Type = Universal_Fixed then
6920             return True;
6921
6922          elsif (In_Instance or else In_Inlined_Body)
6923            and then not Comes_From_Source (N)
6924          then
6925             return True;
6926
6927          else
6928             return Conversion_Check (Is_Numeric_Type (Opnd_Type),
6929                              "illegal operand for numeric conversion");
6930          end if;
6931
6932       elsif Is_Array_Type (Target_Type) then
6933          if not Is_Array_Type (Opnd_Type)
6934            or else Opnd_Type = Any_Composite
6935            or else Opnd_Type = Any_String
6936          then
6937             Error_Msg_N
6938               ("illegal operand for array conversion", Operand);
6939             return False;
6940
6941          elsif Number_Dimensions (Target_Type) /=
6942            Number_Dimensions (Opnd_Type)
6943          then
6944             Error_Msg_N
6945               ("incompatible number of dimensions for conversion", Operand);
6946             return False;
6947
6948          else
6949             declare
6950                Target_Index : Node_Id := First_Index (Target_Type);
6951                Opnd_Index   : Node_Id := First_Index (Opnd_Type);
6952
6953                Target_Index_Type : Entity_Id;
6954                Opnd_Index_Type   : Entity_Id;
6955
6956                Target_Comp_Type : constant Entity_Id :=
6957                                     Component_Type (Target_Type);
6958                Opnd_Comp_Type   : constant Entity_Id :=
6959                                      Component_Type (Opnd_Type);
6960
6961             begin
6962                while Present (Target_Index) and then Present (Opnd_Index) loop
6963                   Target_Index_Type := Etype (Target_Index);
6964                   Opnd_Index_Type   := Etype (Opnd_Index);
6965
6966                   if not (Is_Integer_Type (Target_Index_Type)
6967                           and then Is_Integer_Type (Opnd_Index_Type))
6968                     and then (Root_Type (Target_Index_Type)
6969                               /= Root_Type (Opnd_Index_Type))
6970                   then
6971                      Error_Msg_N
6972                        ("incompatible index types for array conversion",
6973                         Operand);
6974                      return False;
6975                   end if;
6976
6977                   Next_Index (Target_Index);
6978                   Next_Index (Opnd_Index);
6979                end loop;
6980
6981                if Base_Type (Target_Comp_Type) /=
6982                  Base_Type (Opnd_Comp_Type)
6983                then
6984                   Error_Msg_N
6985                     ("incompatible component types for array conversion",
6986                      Operand);
6987                   return False;
6988
6989                elsif
6990                   Is_Constrained (Target_Comp_Type)
6991                     /= Is_Constrained (Opnd_Comp_Type)
6992                   or else not Subtypes_Statically_Match
6993                                 (Target_Comp_Type, Opnd_Comp_Type)
6994                then
6995                   Error_Msg_N
6996                     ("component subtypes must statically match", Operand);
6997                   return False;
6998
6999                end if;
7000             end;
7001          end if;
7002
7003          return True;
7004
7005       elsif (Ekind (Target_Type) = E_General_Access_Type
7006         or else Ekind (Target_Type) = E_Anonymous_Access_Type)
7007           and then
7008             Conversion_Check
7009               (Is_Access_Type (Opnd_Type)
7010                  and then Ekind (Opnd_Type) /=
7011                    E_Access_Subprogram_Type
7012                  and then Ekind (Opnd_Type) /=
7013                    E_Access_Protected_Subprogram_Type,
7014                "must be an access-to-object type")
7015       then
7016          if Is_Access_Constant (Opnd_Type)
7017            and then not Is_Access_Constant (Target_Type)
7018          then
7019             Error_Msg_N
7020               ("access-to-constant operand type not allowed", Operand);
7021             return False;
7022          end if;
7023
7024          --  Check the static accessibility rule of 4.6(17). Note that
7025          --  the check is not enforced when within an instance body, since
7026          --  the RM requires such cases to be caught at run time.
7027
7028          if Ekind (Target_Type) /= E_Anonymous_Access_Type then
7029             if Type_Access_Level (Opnd_Type)
7030               > Type_Access_Level (Target_Type)
7031             then
7032                --  In an instance, this is a run-time check, but one we
7033                --  know will fail, so generate an appropriate warning.
7034                --  The raise will be generated by Expand_N_Type_Conversion.
7035
7036                if In_Instance_Body then
7037                   Error_Msg_N
7038                     ("?cannot convert local pointer to non-local access type",
7039                      Operand);
7040                   Error_Msg_N
7041                     ("?Program_Error will be raised at run time", Operand);
7042
7043                else
7044                   Error_Msg_N
7045                     ("cannot convert local pointer to non-local access type",
7046                      Operand);
7047                   return False;
7048                end if;
7049
7050             elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then
7051
7052                --  When the operand is a selected access discriminant
7053                --  the check needs to be made against the level of the
7054                --  object denoted by the prefix of the selected name.
7055                --  (Object_Access_Level handles checking the prefix
7056                --  of the operand for this case.)
7057
7058                if Nkind (Operand) = N_Selected_Component
7059                  and then Object_Access_Level (Operand)
7060                    > Type_Access_Level (Target_Type)
7061                then
7062                   --  In an instance, this is a run-time check, but one we
7063                   --  know will fail, so generate an appropriate warning.
7064                   --  The raise will be generated by Expand_N_Type_Conversion.
7065
7066                   if In_Instance_Body then
7067                      Error_Msg_N
7068                        ("?cannot convert access discriminant to non-local" &
7069                         " access type", Operand);
7070                      Error_Msg_N
7071                        ("?Program_Error will be raised at run time", Operand);
7072
7073                   else
7074                      Error_Msg_N
7075                        ("cannot convert access discriminant to non-local" &
7076                         " access type", Operand);
7077                      return False;
7078                   end if;
7079                end if;
7080
7081                --  The case of a reference to an access discriminant
7082                --  from within a type declaration (which will appear
7083                --  as a discriminal) is always illegal because the
7084                --  level of the discriminant is considered to be
7085                --  deeper than any (namable) access type.
7086
7087                if Is_Entity_Name (Operand)
7088                  and then (Ekind (Entity (Operand)) = E_In_Parameter
7089                             or else Ekind (Entity (Operand)) = E_Constant)
7090                  and then Present (Discriminal_Link (Entity (Operand)))
7091                then
7092                   Error_Msg_N
7093                     ("discriminant has deeper accessibility level than target",
7094                      Operand);
7095                   return False;
7096                end if;
7097             end if;
7098          end if;
7099
7100          declare
7101             Target : constant Entity_Id := Designated_Type (Target_Type);
7102             Opnd   : constant Entity_Id := Designated_Type (Opnd_Type);
7103
7104          begin
7105             if Is_Tagged_Type (Target) then
7106                return Valid_Tagged_Conversion (Target, Opnd);
7107
7108             else
7109                if Base_Type (Target) /= Base_Type (Opnd) then
7110                   Error_Msg_NE
7111                     ("target designated type not compatible with }",
7112                      N, Base_Type (Opnd));
7113                   return False;
7114
7115                --  Ada 2005 AI-384: legality rule is symmetric in both
7116                --  designated types. The conversion is legal (with possible
7117                --  constraint check) if either designated type is
7118                --  unconstrained.
7119
7120                elsif Subtypes_Statically_Match (Target, Opnd)
7121                  or else
7122                    (Has_Discriminants (Target)
7123                      and then
7124                       (not Is_Constrained (Opnd)
7125                         or else not Is_Constrained (Target)))
7126                then
7127                   return True;
7128
7129                else
7130                   Error_Msg_NE
7131                     ("target designated subtype not compatible with }",
7132                      N, Opnd);
7133                   return False;
7134                end if;
7135             end if;
7136          end;
7137
7138       elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
7139                or else
7140              Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
7141         and then Conversion_Check
7142                    (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
7143                     "illegal operand for access subprogram conversion")
7144       then
7145          --  Check that the designated types are subtype conformant
7146
7147          if not Subtype_Conformant (Designated_Type (Opnd_Type),
7148                                     Designated_Type (Target_Type))
7149          then
7150             Error_Msg_N
7151               ("operand type is not subtype conformant with target type",
7152                Operand);
7153          end if;
7154
7155          --  Check the static accessibility rule of 4.6(20)
7156
7157          if Type_Access_Level (Opnd_Type) >
7158             Type_Access_Level (Target_Type)
7159          then
7160             Error_Msg_N
7161               ("operand type has deeper accessibility level than target",
7162                Operand);
7163
7164          --  Check that if the operand type is declared in a generic body,
7165          --  then the target type must be declared within that same body
7166          --  (enforces last sentence of 4.6(20)).
7167
7168          elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
7169             declare
7170                O_Gen : constant Node_Id :=
7171                          Enclosing_Generic_Body (Opnd_Type);
7172
7173                T_Gen : Node_Id :=
7174                          Enclosing_Generic_Body (Target_Type);
7175
7176             begin
7177                while Present (T_Gen) and then T_Gen /= O_Gen loop
7178                   T_Gen := Enclosing_Generic_Body (T_Gen);
7179                end loop;
7180
7181                if T_Gen /= O_Gen then
7182                   Error_Msg_N
7183                     ("target type must be declared in same generic body"
7184                      & " as operand type", N);
7185                end if;
7186             end;
7187          end if;
7188
7189          return True;
7190
7191       elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
7192         and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
7193       then
7194          --  It is valid to convert from one RAS type to another provided
7195          --  that their specification statically match.
7196
7197          Check_Subtype_Conformant
7198            (New_Id  =>
7199               Designated_Type (Corresponding_Remote_Type (Target_Type)),
7200             Old_Id  =>
7201               Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
7202             Err_Loc =>
7203               N);
7204          return True;
7205
7206       elsif Is_Tagged_Type (Target_Type) then
7207          return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
7208
7209       --  Types derived from the same root type are convertible.
7210
7211       elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
7212          return True;
7213
7214       --  In an instance, there may be inconsistent views of the same
7215       --  type, or types derived from the same type.
7216
7217       elsif In_Instance
7218         and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
7219       then
7220          return True;
7221
7222       --  Special check for common access type error case
7223
7224       elsif Ekind (Target_Type) = E_Access_Type
7225          and then Is_Access_Type (Opnd_Type)
7226       then
7227          Error_Msg_N ("target type must be general access type!", N);
7228          Error_Msg_NE ("add ALL to }!", N, Target_Type);
7229
7230          return False;
7231
7232       else
7233          Error_Msg_NE ("invalid conversion, not compatible with }",
7234            N, Opnd_Type);
7235
7236          return False;
7237       end if;
7238    end Valid_Conversion;
7239
7240 end Sem_Res;