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