gcc/ada/sem_res.adb

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