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