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