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