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-2008, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Debug;    use Debug;
  29 with Debug_A;  use Debug_A;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Expander; use Expander;
  34 with Exp_Disp; use Exp_Disp;
  35 with Exp_Ch6;  use Exp_Ch6;
  36 with Exp_Ch7;  use Exp_Ch7;
  37 with Exp_Tss;  use Exp_Tss;
  38 with Exp_Util; use Exp_Util;
  39 with Fname;    use Fname;
  40 with Freeze;   use Freeze;
  41 with Itypes;   use Itypes;
  42 with Lib;      use Lib;
  43 with Lib.Xref; use Lib.Xref;
  44 with Namet;    use Namet;
  45 with Nmake;    use Nmake;
  46 with Nlists;   use Nlists;
  47 with Opt;      use Opt;
  48 with Output;   use Output;
  49 with Restrict; use Restrict;
  50 with Rident;   use Rident;
  51 with Rtsfind;  use Rtsfind;
  52 with Sem;      use Sem;
  53 with Sem_Aggr; use Sem_Aggr;
  54 with Sem_Attr; use Sem_Attr;
  55 with Sem_Cat;  use Sem_Cat;
  56 with Sem_Ch4;  use Sem_Ch4;
  57 with Sem_Ch6;  use Sem_Ch6;
  58 with Sem_Ch8;  use Sem_Ch8;
  59 with Sem_Ch13; use Sem_Ch13;
  60 with Sem_Disp; use Sem_Disp;
  61 with Sem_Dist; use Sem_Dist;
  62 with Sem_Elab; use Sem_Elab;
  63 with Sem_Eval; use Sem_Eval;
  64 with Sem_Intr; use Sem_Intr;
  65 with Sem_Util; use Sem_Util;
  66 with Sem_Type; use Sem_Type;
  67 with Sem_Warn; use Sem_Warn;
  68 with Sinfo;    use Sinfo;
  69 with Snames;   use Snames;
  70 with Stand;    use Stand;
  71 with Stringt;  use Stringt;
  72 with Style;    use Style;
  73 with Targparm; use Targparm;
  74 with Tbuild;   use Tbuild;
  75 with Uintp;    use Uintp;
  76 with Urealp;   use Urealp;
  77
  78 package body Sem_Res is
  79
  80    -----------------------
  81    -- Local Subprograms --
  82    -----------------------
  83
  84    --  Second pass (top-down) type checking and overload resolution procedures
  85    --  Typ is the type required by context. These procedures propagate the
  86    --  type information recursively to the descendants of N. If the node
  87    --  is not overloaded, its Etype is established in the first pass. If
  88    --  overloaded,  the Resolve routines set the correct type. For arith.
  89    --  operators, the Etype is the base type of the context.
  90
  91    --  Note that Resolve_Attribute is separated off in Sem_Attr
  92
  93    procedure Check_Discriminant_Use (N : Node_Id);
  94    --  Enforce the restrictions on the use of discriminants when constraining
  95    --  a component of a discriminated type (record or concurrent type).
  96
  97    procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);
  98    --  Given a node for an operator associated with type T, check that
  99    --  the operator is visible. Operators all of whose operands are
 100    --  universal must be checked for visibility during resolution
 101    --  because their type is not determinable based on their operands.
 102
 103    procedure Check_Fully_Declared_Prefix
 104      (Typ  : Entity_Id;
 105       Pref : Node_Id);
 106    --  Check that the type of the prefix of a dereference is not incomplete
 107
 108    function Check_Infinite_Recursion (N : Node_Id) return Boolean;
 109    --  Given a call node, N, which is known to occur immediately within the
 110    --  subprogram being called, determines whether it is a detectable case of
 111    --  an infinite recursion, and if so, outputs appropriate messages. Returns
 112    --  True if an infinite recursion is detected, and False otherwise.
 113
 114    procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
 115    --  If the type of the object being initialized uses the secondary stack
 116    --  directly or indirectly, create a transient scope for the call to the
 117    --  init proc. This is because we do not create transient scopes for the
 118    --  initialization of individual components within the init proc itself.
 119    --  Could be optimized away perhaps?
 120
 121    function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
 122    --  Determine whether E is an access type declared by an access
 123    --  declaration, and not an (anonymous) allocator type.
 124
 125    function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
 126    --  Utility to check whether the name in the call is a predefined
 127    --  operator, in which case the call is made into an operator node.
 128    --  An instance of an intrinsic conversion operation may be given
 129    --  an operator name, but is not treated like an operator.
 130
 131    procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);
 132    --  If a default expression in entry call N depends on the discriminants
 133    --  of the task, it must be replaced with a reference to the discriminant
 134    --  of the task being called.
 135
 136    procedure Resolve_Op_Concat_Arg
 137      (N       : Node_Id;
 138       Arg     : Node_Id;
 139       Typ     : Entity_Id;
 140       Is_Comp : Boolean);
 141    --  Internal procedure for Resolve_Op_Concat to resolve one operand of
 142    --  concatenation operator.  The operand is either of the array type or of
 143    --  the component type. If the operand is an aggregate, and the component
 144    --  type is composite, this is ambiguous if component type has aggregates.
 145
 146    procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id);
 147    --  Does the first part of the work of Resolve_Op_Concat
 148
 149    procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id);
 150    --  Does the "rest" of the work of Resolve_Op_Concat, after the left operand
 151    --  has been resolved. See Resolve_Op_Concat for details.
 152
 153    procedure Resolve_Allocator                 (N : Node_Id; Typ : Entity_Id);
 154    procedure Resolve_Arithmetic_Op             (N : Node_Id; Typ : Entity_Id);
 155    procedure Resolve_Call                      (N : Node_Id; Typ : Entity_Id);
 156    procedure Resolve_Character_Literal         (N : Node_Id; Typ : Entity_Id);
 157    procedure Resolve_Comparison_Op             (N : Node_Id; Typ : Entity_Id);
 158    procedure Resolve_Conditional_Expression    (N : Node_Id; Typ : Entity_Id);
 159    procedure Resolve_Equality_Op               (N : Node_Id; Typ : Entity_Id);
 160    procedure Resolve_Explicit_Dereference      (N : Node_Id; Typ : Entity_Id);
 161    procedure Resolve_Entity_Name               (N : Node_Id; Typ : Entity_Id);
 162    procedure Resolve_Indexed_Component         (N : Node_Id; Typ : Entity_Id);
 163    procedure Resolve_Integer_Literal           (N : Node_Id; Typ : Entity_Id);
 164    procedure Resolve_Logical_Op                (N : Node_Id; Typ : Entity_Id);
 165    procedure Resolve_Membership_Op             (N : Node_Id; Typ : Entity_Id);
 166    procedure Resolve_Null                      (N : Node_Id; Typ : Entity_Id);
 167    procedure Resolve_Operator_Symbol           (N : Node_Id; Typ : Entity_Id);
 168    procedure Resolve_Op_Concat                 (N : Node_Id; Typ : Entity_Id);
 169    procedure Resolve_Op_Expon                  (N : Node_Id; Typ : Entity_Id);
 170    procedure Resolve_Op_Not                    (N : Node_Id; Typ : Entity_Id);
 171    procedure Resolve_Qualified_Expression      (N : Node_Id; Typ : Entity_Id);
 172    procedure Resolve_Range                     (N : Node_Id; Typ : Entity_Id);
 173    procedure Resolve_Real_Literal              (N : Node_Id; Typ : Entity_Id);
 174    procedure Resolve_Reference                 (N : Node_Id; Typ : Entity_Id);
 175    procedure Resolve_Selected_Component        (N : Node_Id; Typ : Entity_Id);
 176    procedure Resolve_Shift                     (N : Node_Id; Typ : Entity_Id);
 177    procedure Resolve_Short_Circuit             (N : Node_Id; Typ : Entity_Id);
 178    procedure Resolve_Slice                     (N : Node_Id; Typ : Entity_Id);
 179    procedure Resolve_String_Literal            (N : Node_Id; Typ : Entity_Id);
 180    procedure Resolve_Subprogram_Info           (N : Node_Id; Typ : Entity_Id);
 181    procedure Resolve_Type_Conversion           (N : Node_Id; Typ : Entity_Id);
 182    procedure Resolve_Unary_Op                  (N : Node_Id; Typ : Entity_Id);
 183    procedure Resolve_Unchecked_Expression      (N : Node_Id; Typ : Entity_Id);
 184    procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id);
 185
 186    function Operator_Kind
 187      (Op_Name   : Name_Id;
 188       Is_Binary : Boolean) return Node_Kind;
 189    --  Utility to map the name of an operator into the corresponding Node. Used
 190    --  by other node rewriting procedures.
 191
 192    procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
 193    --  Resolve actuals of call, and add default expressions for missing ones.
 194    --  N is the Node_Id for the subprogram call, and Nam is the entity of the
 195    --  called subprogram.
 196
 197    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
 198    --  Called from Resolve_Call, when the prefix denotes an entry or element
 199    --  of entry family. Actuals are resolved as for subprograms, and the node
 200    --  is rebuilt as an entry call. Also called for protected operations. Typ
 201    --  is the context type, which is used when the operation is a protected
 202    --  function with no arguments, and the return value is indexed.
 203
 204    procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
 205    --  A call to a user-defined intrinsic operator is rewritten as a call
 206    --  to the corresponding predefined operator, with suitable conversions.
 207
 208    procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
 209    --  Ditto, for unary operators (only arithmetic ones)
 210
 211    procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
 212    --  If an operator node resolves to a call to a user-defined operator,
 213    --  rewrite the node as a function call.
 214
 215    procedure Make_Call_Into_Operator
 216      (N     : Node_Id;
 217       Typ   : Entity_Id;
 218       Op_Id : Entity_Id);
 219    --  Inverse transformation: if an operator is given in functional notation,
 220    --  then after resolving the node, transform into an operator node, so
 221    --  that operands are resolved properly. Recall that predefined operators
 222    --  do not have a full signature and special resolution rules apply.
 223
 224    procedure Rewrite_Renamed_Operator
 225      (N   : Node_Id;
 226       Op  : Entity_Id;
 227       Typ : Entity_Id);
 228    --  An operator can rename another, e.g. in  an instantiation. In that
 229    --  case, the proper operator node must be constructed and resolved.
 230
 231    procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
 232    --  The String_Literal_Subtype is built for all strings that are not
 233    --  operands of a static concatenation operation. If the argument is
 234    --  not a N_String_Literal node, then the call has no effect.
 235
 236    procedure Set_Slice_Subtype (N : Node_Id);
 237    --  Build subtype of array type, with the range specified by the slice
 238
 239    procedure Simplify_Type_Conversion (N : Node_Id);
 240    --  Called after N has been resolved and evaluated, but before range checks
 241    --  have been applied. Currently simplifies a combination of floating-point
 242    --  to integer conversion and Truncation attribute.
 243
 244    function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
 245    --  A universal_fixed expression in an universal context is unambiguous
 246    --  if there is only one applicable fixed point type. Determining whether
 247    --  there is only one requires a search over all visible entities, and
 248    --  happens only in very pathological cases (see 6115-006).
 249
 250    function Valid_Conversion
 251      (N       : Node_Id;
 252       Target  : Entity_Id;
 253       Operand : Node_Id) return Boolean;
 254    --  Verify legality rules given in 4.6 (8-23). Target is the target
 255    --  type of the conversion, which may be an implicit conversion of
 256    --  an actual parameter to an anonymous access type (in which case
 257    --  N denotes the actual parameter and N = Operand).
 258
 259    -------------------------
 260    -- Ambiguous_Character --
 261    -------------------------
 262
 263    procedure Ambiguous_Character (C : Node_Id) is
 264       E : Entity_Id;
 265
 266    begin
 267       if Nkind (C) = N_Character_Literal then
 268          Error_Msg_N ("ambiguous character literal", C);
 269
 270          --  First the ones in Standard
 271
 272          Error_Msg_N
 273            ("\\possible interpretation: Character!", C);
 274          Error_Msg_N
 275            ("\\possible interpretation: Wide_Character!", C);
 276
 277          --  Include Wide_Wide_Character in Ada 2005 mode
 278
 279          if Ada_Version >= Ada_05 then
 280             Error_Msg_N
 281               ("\\possible interpretation: Wide_Wide_Character!", C);
 282          end if;
 283
 284          --  Now any other types that match
 285
 286          E := Current_Entity (C);
 287          while Present (E) loop
 288             Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E));
 289             E := Homonym (E);
 290          end loop;
 291       end if;
 292    end Ambiguous_Character;
 293
 294    -------------------------
 295    -- Analyze_And_Resolve --
 296    -------------------------
 297
 298    procedure Analyze_And_Resolve (N : Node_Id) is
 299    begin
 300       Analyze (N);
 301       Resolve (N);
 302    end Analyze_And_Resolve;
 303
 304    procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
 305    begin
 306       Analyze (N);
 307       Resolve (N, Typ);
 308    end Analyze_And_Resolve;
 309
 310    --  Version withs check(s) suppressed
 311
 312    procedure Analyze_And_Resolve
 313      (N        : Node_Id;
 314       Typ      : Entity_Id;
 315       Suppress : Check_Id)
 316    is
 317       Scop : constant Entity_Id := Current_Scope;
 318
 319    begin
 320       if Suppress = All_Checks then
 321          declare
 322             Svg : constant Suppress_Array := Scope_Suppress;
 323          begin
 324             Scope_Suppress := (others => True);
 325             Analyze_And_Resolve (N, Typ);
 326             Scope_Suppress := Svg;
 327          end;
 328
 329       else
 330          declare
 331             Svg : constant Boolean := Scope_Suppress (Suppress);
 332
 333          begin
 334             Scope_Suppress (Suppress) := True;
 335             Analyze_And_Resolve (N, Typ);
 336             Scope_Suppress (Suppress) := Svg;
 337          end;
 338       end if;
 339
 340       if Current_Scope /= Scop
 341         and then Scope_Is_Transient
 342       then
 343          --  This can only happen if a transient scope was created
 344          --  for an inner expression, which will be removed upon
 345          --  completion of the analysis of an enclosing construct.
 346          --  The transient scope must have the suppress status of
 347          --  the enclosing environment, not of this Analyze call.
 348
 349          Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
 350            Scope_Suppress;
 351       end if;
 352    end Analyze_And_Resolve;
 353
 354    procedure Analyze_And_Resolve
 355      (N        : Node_Id;
 356       Suppress : Check_Id)
 357    is
 358       Scop : constant Entity_Id := Current_Scope;
 359
 360    begin
 361       if Suppress = All_Checks then
 362          declare
 363             Svg : constant Suppress_Array := Scope_Suppress;
 364          begin
 365             Scope_Suppress := (others => True);
 366             Analyze_And_Resolve (N);
 367             Scope_Suppress := Svg;
 368          end;
 369
 370       else
 371          declare
 372             Svg : constant Boolean := Scope_Suppress (Suppress);
 373
 374          begin
 375             Scope_Suppress (Suppress) := True;
 376             Analyze_And_Resolve (N);
 377             Scope_Suppress (Suppress) := Svg;
 378          end;
 379       end if;
 380
 381       if Current_Scope /= Scop
 382         and then Scope_Is_Transient
 383       then
 384          Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
 385            Scope_Suppress;
 386       end if;
 387    end Analyze_And_Resolve;
 388
 389    ----------------------------
 390    -- Check_Discriminant_Use --
 391    ----------------------------
 392
 393    procedure Check_Discriminant_Use (N : Node_Id) is
 394       PN   : constant Node_Id   := Parent (N);
 395       Disc : constant Entity_Id := Entity (N);
 396       P    : Node_Id;
 397       D    : Node_Id;
 398
 399    begin
 400       --  Any use in a spec-expression is legal
 401
 402       if In_Spec_Expression then
 403          null;
 404
 405       elsif Nkind (PN) = N_Range then
 406
 407          --  Discriminant cannot be used to constrain a scalar type
 408
 409          P := Parent (PN);
 410
 411          if Nkind (P) = N_Range_Constraint
 412            and then Nkind (Parent (P)) = N_Subtype_Indication
 413            and then Nkind (Parent (Parent (P))) = N_Component_Definition
 414          then
 415             Error_Msg_N ("discriminant cannot constrain scalar type", N);
 416
 417          elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then
 418
 419             --  The following check catches the unusual case where
 420             --  a discriminant appears within an index constraint
 421             --  that is part of a larger expression within a constraint
 422             --  on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))".
 423             --  For now we only check case of record components, and
 424             --  note that a similar check should also apply in the
 425             --  case of discriminant constraints below. ???
 426
 427             --  Note that the check for N_Subtype_Declaration below is to
 428             --  detect the valid use of discriminants in the constraints of a
 429             --  subtype declaration when this subtype declaration appears
 430             --  inside the scope of a record type (which is syntactically
 431             --  illegal, but which may be created as part of derived type
 432             --  processing for records). See Sem_Ch3.Build_Derived_Record_Type
 433             --  for more info.
 434
 435             if Ekind (Current_Scope) = E_Record_Type
 436               and then Scope (Disc) = Current_Scope
 437               and then not
 438                 (Nkind (Parent (P)) = N_Subtype_Indication
 439                   and then
 440                     Nkind_In (Parent (Parent (P)), N_Component_Definition,
 441                                                    N_Subtype_Declaration)
 442                   and then Paren_Count (N) = 0)
 443             then
 444                Error_Msg_N
 445                  ("discriminant must appear alone in component constraint", N);
 446                return;
 447             end if;
 448
 449             --   Detect a common beginner error:
 450
 451             --   type R (D : Positive := 100) is record
 452             --     Name : String (1 .. D);
 453             --   end record;
 454
 455             --  The default value causes an object of type R to be
 456             --  allocated with room for Positive'Last characters.
 457
 458             declare
 459                SI : Node_Id;
 460                T  : Entity_Id;
 461                TB : Node_Id;
 462                CB : Entity_Id;
 463
 464                function Large_Storage_Type (T : Entity_Id) return Boolean;
 465                --  Return True if type T has a large enough range that
 466                --  any array whose index type covered the whole range of
 467                --  the type would likely raise Storage_Error.
 468
 469                ------------------------
 470                -- Large_Storage_Type --
 471                ------------------------
 472
 473                function Large_Storage_Type (T : Entity_Id) return Boolean is
 474                begin
 475                   --  The type is considered large if its bounds are known at
 476                   --  compile time and if it requires at least as many bits as
 477                   --  a Positive to store the possible values.
 478
 479                   return Compile_Time_Known_Value (Type_Low_Bound (T))
 480                     and then Compile_Time_Known_Value (Type_High_Bound (T))
 481                     and then
 482                       Minimum_Size (T, Biased => True) >=
 483                         Esize (Standard_Integer) - 1;
 484                end Large_Storage_Type;
 485
 486             begin
 487                --  Check that the Disc has a large range
 488
 489                if not Large_Storage_Type (Etype (Disc)) then
 490                   goto No_Danger;
 491                end if;
 492
 493                --  If the enclosing type is limited, we allocate only the
 494                --  default value, not the maximum, and there is no need for
 495                --  a warning.
 496
 497                if Is_Limited_Type (Scope (Disc)) then
 498                   goto No_Danger;
 499                end if;
 500
 501                --  Check that it is the high bound
 502
 503                if N /= High_Bound (PN)
 504                  or else No (Discriminant_Default_Value (Disc))
 505                then
 506                   goto No_Danger;
 507                end if;
 508
 509                --  Check the array allows a large range at this bound.
 510                --  First find the array
 511
 512                SI := Parent (P);
 513
 514                if Nkind (SI) /= N_Subtype_Indication then
 515                   goto No_Danger;
 516                end if;
 517
 518                T := Entity (Subtype_Mark (SI));
 519
 520                if not Is_Array_Type (T) then
 521                   goto No_Danger;
 522                end if;
 523
 524                --  Next, find the dimension
 525
 526                TB := First_Index (T);
 527                CB := First (Constraints (P));
 528                while True
 529                  and then Present (TB)
 530                  and then Present (CB)
 531                  and then CB /= PN
 532                loop
 533                   Next_Index (TB);
 534                   Next (CB);
 535                end loop;
 536
 537                if CB /= PN then
 538                   goto No_Danger;
 539                end if;
 540
 541                --  Now, check the dimension has a large range
 542
 543                if not Large_Storage_Type (Etype (TB)) then
 544                   goto No_Danger;
 545                end if;
 546
 547                --  Warn about the danger
 548
 549                Error_Msg_N
 550                  ("?creation of & object may raise Storage_Error!",
 551                   Scope (Disc));
 552
 553                <<No_Danger>>
 554                   null;
 555
 556             end;
 557          end if;
 558
 559       --  Legal case is in index or discriminant constraint
 560
 561       elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,
 562                           N_Discriminant_Association)
 563       then
 564          if Paren_Count (N) > 0 then
 565             Error_Msg_N
 566               ("discriminant in constraint must appear alone",  N);
 567
 568          elsif Nkind (N) = N_Expanded_Name
 569            and then Comes_From_Source (N)
 570          then
 571             Error_Msg_N
 572               ("discriminant must appear alone as a direct name", N);
 573          end if;
 574
 575          return;
 576
 577       --  Otherwise, context is an expression. It should not be within
 578       --  (i.e. a subexpression of) a constraint for a component.
 579
 580       else
 581          D := PN;
 582          P := Parent (PN);
 583          while not Nkind_In (P, N_Component_Declaration,
 584                                 N_Subtype_Indication,
 585                                 N_Entry_Declaration)
 586          loop
 587             D := P;
 588             P := Parent (P);
 589             exit when No (P);
 590          end loop;
 591
 592          --  If the discriminant is used in an expression that is a bound
 593          --  of a scalar type, an Itype is created and the bounds are attached
 594          --  to its range,  not to the original subtype indication. Such use
 595          --  is of course a double fault.
 596
 597          if (Nkind (P) = N_Subtype_Indication
 598               and then Nkind_In (Parent (P), N_Component_Definition,
 599                                              N_Derived_Type_Definition)
 600               and then D = Constraint (P))
 601
 602          --  The constraint itself may be given by a subtype indication,
 603          --  rather than by a more common discrete range.
 604
 605            or else (Nkind (P) = N_Subtype_Indication
 606                       and then
 607                     Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
 608            or else Nkind (P) = N_Entry_Declaration
 609            or else Nkind (D) = N_Defining_Identifier
 610          then
 611             Error_Msg_N
 612               ("discriminant in constraint must appear alone",  N);
 613          end if;
 614       end if;
 615    end Check_Discriminant_Use;
 616
 617    --------------------------------
 618    -- Check_For_Visible_Operator --
 619    --------------------------------
 620
 621    procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
 622    begin
 623       if Is_Invisible_Operator (N, T) then
 624          Error_Msg_NE
 625            ("operator for} is not directly visible!", N, First_Subtype (T));
 626          Error_Msg_N ("use clause would make operation legal!", N);
 627       end if;
 628    end Check_For_Visible_Operator;
 629
 630    ----------------------------------
 631    --  Check_Fully_Declared_Prefix --
 632    ----------------------------------
 633
 634    procedure Check_Fully_Declared_Prefix
 635      (Typ  : Entity_Id;
 636       Pref : Node_Id)
 637    is
 638    begin
 639       --  Check that the designated type of the prefix of a dereference is
 640       --  not an incomplete type. This cannot be done unconditionally, because
 641       --  dereferences of private types are legal in default expressions. This
 642       --  case is taken care of in Check_Fully_Declared, called below. There
 643       --  are also 2005 cases where it is legal for the prefix to be unfrozen.
 644
 645       --  This consideration also applies to similar checks for allocators,
 646       --  qualified expressions, and type conversions.
 647
 648       --  An additional exception concerns other per-object expressions that
 649       --  are not directly related to component declarations, in particular
 650       --  representation pragmas for tasks. These will be per-object
 651       --  expressions if they depend on discriminants or some global entity.
 652       --  If the task has access discriminants, the designated type may be
 653       --  incomplete at the point the expression is resolved. This resolution
 654       --  takes place within the body of the initialization procedure, where
 655       --  the discriminant is replaced by its discriminal.
 656
 657       if Is_Entity_Name (Pref)
 658         and then Ekind (Entity (Pref)) = E_In_Parameter
 659       then
 660          null;
 661
 662       --  Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
 663       --  are handled by Analyze_Access_Attribute, Analyze_Assignment,
 664       --  Analyze_Object_Renaming, and Freeze_Entity.
 665
 666       elsif Ada_Version >= Ada_05
 667         and then Is_Entity_Name (Pref)
 668         and then Ekind (Directly_Designated_Type (Etype (Pref))) =
 669                                                        E_Incomplete_Type
 670         and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref)))
 671       then
 672          null;
 673       else
 674          Check_Fully_Declared (Typ, Parent (Pref));
 675       end if;
 676    end Check_Fully_Declared_Prefix;
 677
 678    ------------------------------
 679    -- Check_Infinite_Recursion --
 680    ------------------------------
 681
 682    function Check_Infinite_Recursion (N : Node_Id) return Boolean is
 683       P : Node_Id;
 684       C : Node_Id;
 685
 686       function Same_Argument_List return Boolean;
 687       --  Check whether list of actuals is identical to list of formals
 688       --  of called function (which is also the enclosing scope).
 689
 690       ------------------------
 691       -- Same_Argument_List --
 692       ------------------------
 693
 694       function Same_Argument_List return Boolean is
 695          A    : Node_Id;
 696          F    : Entity_Id;
 697          Subp : Entity_Id;
 698
 699       begin
 700          if not Is_Entity_Name (Name (N)) then
 701             return False;
 702          else
 703             Subp := Entity (Name (N));
 704          end if;
 705
 706          F := First_Formal (Subp);
 707          A := First_Actual (N);
 708          while Present (F) and then Present (A) loop
 709             if not Is_Entity_Name (A)
 710               or else Entity (A) /= F
 711             then
 712                return False;
 713             end if;
 714
 715             Next_Actual (A);
 716             Next_Formal (F);
 717          end loop;
 718
 719          return True;
 720       end Same_Argument_List;
 721
 722    --  Start of processing for Check_Infinite_Recursion
 723
 724    begin
 725       --  Special case, if this is a procedure call and is a call to the
 726       --  current procedure with the same argument list, then this is for
 727       --  sure an infinite recursion and we insert a call to raise SE.
 728
 729       if Is_List_Member (N)
 730         and then List_Length (List_Containing (N)) = 1
 731         and then Same_Argument_List
 732       then
 733          declare
 734             P : constant Node_Id := Parent (N);
 735          begin
 736             if Nkind (P) = N_Handled_Sequence_Of_Statements
 737               and then Nkind (Parent (P)) = N_Subprogram_Body
 738               and then Is_Empty_List (Declarations (Parent (P)))
 739             then
 740                Error_Msg_N ("!?infinite recursion", N);
 741                Error_Msg_N ("\!?Storage_Error will be raised at run time", N);
 742                Insert_Action (N,
 743                  Make_Raise_Storage_Error (Sloc (N),
 744                    Reason => SE_Infinite_Recursion));
 745                return True;
 746             end if;
 747          end;
 748       end if;
 749
 750       --  If not that special case, search up tree, quitting if we reach a
 751       --  construct (e.g. a conditional) that tells us that this is not a
 752       --  case for an infinite recursion warning.
 753
 754       C := N;
 755       loop
 756          P := Parent (C);
 757          exit when Nkind (P) = N_Subprogram_Body;
 758          if Nkind_In (P, N_Or_Else,
 759                          N_And_Then,
 760                          N_If_Statement,
 761                          N_Case_Statement)
 762          then
 763             return False;
 764
 765          elsif Nkind (P) = N_Handled_Sequence_Of_Statements
 766            and then C /= First (Statements (P))
 767          then
 768             --  If the call is the expression of a return statement and the
 769             --  actuals are identical to the formals, it's worth a warning.
 770             --  However, we skip this if there is an immediately preceding
 771             --  raise statement, since the call is never executed.
 772
 773             --  Furthermore, this corresponds to a common idiom:
 774
 775             --    function F (L : Thing) return Boolean is
 776             --    begin
 777             --       raise Program_Error;
 778             --       return F (L);
 779             --    end F;
 780
 781             --  for generating a stub function
 782
 783             if Nkind (Parent (N)) = N_Simple_Return_Statement
 784               and then Same_Argument_List
 785             then
 786                exit when not Is_List_Member (Parent (N));
 787
 788                --  OK, return statement is in a statement list, look for raise
 789
 790                declare
 791                   Nod : Node_Id;
 792
 793                begin
 794                   --  Skip past N_Freeze_Entity nodes generated by expansion
 795
 796                   Nod := Prev (Parent (N));
 797                   while Present (Nod)
 798                     and then Nkind (Nod) = N_Freeze_Entity
 799                   loop
 800                      Prev (Nod);
 801                   end loop;
 802
 803                   --  If no raise statement, give warning
 804
 805                   exit when Nkind (Nod) /= N_Raise_Statement
 806                     and then
 807                       (Nkind (Nod) not in N_Raise_xxx_Error
 808                          or else Present (Condition (Nod)));
 809                end;
 810             end if;
 811
 812             return False;
 813
 814          else
 815             C := P;
 816          end if;
 817       end loop;
 818
 819       Error_Msg_N ("!?possible infinite recursion", N);
 820       Error_Msg_N ("\!?Storage_Error may be raised at run time", N);
 821
 822       return True;
 823    end Check_Infinite_Recursion;
 824
 825    -------------------------------
 826    -- Check_Initialization_Call --
 827    -------------------------------
 828
 829    procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
 830       Typ : constant Entity_Id := Etype (First_Formal (Nam));
 831
 832       function Uses_SS (T : Entity_Id) return Boolean;
 833       --  Check whether the creation of an object of the type will involve
 834       --  use of the secondary stack. If T is a record type, this is true
 835       --  if the expression for some component uses the secondary stack, e.g.
 836       --  through a call to a function that returns an unconstrained value.
 837       --  False if T is controlled, because cleanups occur elsewhere.
 838
 839       -------------
 840       -- Uses_SS --
 841       -------------
 842
 843       function Uses_SS (T : Entity_Id) return Boolean is
 844          Comp      : Entity_Id;
 845          Expr      : Node_Id;
 846          Full_Type : Entity_Id := Underlying_Type (T);
 847
 848       begin
 849          --  Normally we want to use the underlying type, but if it's not set
 850          --  then continue with T.
 851
 852          if not Present (Full_Type) then
 853             Full_Type := T;
 854          end if;
 855
 856          if Is_Controlled (Full_Type) then
 857             return False;
 858
 859          elsif Is_Array_Type (Full_Type) then
 860             return Uses_SS (Component_Type (Full_Type));
 861
 862          elsif Is_Record_Type (Full_Type) then
 863             Comp := First_Component (Full_Type);
 864             while Present (Comp) loop
 865                if Ekind (Comp) = E_Component
 866                  and then Nkind (Parent (Comp)) = N_Component_Declaration
 867                then
 868                   --  The expression for a dynamic component may be rewritten
 869                   --  as a dereference, so retrieve original node.
 870
 871                   Expr := Original_Node (Expression (Parent (Comp)));
 872
 873                   --  Return True if the expression is a call to a function
 874                   --  (including an attribute function such as Image) with
 875                   --  a result that requires a transient scope.
 876
 877                   if (Nkind (Expr) = N_Function_Call
 878                        or else (Nkind (Expr) = N_Attribute_Reference
 879                                  and then Present (Expressions (Expr))))
 880                     and then Requires_Transient_Scope (Etype (Expr))
 881                   then
 882                      return True;
 883
 884                   elsif Uses_SS (Etype (Comp)) then
 885                      return True;
 886                   end if;
 887                end if;
 888
 889                Next_Component (Comp);
 890             end loop;
 891
 892             return False;
 893
 894          else
 895             return False;
 896          end if;
 897       end Uses_SS;
 898
 899    --  Start of processing for Check_Initialization_Call
 900
 901    begin
 902       --  Establish a transient scope if the type needs it
 903
 904       if Uses_SS (Typ) then
 905          Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
 906       end if;
 907    end Check_Initialization_Call;
 908
 909    ------------------------------
 910    -- Check_Parameterless_Call --
 911    ------------------------------
 912
 913    procedure Check_Parameterless_Call (N : Node_Id) is
 914       Nam : Node_Id;
 915
 916       function Prefix_Is_Access_Subp return Boolean;
 917       --  If the prefix is of an access_to_subprogram type, the node must be
 918       --  rewritten as a call. Ditto if the prefix is overloaded and all its
 919       --  interpretations are access to subprograms.
 920
 921       ---------------------------
 922       -- Prefix_Is_Access_Subp --
 923       ---------------------------
 924
 925       function Prefix_Is_Access_Subp return Boolean is
 926          I   : Interp_Index;
 927          It  : Interp;
 928
 929       begin
 930          if not Is_Overloaded (N) then
 931             return
 932               Ekind (Etype (N)) = E_Subprogram_Type
 933                 and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type;
 934          else
 935             Get_First_Interp (N, I, It);
 936             while Present (It.Typ) loop
 937                if Ekind (It.Typ) /= E_Subprogram_Type
 938                  or else Base_Type (Etype (It.Typ)) = Standard_Void_Type
 939                then
 940                   return False;
 941                end if;
 942
 943                Get_Next_Interp (I, It);
 944             end loop;
 945
 946             return True;
 947          end if;
 948       end Prefix_Is_Access_Subp;
 949
 950    --  Start of processing for Check_Parameterless_Call
 951
 952    begin
 953       --  Defend against junk stuff if errors already detected
 954
 955       if Total_Errors_Detected /= 0 then
 956          if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
 957             return;
 958          elsif Nkind (N) in N_Has_Chars
 959            and then Chars (N) in Error_Name_Or_No_Name
 960          then
 961             return;
 962          end if;
 963
 964          Require_Entity (N);
 965       end if;
 966
 967       --  If the context expects a value, and the name is a procedure, this is
 968       --  most likely a missing 'Access. Don't try to resolve the parameterless
 969       --  call, error will be caught when the outer call is analyzed.
 970
 971       if Is_Entity_Name (N)
 972         and then Ekind (Entity (N)) = E_Procedure
 973         and then not Is_Overloaded (N)
 974         and then
 975          Nkind_In (Parent (N), N_Parameter_Association,
 976                                N_Function_Call,
 977                                N_Procedure_Call_Statement)
 978       then
 979          return;
 980       end if;
 981
 982       --  Rewrite as call if overloadable entity that is (or could be, in the
 983       --  overloaded case) a function call. If we know for sure that the entity
 984       --  is an enumeration literal, we do not rewrite it.
 985
 986       if (Is_Entity_Name (N)
 987             and then Is_Overloadable (Entity (N))
 988             and then (Ekind (Entity (N)) /= E_Enumeration_Literal
 989                         or else Is_Overloaded (N)))
 990
 991       --  Rewrite as call if it is an explicit deference of an expression of
 992       --  a subprogram access type, and the subprogram type is not that of a
 993       --  procedure or entry.
 994
 995       or else
 996         (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp)
 997
 998       --  Rewrite as call if it is a selected component which is a function,
 999       --  this is the case of a call to a protected function (which may be
1000       --  overloaded with other protected operations).
1001
1002       or else
1003         (Nkind (N) = N_Selected_Component
1004           and then (Ekind (Entity (Selector_Name (N))) = E_Function
1005                       or else
1006                         ((Ekind (Entity (Selector_Name (N))) = E_Entry
1007                             or else
1008                           Ekind (Entity (Selector_Name (N))) = E_Procedure)
1009                             and then Is_Overloaded (Selector_Name (N)))))
1010
1011       --  If one of the above three conditions is met, rewrite as call.
1012       --  Apply the rewriting only once.
1013
1014       then
1015          if Nkind (Parent (N)) /= N_Function_Call
1016            or else N /= Name (Parent (N))
1017          then
1018             Nam := New_Copy (N);
1019
1020             --  If overloaded, overload set belongs to new copy
1021
1022             Save_Interps (N, Nam);
1023
1024             --  Change node to parameterless function call (note that the
1025             --  Parameter_Associations associations field is left set to Empty,
1026             --  its normal default value since there are no parameters)
1027
1028             Change_Node (N, N_Function_Call);
1029             Set_Name (N, Nam);
1030             Set_Sloc (N, Sloc (Nam));
1031             Analyze_Call (N);
1032          end if;
1033
1034       elsif Nkind (N) = N_Parameter_Association then
1035          Check_Parameterless_Call (Explicit_Actual_Parameter (N));
1036       end if;
1037    end Check_Parameterless_Call;
1038
1039    -----------------------------
1040    -- Is_Definite_Access_Type --
1041    -----------------------------
1042
1043    function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
1044       Btyp : constant Entity_Id := Base_Type (E);
1045    begin
1046       return Ekind (Btyp) = E_Access_Type
1047         or else (Ekind (Btyp) = E_Access_Subprogram_Type
1048                   and then Comes_From_Source (Btyp));
1049    end Is_Definite_Access_Type;
1050
1051    ----------------------
1052    -- Is_Predefined_Op --
1053    ----------------------
1054
1055    function Is_Predefined_Op (Nam : Entity_Id) return Boolean is
1056    begin
1057       return Is_Intrinsic_Subprogram (Nam)
1058         and then not Is_Generic_Instance (Nam)
1059         and then Chars (Nam) in Any_Operator_Name
1060         and then (No (Alias (Nam))
1061                    or else Is_Predefined_Op (Alias (Nam)));
1062    end Is_Predefined_Op;
1063
1064    -----------------------------
1065    -- Make_Call_Into_Operator --
1066    -----------------------------
1067
1068    procedure Make_Call_Into_Operator
1069      (N     : Node_Id;
1070       Typ   : Entity_Id;
1071       Op_Id : Entity_Id)
1072    is
1073       Op_Name   : constant Name_Id := Chars (Op_Id);
1074       Act1      : Node_Id := First_Actual (N);
1075       Act2      : Node_Id := Next_Actual (Act1);
1076       Error     : Boolean := False;
1077       Func      : constant Entity_Id := Entity (Name (N));
1078       Is_Binary : constant Boolean   := Present (Act2);
1079       Op_Node   : Node_Id;
1080       Opnd_Type : Entity_Id;
1081       Orig_Type : Entity_Id := Empty;
1082       Pack      : Entity_Id;
1083
1084       type Kind_Test is access function (E : Entity_Id) return Boolean;
1085
1086       function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
1087       --  If the operand is not universal, and the operator is given by a
1088       --  expanded name,  verify that the operand has an interpretation with
1089       --  a type defined in the given scope of the operator.
1090
1091       function Type_In_P (Test : Kind_Test) return Entity_Id;
1092       --  Find a type of the given class in the package Pack that contains
1093       --  the operator.
1094
1095       ---------------------------
1096       -- Operand_Type_In_Scope --
1097       ---------------------------
1098
1099       function Operand_Type_In_Scope (S : Entity_Id) return Boolean is
1100          Nod : constant Node_Id := Right_Opnd (Op_Node);
1101          I   : Interp_Index;
1102          It  : Interp;
1103
1104       begin
1105          if not Is_Overloaded (Nod) then
1106             return Scope (Base_Type (Etype (Nod))) = S;
1107
1108          else
1109             Get_First_Interp (Nod, I, It);
1110             while Present (It.Typ) loop
1111                if Scope (Base_Type (It.Typ)) = S then
1112                   return True;
1113                end if;
1114
1115                Get_Next_Interp (I, It);
1116             end loop;
1117
1118             return False;
1119          end if;
1120       end Operand_Type_In_Scope;
1121
1122       ---------------
1123       -- Type_In_P --
1124       ---------------
1125
1126       function Type_In_P (Test : Kind_Test) return Entity_Id is
1127          E : Entity_Id;
1128
1129          function In_Decl return Boolean;
1130          --  Verify that node is not part of the type declaration for the
1131          --  candidate type, which would otherwise be invisible.
1132
1133          -------------
1134          -- In_Decl --
1135          -------------
1136
1137          function In_Decl return Boolean is
1138             Decl_Node : constant Node_Id := Parent (E);
1139             N2        : Node_Id;
1140
1141          begin
1142             N2 := N;
1143
1144             if Etype (E) = Any_Type then
1145                return True;
1146
1147             elsif No (Decl_Node) then
1148                return False;
1149
1150             else
1151                while Present (N2)
1152                  and then Nkind (N2) /= N_Compilation_Unit
1153                loop
1154                   if N2 = Decl_Node then
1155                      return True;
1156                   else
1157                      N2 := Parent (N2);
1158                   end if;
1159                end loop;
1160
1161                return False;
1162             end if;
1163          end In_Decl;
1164
1165       --  Start of processing for Type_In_P
1166
1167       begin
1168          --  If the context type is declared in the prefix package, this
1169          --  is the desired base type.
1170
1171          if Scope (Base_Type (Typ)) = Pack
1172            and then Test (Typ)
1173          then
1174             return Base_Type (Typ);
1175
1176          else
1177             E := First_Entity (Pack);
1178             while Present (E) loop
1179                if Test (E)
1180                  and then not In_Decl
1181                then
1182                   return E;
1183                end if;
1184
1185                Next_Entity (E);
1186             end loop;
1187
1188             return Empty;
1189          end if;
1190       end Type_In_P;
1191
1192    --  Start of processing for Make_Call_Into_Operator
1193
1194    begin
1195       Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
1196
1197       --  Binary operator
1198
1199       if Is_Binary then
1200          Set_Left_Opnd  (Op_Node, Relocate_Node (Act1));
1201          Set_Right_Opnd (Op_Node, Relocate_Node (Act2));
1202          Save_Interps (Act1, Left_Opnd  (Op_Node));
1203          Save_Interps (Act2, Right_Opnd (Op_Node));
1204          Act1 := Left_Opnd (Op_Node);
1205          Act2 := Right_Opnd (Op_Node);
1206
1207       --  Unary operator
1208
1209       else
1210          Set_Right_Opnd (Op_Node, Relocate_Node (Act1));
1211          Save_Interps (Act1, Right_Opnd (Op_Node));
1212          Act1 := Right_Opnd (Op_Node);
1213       end if;
1214
1215       --  If the operator is denoted by an expanded name, and the prefix is
1216       --  not Standard, but the operator is a predefined one whose scope is
1217       --  Standard, then this is an implicit_operator, inserted as an
1218       --  interpretation by the procedure of the same name. This procedure
1219       --  overestimates the presence of implicit operators, because it does
1220       --  not examine the type of the operands. Verify now that the operand
1221       --  type appears in the given scope. If right operand is universal,
1222       --  check the other operand. In the case of concatenation, either
1223       --  argument can be the component type, so check the type of the result.
1224       --  If both arguments are literals, look for a type of the right kind
1225       --  defined in the given scope. This elaborate nonsense is brought to
1226       --  you courtesy of b33302a. The type itself must be frozen, so we must
1227       --  find the type of the proper class in the given scope.
1228
1229       --  A final wrinkle is the multiplication operator for fixed point
1230       --  types, which is defined in Standard only, and not in the scope of
1231       --  the fixed_point type itself.
1232
1233       if Nkind (Name (N)) = N_Expanded_Name then
1234          Pack := Entity (Prefix (Name (N)));
1235
1236          --  If the entity being called is defined in the given package,
1237          --  it is a renaming of a predefined operator, and known to be
1238          --  legal.
1239
1240          if Scope (Entity (Name (N))) = Pack
1241             and then Pack /= Standard_Standard
1242          then
1243             null;
1244
1245          --  Visibility does not need to be checked in an instance: if the
1246          --  operator was not visible in the generic it has been diagnosed
1247          --  already, else there is an implicit copy of it in the instance.
1248
1249          elsif In_Instance then
1250             null;
1251
1252          elsif (Op_Name =  Name_Op_Multiply
1253               or else Op_Name = Name_Op_Divide)
1254            and then Is_Fixed_Point_Type (Etype (Left_Opnd  (Op_Node)))
1255            and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
1256          then
1257             if Pack /= Standard_Standard then
1258                Error := True;
1259             end if;
1260
1261          --  Ada 2005, AI-420:  Predefined equality on Universal_Access
1262          --  is available.
1263
1264          elsif Ada_Version >= Ada_05
1265            and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
1266            and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
1267          then
1268             null;
1269
1270          else
1271             Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
1272
1273             if Op_Name = Name_Op_Concat then
1274                Opnd_Type := Base_Type (Typ);
1275
1276             elsif (Scope (Opnd_Type) = Standard_Standard
1277                      and then Is_Binary)
1278               or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference
1279                         and then Is_Binary
1280                         and then not Comes_From_Source (Opnd_Type))
1281             then
1282                Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node)));
1283             end if;
1284
1285             if Scope (Opnd_Type) = Standard_Standard then
1286
1287                --  Verify that the scope contains a type that corresponds to
1288                --  the given literal. Optimize the case where Pack is Standard.
1289
1290                if Pack /= Standard_Standard then
1291
1292                   if Opnd_Type = Universal_Integer then
1293                      Orig_Type :=  Type_In_P (Is_Integer_Type'Access);
1294
1295                   elsif Opnd_Type = Universal_Real then
1296                      Orig_Type := Type_In_P (Is_Real_Type'Access);
1297
1298                   elsif Opnd_Type = Any_String then
1299                      Orig_Type := Type_In_P (Is_String_Type'Access);
1300
1301                   elsif Opnd_Type = Any_Access then
1302                      Orig_Type :=  Type_In_P (Is_Definite_Access_Type'Access);
1303
1304                   elsif Opnd_Type = Any_Composite then
1305                      Orig_Type := Type_In_P (Is_Composite_Type'Access);
1306
1307                      if Present (Orig_Type) then
1308                         if Has_Private_Component (Orig_Type) then
1309                            Orig_Type := Empty;
1310                         else
1311                            Set_Etype (Act1, Orig_Type);
1312
1313                            if Is_Binary then
1314                               Set_Etype (Act2, Orig_Type);
1315                            end if;
1316                         end if;
1317                      end if;
1318
1319                   else
1320                      Orig_Type := Empty;
1321                   end if;
1322
1323                   Error := No (Orig_Type);
1324                end if;
1325
1326             elsif Ekind (Opnd_Type) = E_Allocator_Type
1327                and then No (Type_In_P (Is_Definite_Access_Type'Access))
1328             then
1329                Error := True;
1330
1331             --  If the type is defined elsewhere, and the operator is not
1332             --  defined in the given scope (by a renaming declaration, e.g.)
1333             --  then this is an error as well. If an extension of System is
1334             --  present, and the type may be defined there, Pack must be
1335             --  System itself.
1336
1337             elsif Scope (Opnd_Type) /= Pack
1338               and then Scope (Op_Id) /= Pack
1339               and then (No (System_Aux_Id)
1340                          or else Scope (Opnd_Type) /= System_Aux_Id
1341                          or else Pack /= Scope (System_Aux_Id))
1342             then
1343                if not Is_Overloaded (Right_Opnd (Op_Node)) then
1344                   Error := True;
1345                else
1346                   Error := not Operand_Type_In_Scope (Pack);
1347                end if;
1348
1349             elsif Pack = Standard_Standard
1350               and then not Operand_Type_In_Scope (Standard_Standard)
1351             then
1352                Error := True;
1353             end if;
1354          end if;
1355
1356          if Error then
1357             Error_Msg_Node_2 := Pack;
1358             Error_Msg_NE
1359               ("& not declared in&", N, Selector_Name (Name (N)));
1360             Set_Etype (N, Any_Type);
1361             return;
1362          end if;
1363       end if;
1364
1365       Set_Chars  (Op_Node, Op_Name);
1366
1367       if not Is_Private_Type (Etype (N)) then
1368          Set_Etype (Op_Node, Base_Type (Etype (N)));
1369       else
1370          Set_Etype (Op_Node, Etype (N));
1371       end if;
1372
1373       --  If this is a call to a function that renames a predefined equality,
1374       --  the renaming declaration provides a type that must be used to
1375       --  resolve the operands. This must be done now because resolution of
1376       --  the equality node will not resolve any remaining ambiguity, and it
1377       --  assumes that the first operand is not overloaded.
1378
1379       if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
1380         and then Ekind (Func) = E_Function
1381         and then Is_Overloaded (Act1)
1382       then
1383          Resolve (Act1, Base_Type (Etype (First_Formal (Func))));
1384          Resolve (Act2, Base_Type (Etype (First_Formal (Func))));
1385       end if;
1386
1387       Set_Entity (Op_Node, Op_Id);
1388       Generate_Reference (Op_Id, N, ' ');
1389
1390       --  Do rewrite setting Comes_From_Source on the result if the original
1391       --  call came from source. Although it is not strictly the case that the
1392       --  operator as such comes from the source, logically it corresponds
1393       --  exactly to the function call in the source, so it should be marked
1394       --  this way (e.g. to make sure that validity checks work fine).
1395
1396       declare
1397          CS : constant Boolean := Comes_From_Source (N);
1398       begin
1399          Rewrite (N, Op_Node);
1400          Set_Comes_From_Source (N, CS);
1401       end;
1402
1403       --  If this is an arithmetic operator and the result type is private,
1404       --  the operands and the result must be wrapped in conversion to
1405       --  expose the underlying numeric type and expand the proper checks,
1406       --  e.g. on division.
1407
1408       if Is_Private_Type (Typ) then
1409          case Nkind (N) is
1410             when N_Op_Add  | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
1411             N_Op_Expon     | N_Op_Mod      | N_Op_Rem      =>
1412                Resolve_Intrinsic_Operator (N, Typ);
1413
1414             when N_Op_Plus | N_Op_Minus    | N_Op_Abs      =>
1415                Resolve_Intrinsic_Unary_Operator (N, Typ);
1416
1417             when others =>
1418                Resolve (N, Typ);
1419          end case;
1420       else
1421          Resolve (N, Typ);
1422       end if;
1423
1424       --  For predefined operators on literals, the operation freezes
1425       --  their type.
1426
1427       if Present (Orig_Type) then
1428          Set_Etype (Act1, Orig_Type);
1429          Freeze_Expression (Act1);
1430       end if;
1431    end Make_Call_Into_Operator;
1432
1433    -------------------
1434    -- Operator_Kind --
1435    -------------------
1436
1437    function Operator_Kind
1438      (Op_Name   : Name_Id;
1439       Is_Binary : Boolean) return Node_Kind
1440    is
1441       Kind : Node_Kind;
1442
1443    begin
1444       if Is_Binary then
1445          if    Op_Name =  Name_Op_And      then
1446             Kind := N_Op_And;
1447          elsif Op_Name =  Name_Op_Or       then
1448             Kind := N_Op_Or;
1449          elsif Op_Name =  Name_Op_Xor      then
1450             Kind := N_Op_Xor;
1451          elsif Op_Name =  Name_Op_Eq       then
1452             Kind := N_Op_Eq;
1453          elsif Op_Name =  Name_Op_Ne       then
1454             Kind := N_Op_Ne;
1455          elsif Op_Name =  Name_Op_Lt       then
1456             Kind := N_Op_Lt;
1457          elsif Op_Name =  Name_Op_Le       then
1458             Kind := N_Op_Le;
1459          elsif Op_Name =  Name_Op_Gt       then
1460             Kind := N_Op_Gt;
1461          elsif Op_Name =  Name_Op_Ge       then
1462             Kind := N_Op_Ge;
1463          elsif Op_Name =  Name_Op_Add      then
1464             Kind := N_Op_Add;
1465          elsif Op_Name =  Name_Op_Subtract then
1466             Kind := N_Op_Subtract;
1467          elsif Op_Name =  Name_Op_Concat   then
1468             Kind := N_Op_Concat;
1469          elsif Op_Name =  Name_Op_Multiply then
1470             Kind := N_Op_Multiply;
1471          elsif Op_Name =  Name_Op_Divide   then
1472             Kind := N_Op_Divide;
1473          elsif Op_Name =  Name_Op_Mod      then
1474             Kind := N_Op_Mod;
1475          elsif Op_Name =  Name_Op_Rem      then
1476             Kind := N_Op_Rem;
1477          elsif Op_Name =  Name_Op_Expon    then
1478             Kind := N_Op_Expon;
1479          else
1480             raise Program_Error;
1481          end if;
1482
1483       --  Unary operators
1484
1485       else
1486          if    Op_Name =  Name_Op_Add      then
1487             Kind := N_Op_Plus;
1488          elsif Op_Name =  Name_Op_Subtract then
1489             Kind := N_Op_Minus;
1490          elsif Op_Name =  Name_Op_Abs      then
1491             Kind := N_Op_Abs;
1492          elsif Op_Name =  Name_Op_Not      then
1493             Kind := N_Op_Not;
1494          else
1495             raise Program_Error;
1496          end if;
1497       end if;
1498
1499       return Kind;
1500    end Operator_Kind;
1501
1502    ----------------------------
1503    -- Preanalyze_And_Resolve --
1504    ----------------------------
1505
1506    procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is
1507       Save_Full_Analysis : constant Boolean := Full_Analysis;
1508
1509    begin
1510       Full_Analysis := False;
1511       Expander_Mode_Save_And_Set (False);
1512
1513       --  We suppress all checks for this analysis, since the checks will
1514       --  be applied properly, and in the right location, when the default
1515       --  expression is reanalyzed and reexpanded later on.
1516
1517       Analyze_And_Resolve (N, T, Suppress => All_Checks);
1518
1519       Expander_Mode_Restore;
1520       Full_Analysis := Save_Full_Analysis;
1521    end Preanalyze_And_Resolve;
1522
1523    --  Version without context type
1524
1525    procedure Preanalyze_And_Resolve (N : Node_Id) is
1526       Save_Full_Analysis : constant Boolean := Full_Analysis;
1527
1528    begin
1529       Full_Analysis := False;
1530       Expander_Mode_Save_And_Set (False);
1531
1532       Analyze (N);
1533       Resolve (N, Etype (N), Suppress => All_Checks);
1534
1535       Expander_Mode_Restore;
1536       Full_Analysis := Save_Full_Analysis;
1537    end Preanalyze_And_Resolve;
1538
1539    ----------------------------------
1540    -- Replace_Actual_Discriminants --
1541    ----------------------------------
1542
1543    procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is
1544       Loc : constant Source_Ptr := Sloc (N);
1545       Tsk : Node_Id := Empty;
1546
1547       function Process_Discr (Nod : Node_Id) return Traverse_Result;
1548
1549       -------------------
1550       -- Process_Discr --
1551       -------------------
1552
1553       function Process_Discr (Nod : Node_Id) return Traverse_Result is
1554          Ent : Entity_Id;
1555
1556       begin
1557          if Nkind (Nod) = N_Identifier then
1558             Ent := Entity (Nod);
1559
1560             if Present (Ent)
1561               and then Ekind (Ent) = E_Discriminant
1562             then
1563                Rewrite (Nod,
1564                  Make_Selected_Component (Loc,
1565                    Prefix        => New_Copy_Tree (Tsk, New_Sloc => Loc),
1566                    Selector_Name => Make_Identifier (Loc, Chars (Ent))));
1567
1568                Set_Etype (Nod, Etype (Ent));
1569             end if;
1570
1571          end if;
1572
1573          return OK;
1574       end Process_Discr;
1575
1576       procedure Replace_Discrs is new Traverse_Proc (Process_Discr);
1577
1578    --  Start of processing for Replace_Actual_Discriminants
1579
1580    begin
1581       if not Expander_Active then
1582          return;
1583       end if;
1584
1585       if Nkind (Name (N)) = N_Selected_Component then
1586          Tsk := Prefix (Name (N));
1587
1588       elsif Nkind (Name (N)) = N_Indexed_Component then
1589          Tsk := Prefix (Prefix (Name (N)));
1590       end if;
1591
1592       if No (Tsk) then
1593          return;
1594       else
1595          Replace_Discrs (Default);
1596       end if;
1597    end Replace_Actual_Discriminants;
1598
1599    -------------
1600    -- Resolve --
1601    -------------
1602
1603    procedure Resolve (N : Node_Id; Typ : Entity_Id) is
1604       Ambiguous : Boolean   := False;
1605       Ctx_Type  : Entity_Id := Typ;
1606       Expr_Type : Entity_Id := Empty; -- prevent junk warning
1607       Err_Type  : Entity_Id := Empty;
1608       Found     : Boolean   := False;
1609       From_Lib  : Boolean;
1610       I         : Interp_Index;
1611       I1        : Interp_Index := 0;  -- prevent junk warning
1612       It        : Interp;
1613       It1       : Interp;
1614       Seen      : Entity_Id := Empty; -- prevent junk warning
1615
1616       function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
1617       --  Determine whether a node comes from a predefined library unit or
1618       --  Standard.
1619
1620       procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
1621       --  Try and fix up a literal so that it matches its expected type. New
1622       --  literals are manufactured if necessary to avoid cascaded errors.
1623
1624       procedure Resolution_Failed;
1625       --  Called when attempt at resolving current expression fails
1626
1627       ------------------------------------
1628       -- Comes_From_Predefined_Lib_Unit --
1629       -------------------------------------
1630
1631       function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is
1632       begin
1633          return
1634            Sloc (Nod) = Standard_Location
1635              or else Is_Predefined_File_Name (Unit_File_Name (
1636                        Get_Source_Unit (Sloc (Nod))));
1637       end Comes_From_Predefined_Lib_Unit;
1638
1639       --------------------
1640       -- Patch_Up_Value --
1641       --------------------
1642
1643       procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is
1644       begin
1645          if Nkind (N) = N_Integer_Literal
1646            and then Is_Real_Type (Typ)
1647          then
1648             Rewrite (N,
1649               Make_Real_Literal (Sloc (N),
1650                 Realval => UR_From_Uint (Intval (N))));
1651             Set_Etype (N, Universal_Real);
1652             Set_Is_Static_Expression (N);
1653
1654          elsif Nkind (N) = N_Real_Literal
1655            and then Is_Integer_Type (Typ)
1656          then
1657             Rewrite (N,
1658               Make_Integer_Literal (Sloc (N),
1659                 Intval => UR_To_Uint (Realval (N))));
1660             Set_Etype (N, Universal_Integer);
1661             Set_Is_Static_Expression (N);
1662
1663          elsif Nkind (N) = N_String_Literal
1664            and then Is_Character_Type (Typ)
1665          then
1666             Set_Character_Literal_Name (Char_Code (Character'Pos ('A')));
1667             Rewrite (N,
1668               Make_Character_Literal (Sloc (N),
1669                 Chars => Name_Find,
1670                 Char_Literal_Value =>
1671                   UI_From_Int (Character'Pos ('A'))));
1672             Set_Etype (N, Any_Character);
1673             Set_Is_Static_Expression (N);
1674
1675          elsif Nkind (N) /= N_String_Literal
1676            and then Is_String_Type (Typ)
1677          then
1678             Rewrite (N,
1679               Make_String_Literal (Sloc (N),
1680                 Strval => End_String));
1681
1682          elsif Nkind (N) = N_Range then
1683             Patch_Up_Value (Low_Bound (N), Typ);
1684             Patch_Up_Value (High_Bound (N), Typ);
1685          end if;
1686       end Patch_Up_Value;
1687
1688       -----------------------
1689       -- Resolution_Failed --
1690       -----------------------
1691
1692       procedure Resolution_Failed is
1693       begin
1694          Patch_Up_Value (N, Typ);
1695          Set_Etype (N, Typ);
1696          Debug_A_Exit ("resolving  ", N, " (done, resolution failed)");
1697          Set_Is_Overloaded (N, False);
1698
1699          --  The caller will return without calling the expander, so we need
1700          --  to set the analyzed flag. Note that it is fine to set Analyzed
1701          --  to True even if we are in the middle of a shallow analysis,
1702          --  (see the spec of sem for more details) since this is an error
1703          --  situation anyway, and there is no point in repeating the
1704          --  analysis later (indeed it won't work to repeat it later, since
1705          --  we haven't got a clear resolution of which entity is being
1706          --  referenced.)
1707
1708          Set_Analyzed (N, True);
1709          return;
1710       end Resolution_Failed;
1711
1712    --  Start of processing for Resolve
1713
1714    begin
1715       if N = Error then
1716          return;
1717       end if;
1718
1719       --  Access attribute on remote subprogram cannot be used for
1720       --  a non-remote access-to-subprogram type.
1721
1722       if Nkind (N) = N_Attribute_Reference
1723         and then (Attribute_Name (N) = Name_Access
1724                     or else Attribute_Name (N) = Name_Unrestricted_Access
1725                     or else Attribute_Name (N) = Name_Unchecked_Access)
1726         and then Comes_From_Source (N)
1727         and then Is_Entity_Name (Prefix (N))
1728         and then Is_Subprogram (Entity (Prefix (N)))
1729         and then Is_Remote_Call_Interface (Entity (Prefix (N)))
1730         and then not Is_Remote_Access_To_Subprogram_Type (Typ)
1731       then
1732          Error_Msg_N
1733            ("prefix must statically denote a non-remote subprogram", N);
1734       end if;
1735
1736       From_Lib := Comes_From_Predefined_Lib_Unit (N);
1737
1738       --  If the context is a Remote_Access_To_Subprogram, access attributes
1739       --  must be resolved with the corresponding fat pointer. There is no need
1740       --  to check for the attribute name since the return type of an
1741       --  attribute is never a remote type.
1742
1743       if Nkind (N) = N_Attribute_Reference
1744         and then Comes_From_Source (N)
1745         and then (Is_Remote_Call_Interface (Typ)
1746                     or else Is_Remote_Types (Typ))
1747       then
1748          declare
1749             Attr      : constant Attribute_Id :=
1750                           Get_Attribute_Id (Attribute_Name (N));
1751             Pref      : constant Node_Id      := Prefix (N);
1752             Decl      : Node_Id;
1753             Spec      : Node_Id;
1754             Is_Remote : Boolean := True;
1755
1756          begin
1757             --  Check that Typ is a remote access-to-subprogram type
1758
1759             if Is_Remote_Access_To_Subprogram_Type (Typ) then
1760                --  Prefix (N) must statically denote a remote subprogram
1761                --  declared in a package specification.
1762
1763                if Attr = Attribute_Access then
1764                   Decl := Unit_Declaration_Node (Entity (Pref));
1765
1766                   if Nkind (Decl) = N_Subprogram_Body then
1767                      Spec := Corresponding_Spec (Decl);
1768
1769                      if not No (Spec) then
1770                         Decl := Unit_Declaration_Node (Spec);
1771                      end if;
1772                   end if;
1773
1774                   Spec := Parent (Decl);
1775
1776                   if not Is_Entity_Name (Prefix (N))
1777                     or else Nkind (Spec) /= N_Package_Specification
1778                     or else
1779                       not Is_Remote_Call_Interface (Defining_Entity (Spec))
1780                   then
1781                      Is_Remote := False;
1782                      Error_Msg_N
1783                        ("prefix must statically denote a remote subprogram ",
1784                         N);
1785                   end if;
1786                end if;
1787
1788                --   If we are generating code for a distributed program.
1789                --   perform semantic checks against the corresponding
1790                --   remote entities.
1791
1792                if (Attr = Attribute_Access
1793                     or else Attr = Attribute_Unchecked_Access
1794                     or else Attr = Attribute_Unrestricted_Access)
1795                  and then Expander_Active
1796                  and then Get_PCS_Name /= Name_No_DSA
1797                then
1798                   Check_Subtype_Conformant
1799                     (New_Id  => Entity (Prefix (N)),
1800                      Old_Id  => Designated_Type
1801                        (Corresponding_Remote_Type (Typ)),
1802                      Err_Loc => N);
1803
1804                   if Is_Remote then
1805                      Process_Remote_AST_Attribute (N, Typ);
1806                   end if;
1807                end if;
1808             end if;
1809          end;
1810       end if;
1811
1812       Debug_A_Entry ("resolving  ", N);
1813
1814       if Comes_From_Source (N) then
1815          if Is_Fixed_Point_Type (Typ) then
1816             Check_Restriction (No_Fixed_Point, N);
1817
1818          elsif Is_Floating_Point_Type (Typ)
1819            and then Typ /= Universal_Real
1820            and then Typ /= Any_Real
1821          then
1822             Check_Restriction (No_Floating_Point, N);
1823          end if;
1824       end if;
1825
1826       --  Return if already analyzed
1827
1828       if Analyzed (N) then
1829          Debug_A_Exit ("resolving  ", N, "  (done, already analyzed)");
1830          return;
1831
1832       --  Return if type = Any_Type (previous error encountered)
1833
1834       elsif Etype (N) = Any_Type then
1835          Debug_A_Exit ("resolving  ", N, "  (done, Etype = Any_Type)");
1836          return;
1837       end if;
1838
1839       Check_Parameterless_Call (N);
1840
1841       --  If not overloaded, then we know the type, and all that needs doing
1842       --  is to check that this type is compatible with the context.
1843
1844       if not Is_Overloaded (N) then
1845          Found := Covers (Typ, Etype (N));
1846          Expr_Type := Etype (N);
1847
1848       --  In the overloaded case, we must select the interpretation that
1849       --  is compatible with the context (i.e. the type passed to Resolve)
1850
1851       else
1852          --  Loop through possible interpretations
1853
1854          Get_First_Interp (N, I, It);
1855          Interp_Loop : while Present (It.Typ) loop
1856
1857             --  We are only interested in interpretations that are compatible
1858             --  with the expected type, any other interpretations are ignored.
1859
1860             if not Covers (Typ, It.Typ) then
1861                if Debug_Flag_V then
1862                   Write_Str ("    interpretation incompatible with context");
1863                   Write_Eol;
1864                end if;
1865
1866             else
1867                --  Skip the current interpretation if it is disabled by an
1868                --  abstract operator. This action is performed only when the
1869                --  type against which we are resolving is the same as the
1870                --  type of the interpretation.
1871
1872                if Ada_Version >= Ada_05
1873                  and then It.Typ = Typ
1874                  and then Typ /= Universal_Integer
1875                  and then Typ /= Universal_Real
1876                  and then Present (It.Abstract_Op)
1877                then
1878                   goto Continue;
1879                end if;
1880
1881                --  First matching interpretation
1882
1883                if not Found then
1884                   Found := True;
1885                   I1    := I;
1886                   Seen  := It.Nam;
1887                   Expr_Type := It.Typ;
1888
1889                --  Matching interpretation that is not the first, maybe an
1890                --  error, but there are some cases where preference rules are
1891                --  used to choose between the two possibilities. These and
1892                --  some more obscure cases are handled in Disambiguate.
1893
1894                else
1895                   --  If the current statement is part of a predefined library
1896                   --  unit, then all interpretations which come from user level
1897                   --  packages should not be considered.
1898
1899                   if From_Lib
1900                     and then not Comes_From_Predefined_Lib_Unit (It.Nam)
1901                   then
1902                      goto Continue;
1903                   end if;
1904
1905                   Error_Msg_Sloc := Sloc (Seen);
1906                   It1 := Disambiguate (N, I1, I, Typ);
1907
1908                   --  Disambiguation has succeeded. Skip the remaining
1909                   --  interpretations.
1910
1911                   if It1 /= No_Interp then
1912                      Seen := It1.Nam;
1913                      Expr_Type := It1.Typ;
1914
1915                      while Present (It.Typ) loop
1916                         Get_Next_Interp (I, It);
1917                      end loop;
1918
1919                   else
1920                      --  Before we issue an ambiguity complaint, check for
1921                      --  the case of a subprogram call where at least one
1922                      --  of the arguments is Any_Type, and if so, suppress
1923                      --  the message, since it is a cascaded error.
1924
1925                      if Nkind_In (N, N_Function_Call,
1926                                      N_Procedure_Call_Statement)
1927                      then
1928                         declare
1929                            A : Node_Id;
1930                            E : Node_Id;
1931
1932                         begin
1933                            A := First_Actual (N);
1934                            while Present (A) loop
1935                               E := A;
1936
1937                               if Nkind (E) = N_Parameter_Association then
1938                                  E := Explicit_Actual_Parameter (E);
1939                               end if;
1940
1941                               if Etype (E) = Any_Type then
1942                                  if Debug_Flag_V then
1943                                     Write_Str ("Any_Type in call");
1944                                     Write_Eol;
1945                                  end if;
1946
1947                                  exit Interp_Loop;
1948                               end if;
1949
1950                               Next_Actual (A);
1951                            end loop;
1952                         end;
1953
1954                      elsif Nkind (N) in N_Binary_Op
1955                        and then (Etype (Left_Opnd (N)) = Any_Type
1956                                   or else Etype (Right_Opnd (N)) = Any_Type)
1957                      then
1958                         exit Interp_Loop;
1959
1960                      elsif Nkind (N) in  N_Unary_Op
1961                        and then Etype (Right_Opnd (N)) = Any_Type
1962                      then
1963                         exit Interp_Loop;
1964                      end if;
1965
1966                      --  Not that special case, so issue message using the
1967                      --  flag Ambiguous to control printing of the header
1968                      --  message only at the start of an ambiguous set.
1969
1970                      if not Ambiguous then
1971                         if Nkind (N) = N_Function_Call
1972                           and then Nkind (Name (N)) = N_Explicit_Dereference
1973                         then
1974                            Error_Msg_N
1975                              ("ambiguous expression "
1976                                & "(cannot resolve indirect call)!", N);
1977                         else
1978                            Error_Msg_NE
1979                              ("ambiguous expression (cannot resolve&)!",
1980                               N, It.Nam);
1981                         end if;
1982
1983                         Ambiguous := True;
1984
1985                         if Nkind (Parent (Seen)) = N_Full_Type_Declaration then
1986                            Error_Msg_N
1987                              ("\\possible interpretation (inherited)#!", N);
1988                         else
1989                            Error_Msg_N ("\\possible interpretation#!", N);
1990                         end if;
1991                      end if;
1992
1993                      Error_Msg_Sloc := Sloc (It.Nam);
1994
1995                      --  By default, the error message refers to the candidate
1996                      --  interpretation. But if it is a predefined operator, it
1997                      --  is implicitly declared at the declaration of the type
1998                      --  of the operand. Recover the sloc of that declaration
1999                      --  for the error message.
2000
2001                      if Nkind (N) in N_Op
2002                        and then Scope (It.Nam) = Standard_Standard
2003                        and then not Is_Overloaded (Right_Opnd (N))
2004                        and then Scope (Base_Type (Etype (Right_Opnd (N)))) /=
2005                                                              Standard_Standard
2006                      then
2007                         Err_Type := First_Subtype (Etype (Right_Opnd (N)));
2008
2009                         if Comes_From_Source (Err_Type)
2010                           and then Present (Parent (Err_Type))
2011                         then
2012                            Error_Msg_Sloc := Sloc (Parent (Err_Type));
2013                         end if;
2014
2015                      elsif Nkind (N) in N_Binary_Op
2016                        and then Scope (It.Nam) = Standard_Standard
2017                        and then not Is_Overloaded (Left_Opnd (N))
2018                        and then Scope (Base_Type (Etype (Left_Opnd (N)))) /=
2019                                                              Standard_Standard
2020                      then
2021                         Err_Type := First_Subtype (Etype (Left_Opnd (N)));
2022
2023                         if Comes_From_Source (Err_Type)
2024                           and then Present (Parent (Err_Type))
2025                         then
2026                            Error_Msg_Sloc := Sloc (Parent (Err_Type));
2027                         end if;
2028
2029                      --  If this is an indirect call, use the subprogram_type
2030                      --  in the message, to have a meaningful location.
2031                      --  Indicate as well if this is an inherited operation,
2032                      --  created by a type declaration.
2033
2034                      elsif Nkind (N) = N_Function_Call
2035                        and then Nkind (Name (N)) = N_Explicit_Dereference
2036                        and then Is_Type (It.Nam)
2037                      then
2038                         Err_Type := It.Nam;
2039                         Error_Msg_Sloc :=
2040                           Sloc (Associated_Node_For_Itype (Err_Type));
2041                      else
2042                         Err_Type := Empty;
2043                      end if;
2044
2045                      if Nkind (N) in N_Op
2046                        and then Scope (It.Nam) = Standard_Standard
2047                        and then Present (Err_Type)
2048                      then
2049                         --  Special-case the message for universal_fixed
2050                         --  operators, which are not declared with the type
2051                         --  of the operand, but appear forever in Standard.
2052
2053                         if  It.Typ = Universal_Fixed
2054                           and then Scope (It.Nam) = Standard_Standard
2055                         then
2056                            Error_Msg_N
2057                              ("\\possible interpretation as " &
2058                                 "universal_fixed operation " &
2059                                   "(RM 4.5.5 (19))", N);
2060                         else
2061                            Error_Msg_N
2062                              ("\\possible interpretation (predefined)#!", N);
2063                         end if;
2064
2065                      elsif
2066                        Nkind (Parent (It.Nam)) = N_Full_Type_Declaration
2067                      then
2068                         Error_Msg_N
2069                           ("\\possible interpretation (inherited)#!", N);
2070                      else
2071                         Error_Msg_N ("\\possible interpretation#!", N);
2072                      end if;
2073
2074                   end if;
2075                end if;
2076
2077                --  We have a matching interpretation, Expr_Type is the type
2078                --  from this interpretation, and Seen is the entity.
2079
2080                --  For an operator, just set the entity name. The type will be
2081                --  set by the specific operator resolution routine.
2082
2083                if Nkind (N) in N_Op then
2084                   Set_Entity (N, Seen);
2085                   Generate_Reference (Seen, N);
2086
2087                elsif Nkind (N) = N_Character_Literal then
2088                   Set_Etype (N, Expr_Type);
2089
2090                --  For an explicit dereference, attribute reference, range,
2091                --  short-circuit form (which is not an operator node), or call
2092                --  with a name that is an explicit dereference, there is
2093                --  nothing to be done at this point.
2094
2095                elsif Nkind_In (N, N_Explicit_Dereference,
2096                                   N_Attribute_Reference,
2097                                   N_And_Then,
2098                                   N_Indexed_Component,
2099                                   N_Or_Else,
2100                                   N_Range,
2101                                   N_Selected_Component,
2102                                   N_Slice)
2103                  or else Nkind (Name (N)) = N_Explicit_Dereference
2104                then
2105                   null;
2106
2107                --  For procedure or function calls, set the type of the name,
2108                --  and also the entity pointer for the prefix
2109
2110                elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
2111                  and then (Is_Entity_Name (Name (N))
2112                             or else Nkind (Name (N)) = N_Operator_Symbol)
2113                then
2114                   Set_Etype  (Name (N), Expr_Type);
2115                   Set_Entity (Name (N), Seen);
2116                   Generate_Reference (Seen, Name (N));
2117
2118                elsif Nkind (N) = N_Function_Call
2119                  and then Nkind (Name (N)) = N_Selected_Component
2120                then
2121                   Set_Etype (Name (N), Expr_Type);
2122                   Set_Entity (Selector_Name (Name (N)), Seen);
2123                   Generate_Reference (Seen, Selector_Name (Name (N)));
2124
2125                --  For all other cases, just set the type of the Name
2126
2127                else
2128                   Set_Etype (Name (N), Expr_Type);
2129                end if;
2130
2131             end if;
2132
2133             <<Continue>>
2134
2135             --  Move to next interpretation
2136
2137             exit Interp_Loop when No (It.Typ);
2138
2139             Get_Next_Interp (I, It);
2140          end loop Interp_Loop;
2141       end if;
2142
2143       --  At this stage Found indicates whether or not an acceptable
2144       --  interpretation exists. If not, then we have an error, except
2145       --  that if the context is Any_Type as a result of some other error,
2146       --  then we suppress the error report.
2147
2148       if not Found then
2149          if Typ /= Any_Type then
2150
2151             --  If type we are looking for is Void, then this is the procedure
2152             --  call case, and the error is simply that what we gave is not a
2153             --  procedure name (we think of procedure calls as expressions with
2154             --  types internally, but the user doesn't think of them this way!)
2155
2156             if Typ = Standard_Void_Type then
2157
2158                --  Special case message if function used as a procedure
2159
2160                if Nkind (N) = N_Procedure_Call_Statement
2161                  and then Is_Entity_Name (Name (N))
2162                  and then Ekind (Entity (Name (N))) = E_Function
2163                then
2164                   Error_Msg_NE
2165                     ("cannot use function & in a procedure call",
2166                      Name (N), Entity (Name (N)));
2167
2168                --  Otherwise give general message (not clear what cases this
2169                --  covers, but no harm in providing for them!)
2170
2171                else
2172                   Error_Msg_N ("expect procedure name in procedure call", N);
2173                end if;
2174
2175                Found := True;
2176
2177             --  Otherwise we do have a subexpression with the wrong type
2178
2179             --  Check for the case of an allocator which uses an access type
2180             --  instead of the designated type. This is a common error and we
2181             --  specialize the message, posting an error on the operand of the
2182             --  allocator, complaining that we expected the designated type of
2183             --  the allocator.
2184
2185             elsif Nkind (N) = N_Allocator
2186               and then Ekind (Typ) in Access_Kind
2187               and then Ekind (Etype (N)) in Access_Kind
2188               and then Designated_Type (Etype (N)) = Typ
2189             then
2190                Wrong_Type (Expression (N), Designated_Type (Typ));
2191                Found := True;
2192
2193             --  Check for view mismatch on Null in instances, for which the
2194             --  view-swapping mechanism has no identifier.
2195
2196             elsif (In_Instance or else In_Inlined_Body)
2197               and then (Nkind (N) = N_Null)
2198               and then Is_Private_Type (Typ)
2199               and then Is_Access_Type (Full_View (Typ))
2200             then
2201                Resolve (N, Full_View (Typ));
2202                Set_Etype (N, Typ);
2203                return;
2204
2205             --  Check for an aggregate. Sometimes we can get bogus aggregates
2206             --  from misuse of parentheses, and we are about to complain about
2207             --  the aggregate without even looking inside it.
2208
2209             --  Instead, if we have an aggregate of type Any_Composite, then
2210             --  analyze and resolve the component fields, and then only issue
2211             --  another message if we get no errors doing this (otherwise
2212             --  assume that the errors in the aggregate caused the problem).
2213
2214             elsif Nkind (N) = N_Aggregate
2215               and then Etype (N) = Any_Composite
2216             then
2217                --  Disable expansion in any case. If there is a type mismatch
2218                --  it may be fatal to try to expand the aggregate. The flag
2219                --  would otherwise be set to false when the error is posted.
2220
2221                Expander_Active := False;
2222
2223                declare
2224                   procedure Check_Aggr (Aggr : Node_Id);
2225                   --  Check one aggregate, and set Found to True if we have a
2226                   --  definite error in any of its elements
2227
2228                   procedure Check_Elmt (Aelmt : Node_Id);
2229                   --  Check one element of aggregate and set Found to True if
2230                   --  we definitely have an error in the element.
2231
2232                   ----------------
2233                   -- Check_Aggr --
2234                   ----------------
2235
2236                   procedure Check_Aggr (Aggr : Node_Id) is
2237                      Elmt : Node_Id;
2238
2239                   begin
2240                      if Present (Expressions (Aggr)) then
2241                         Elmt := First (Expressions (Aggr));
2242                         while Present (Elmt) loop
2243                            Check_Elmt (Elmt);
2244                            Next (Elmt);
2245                         end loop;
2246                      end if;
2247
2248                      if Present (Component_Associations (Aggr)) then
2249                         Elmt := First (Component_Associations (Aggr));
2250                         while Present (Elmt) loop
2251
2252                            --  If this is a default-initialized component, then
2253                            --  there is nothing to check. The box will be
2254                            --  replaced by the appropriate call during late
2255                            --  expansion.
2256
2257                            if not Box_Present (Elmt) then
2258                               Check_Elmt (Expression (Elmt));
2259                            end if;
2260
2261                            Next (Elmt);
2262                         end loop;
2263                      end if;
2264                   end Check_Aggr;
2265
2266                   ----------------
2267                   -- Check_Elmt --
2268                   ----------------
2269
2270                   procedure Check_Elmt (Aelmt : Node_Id) is
2271                   begin
2272                      --  If we have a nested aggregate, go inside it (to
2273                      --  attempt a naked analyze-resolve of the aggregate
2274                      --  can cause undesirable cascaded errors). Do not
2275                      --  resolve expression if it needs a type from context,
2276                      --  as for integer * fixed expression.
2277
2278                      if Nkind (Aelmt) = N_Aggregate then
2279                         Check_Aggr (Aelmt);
2280
2281                      else
2282                         Analyze (Aelmt);
2283
2284                         if not Is_Overloaded (Aelmt)
2285                           and then Etype (Aelmt) /= Any_Fixed
2286                         then
2287                            Resolve (Aelmt);
2288                         end if;
2289
2290                         if Etype (Aelmt) = Any_Type then
2291                            Found := True;
2292                         end if;
2293                      end if;
2294                   end Check_Elmt;
2295
2296                begin
2297                   Check_Aggr (N);
2298                end;
2299             end if;
2300
2301             --  If an error message was issued already, Found got reset
2302             --  to True, so if it is still False, issue the standard
2303             --  Wrong_Type message.
2304
2305             if not Found then
2306                if Is_Overloaded (N)
2307                  and then Nkind (N) = N_Function_Call
2308                then
2309                   declare
2310                      Subp_Name : Node_Id;
2311                   begin
2312                      if Is_Entity_Name (Name (N)) then
2313                         Subp_Name := Name (N);
2314
2315                      elsif Nkind (Name (N)) = N_Selected_Component then
2316
2317                         --  Protected operation: retrieve operation name
2318
2319                         Subp_Name := Selector_Name (Name (N));
2320                      else
2321                         raise Program_Error;
2322                      end if;
2323
2324                      Error_Msg_Node_2 := Typ;
2325                      Error_Msg_NE ("no visible interpretation of&" &
2326                        " matches expected type&", N, Subp_Name);
2327                   end;
2328
2329                   if All_Errors_Mode then
2330                      declare
2331                         Index : Interp_Index;
2332                         It    : Interp;
2333
2334                      begin
2335                         Error_Msg_N ("\\possible interpretations:", N);
2336
2337                         Get_First_Interp (Name (N), Index, It);
2338                         while Present (It.Nam) loop
2339                            Error_Msg_Sloc := Sloc (It.Nam);
2340                            Error_Msg_Node_2 := It.Nam;
2341                            Error_Msg_NE
2342                              ("\\  type& for & declared#", N, It.Typ);
2343                            Get_Next_Interp (Index, It);
2344                         end loop;
2345                      end;
2346
2347                   else
2348                      Error_Msg_N ("\use -gnatf for details", N);
2349                   end if;
2350                else
2351                   Wrong_Type (N, Typ);
2352                end if;
2353             end if;
2354          end if;
2355
2356          Resolution_Failed;
2357          return;
2358
2359       --  Test if we have more than one interpretation for the context
2360
2361       elsif Ambiguous then
2362          Resolution_Failed;
2363          return;
2364
2365       --  Here we have an acceptable interpretation for the context
2366
2367       else
2368          --  Propagate type information and normalize tree for various
2369          --  predefined operations. If the context only imposes a class of
2370          --  types, rather than a specific type, propagate the actual type
2371          --  downward.
2372
2373          if Typ = Any_Integer
2374            or else Typ = Any_Boolean
2375            or else Typ = Any_Modular
2376            or else Typ = Any_Real
2377            or else Typ = Any_Discrete
2378          then
2379             Ctx_Type := Expr_Type;
2380
2381             --  Any_Fixed is legal in a real context only if a specific
2382             --  fixed point type is imposed. If Norman Cohen can be
2383             --  confused by this, it deserves a separate message.
2384
2385             if Typ = Any_Real
2386               and then Expr_Type = Any_Fixed
2387             then
2388                Error_Msg_N ("illegal context for mixed mode operation", N);
2389                Set_Etype (N, Universal_Real);
2390                Ctx_Type := Universal_Real;
2391             end if;
2392          end if;
2393
2394          --  A user-defined operator is transformed into a function call at
2395          --  this point, so that further processing knows that operators are
2396          --  really operators (i.e. are predefined operators). User-defined
2397          --  operators that are intrinsic are just renamings of the predefined
2398          --  ones, and need not be turned into calls either, but if they rename
2399          --  a different operator, we must transform the node accordingly.
2400          --  Instantiations of Unchecked_Conversion are intrinsic but are
2401          --  treated as functions, even if given an operator designator.
2402
2403          if Nkind (N) in N_Op
2404            and then Present (Entity (N))
2405            and then Ekind (Entity (N)) /= E_Operator
2406          then
2407
2408             if not Is_Predefined_Op (Entity (N)) then
2409                Rewrite_Operator_As_Call (N, Entity (N));
2410
2411             elsif Present (Alias (Entity (N)))
2412               and then
2413                 Nkind (Parent (Parent (Entity (N)))) =
2414                                     N_Subprogram_Renaming_Declaration
2415             then
2416                Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
2417
2418                --  If the node is rewritten, it will be fully resolved in
2419                --  Rewrite_Renamed_Operator.
2420
2421                if Analyzed (N) then
2422                   return;
2423                end if;
2424             end if;
2425          end if;
2426
2427          case N_Subexpr'(Nkind (N)) is
2428
2429             when N_Aggregate => Resolve_Aggregate                (N, Ctx_Type);
2430
2431             when N_Allocator => Resolve_Allocator                (N, Ctx_Type);
2432
2433             when N_And_Then | N_Or_Else
2434                              => Resolve_Short_Circuit            (N, Ctx_Type);
2435
2436             when N_Attribute_Reference
2437                              => Resolve_Attribute                (N, Ctx_Type);
2438
2439             when N_Character_Literal
2440                              => Resolve_Character_Literal        (N, Ctx_Type);
2441
2442             when N_Conditional_Expression
2443                              => Resolve_Conditional_Expression   (N, Ctx_Type);
2444
2445             when N_Expanded_Name
2446                              => Resolve_Entity_Name              (N, Ctx_Type);
2447
2448             when N_Extension_Aggregate
2449                              => Resolve_Extension_Aggregate      (N, Ctx_Type);
2450
2451             when N_Explicit_Dereference
2452                              => Resolve_Explicit_Dereference     (N, Ctx_Type);
2453
2454             when N_Function_Call
2455                              => Resolve_Call                     (N, Ctx_Type);
2456
2457             when N_Identifier
2458                              => Resolve_Entity_Name              (N, Ctx_Type);
2459
2460             when N_Indexed_Component
2461                              => Resolve_Indexed_Component        (N, Ctx_Type);
2462
2463             when N_Integer_Literal
2464                              => Resolve_Integer_Literal          (N, Ctx_Type);
2465
2466             when N_Membership_Test
2467                              => Resolve_Membership_Op            (N, Ctx_Type);
2468
2469             when N_Null      => Resolve_Null                     (N, Ctx_Type);
2470
2471             when N_Op_And | N_Op_Or | N_Op_Xor
2472                              => Resolve_Logical_Op               (N, Ctx_Type);
2473
2474             when N_Op_Eq | N_Op_Ne
2475                              => Resolve_Equality_Op              (N, Ctx_Type);
2476
2477             when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
2478                              => Resolve_Comparison_Op            (N, Ctx_Type);
2479
2480             when N_Op_Not    => Resolve_Op_Not                   (N, Ctx_Type);
2481
2482             when N_Op_Add    | N_Op_Subtract | N_Op_Multiply |
2483                  N_Op_Divide | N_Op_Mod      | N_Op_Rem
2484
2485                              => Resolve_Arithmetic_Op            (N, Ctx_Type);
2486
2487             when N_Op_Concat => Resolve_Op_Concat                (N, Ctx_Type);
2488
2489             when N_Op_Expon  => Resolve_Op_Expon                 (N, Ctx_Type);
2490
2491             when N_Op_Plus | N_Op_Minus  | N_Op_Abs
2492                              => Resolve_Unary_Op                 (N, Ctx_Type);
2493
2494             when N_Op_Shift  => Resolve_Shift                    (N, Ctx_Type);
2495
2496             when N_Procedure_Call_Statement
2497                              => Resolve_Call                     (N, Ctx_Type);
2498
2499             when N_Operator_Symbol
2500                              => Resolve_Operator_Symbol          (N, Ctx_Type);
2501
2502             when N_Qualified_Expression
2503                              => Resolve_Qualified_Expression     (N, Ctx_Type);
2504
2505             when N_Raise_xxx_Error
2506                              => Set_Etype (N, Ctx_Type);
2507
2508             when N_Range     => Resolve_Range                    (N, Ctx_Type);
2509
2510             when N_Real_Literal
2511                              => Resolve_Real_Literal             (N, Ctx_Type);
2512
2513             when N_Reference => Resolve_Reference                (N, Ctx_Type);
2514
2515             when N_Selected_Component
2516                              => Resolve_Selected_Component       (N, Ctx_Type);
2517
2518             when N_Slice     => Resolve_Slice                    (N, Ctx_Type);
2519
2520             when N_String_Literal
2521                              => Resolve_String_Literal           (N, Ctx_Type);
2522
2523             when N_Subprogram_Info
2524                              => Resolve_Subprogram_Info          (N, Ctx_Type);
2525
2526             when N_Type_Conversion
2527                              => Resolve_Type_Conversion          (N, Ctx_Type);
2528
2529             when N_Unchecked_Expression =>
2530                Resolve_Unchecked_Expression                      (N, Ctx_Type);
2531
2532             when N_Unchecked_Type_Conversion =>
2533                Resolve_Unchecked_Type_Conversion                 (N, Ctx_Type);
2534
2535          end case;
2536
2537          --  If the subexpression was replaced by a non-subexpression, then
2538          --  all we do is to expand it. The only legitimate case we know of
2539          --  is converting procedure call statement to entry call statements,
2540          --  but there may be others, so we are making this test general.
2541
2542          if Nkind (N) not in N_Subexpr then
2543             Debug_A_Exit ("resolving  ", N, "  (done)");
2544             Expand (N);
2545             return;
2546          end if;
2547
2548          --  The expression is definitely NOT overloaded at this point, so
2549          --  we reset the Is_Overloaded flag to avoid any confusion when
2550          --  reanalyzing the node.
2551
2552          Set_Is_Overloaded (N, False);
2553
2554          --  Freeze expression type, entity if it is a name, and designated
2555          --  type if it is an allocator (RM 13.14(10,11,13)).
2556
2557          --  Now that the resolution of the type of the node is complete,
2558          --  and we did not detect an error, we can expand this node. We
2559          --  skip the expand call if we are in a default expression, see
2560          --  section "Handling of Default Expressions" in Sem spec.
2561
2562          Debug_A_Exit ("resolving  ", N, "  (done)");
2563
2564          --  We unconditionally freeze the expression, even if we are in
2565          --  default expression mode (the Freeze_Expression routine tests
2566          --  this flag and only freezes static types if it is set).
2567
2568          Freeze_Expression (N);
2569
2570          --  Now we can do the expansion
2571
2572          Expand (N);
2573       end if;
2574    end Resolve;
2575
2576    -------------
2577    -- Resolve --
2578    -------------
2579
2580    --  Version with check(s) suppressed
2581
2582    procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
2583    begin
2584       if Suppress = All_Checks then
2585          declare
2586             Svg : constant Suppress_Array := Scope_Suppress;
2587          begin
2588             Scope_Suppress := (others => True);
2589             Resolve (N, Typ);
2590             Scope_Suppress := Svg;
2591          end;
2592
2593       else
2594          declare
2595             Svg : constant Boolean := Scope_Suppress (Suppress);
2596          begin
2597             Scope_Suppress (Suppress) := True;
2598             Resolve (N, Typ);
2599             Scope_Suppress (Suppress) := Svg;
2600          end;
2601       end if;
2602    end Resolve;
2603
2604    -------------
2605    -- Resolve --
2606    -------------
2607
2608    --  Version with implicit type
2609
2610    procedure Resolve (N : Node_Id) is
2611    begin
2612       Resolve (N, Etype (N));
2613    end Resolve;
2614
2615    ---------------------
2616    -- Resolve_Actuals --
2617    ---------------------
2618
2619    procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
2620       Loc    : constant Source_Ptr := Sloc (N);
2621       A      : Node_Id;
2622       F      : Entity_Id;
2623       A_Typ  : Entity_Id;
2624       F_Typ  : Entity_Id;
2625       Prev   : Node_Id := Empty;
2626       Orig_A : Node_Id;
2627
2628       procedure Check_Argument_Order;
2629       --  Performs a check for the case where the actuals are all simple
2630       --  identifiers that correspond to the formal names, but in the wrong
2631       --  order, which is considered suspicious and cause for a warning.
2632
2633       procedure Check_Prefixed_Call;
2634       --  If the original node is an overloaded call in prefix notation,
2635       --  insert an 'Access or a dereference as needed over the first actual.
2636       --  Try_Object_Operation has already verified that there is a valid
2637       --  interpretation, but the form of the actual can only be determined
2638       --  once the primitive operation is identified.
2639
2640       procedure Insert_Default;
2641       --  If the actual is missing in a call, insert in the actuals list
2642       --  an instance of the default expression. The insertion is always
2643       --  a named association.
2644
2645       function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
2646       --  Check whether T1 and T2, or their full views, are derived from a
2647       --  common type. Used to enforce the restrictions on array conversions
2648       --  of AI95-00246.
2649
2650       --------------------------
2651       -- Check_Argument_Order --
2652       --------------------------
2653
2654       procedure Check_Argument_Order is
2655       begin
2656          --  Nothing to do if no parameters, or original node is neither a
2657          --  function call nor a procedure call statement (happens in the
2658          --  operator-transformed-to-function call case), or the call does
2659          --  not come from source, or this warning is off.
2660
2661          if not Warn_On_Parameter_Order
2662            or else
2663              No (Parameter_Associations (N))
2664            or else
2665              not Nkind_In (Original_Node (N), N_Procedure_Call_Statement,
2666                                               N_Function_Call)
2667            or else
2668              not Comes_From_Source (N)
2669          then
2670             return;
2671          end if;
2672
2673          declare
2674             Nargs : constant Nat := List_Length (Parameter_Associations (N));
2675
2676          begin
2677             --  Nothing to do if only one parameter
2678
2679             if Nargs < 2 then
2680                return;
2681             end if;
2682
2683             --  Here if at least two arguments
2684
2685             declare
2686                Actuals : array (1 .. Nargs) of Node_Id;
2687                Actual  : Node_Id;
2688                Formal  : Node_Id;
2689
2690                Wrong_Order : Boolean := False;
2691                --  Set True if an out of order case is found
2692
2693             begin
2694                --  Collect identifier names of actuals, fail if any actual is
2695                --  not a simple identifier, and record max length of name.
2696
2697                Actual := First (Parameter_Associations (N));
2698                for J in Actuals'Range loop
2699                   if Nkind (Actual) /= N_Identifier then
2700                      return;
2701                   else
2702                      Actuals (J) := Actual;
2703                      Next (Actual);
2704                   end if;
2705                end loop;
2706
2707                --  If we got this far, all actuals are identifiers and the list
2708                --  of their names is stored in the Actuals array.
2709
2710                Formal := First_Formal (Nam);
2711                for J in Actuals'Range loop
2712
2713                   --  If we ran out of formals, that's odd, probably an error
2714                   --  which will be detected elsewhere, but abandon the search.
2715
2716                   if No (Formal) then
2717                      return;
2718                   end if;
2719
2720                   --  If name matches and is in order OK
2721
2722                   if Chars (Formal) = Chars (Actuals (J)) then
2723                      null;
2724
2725                   else
2726                      --  If no match, see if it is elsewhere in list and if so
2727                      --  flag potential wrong order if type is compatible.
2728
2729                      for K in Actuals'Range loop
2730                         if Chars (Formal) = Chars (Actuals (K))
2731                           and then
2732                             Has_Compatible_Type (Actuals (K), Etype (Formal))
2733                         then
2734                            Wrong_Order := True;
2735                            goto Continue;
2736                         end if;
2737                      end loop;
2738
2739                      --  No match
2740
2741                      return;
2742                   end if;
2743
2744                   <<Continue>> Next_Formal (Formal);
2745                end loop;
2746
2747                --  If Formals left over, also probably an error, skip warning
2748
2749                if Present (Formal) then
2750                   return;
2751                end if;
2752
2753                --  Here we give the warning if something was out of order
2754
2755                if Wrong_Order then
2756                   Error_Msg_N
2757                     ("actuals for this call may be in wrong order?", N);
2758                end if;
2759             end;
2760          end;
2761       end Check_Argument_Order;
2762
2763       -------------------------
2764       -- Check_Prefixed_Call --
2765       -------------------------
2766
2767       procedure Check_Prefixed_Call is
2768          Act    : constant Node_Id   := First_Actual (N);
2769          A_Type : constant Entity_Id := Etype (Act);
2770          F_Type : constant Entity_Id := Etype (First_Formal (Nam));
2771          Orig   : constant Node_Id := Original_Node (N);
2772          New_A  : Node_Id;
2773
2774       begin
2775          --  Check whether the call is a prefixed call, with or without
2776          --  additional actuals.
2777
2778          if Nkind (Orig) = N_Selected_Component
2779            or else
2780              (Nkind (Orig) = N_Indexed_Component
2781                and then Nkind (Prefix (Orig)) = N_Selected_Component
2782                and then Is_Entity_Name (Prefix (Prefix (Orig)))
2783                and then Is_Entity_Name (Act)
2784                and then Chars (Act) = Chars (Prefix (Prefix (Orig))))
2785          then
2786             if Is_Access_Type (A_Type)
2787               and then not Is_Access_Type (F_Type)
2788             then
2789                --  Introduce dereference on object in prefix
2790
2791                New_A :=
2792                  Make_Explicit_Dereference (Sloc (Act),
2793                    Prefix => Relocate_Node (Act));
2794                Rewrite (Act, New_A);
2795                Analyze (Act);
2796
2797             elsif Is_Access_Type (F_Type)
2798               and then not Is_Access_Type (A_Type)
2799             then
2800                --  Introduce an implicit 'Access in prefix
2801
2802                if not Is_Aliased_View (Act) then
2803                   Error_Msg_NE
2804                     ("object in prefixed call to& must be aliased"
2805                          & " (RM-2005 4.3.1 (13))",
2806                     Prefix (Act), Nam);
2807                end if;
2808
2809                Rewrite (Act,
2810                  Make_Attribute_Reference (Loc,
2811                    Attribute_Name => Name_Access,
2812                    Prefix         => Relocate_Node (Act)));
2813             end if;
2814
2815             Analyze (Act);
2816          end if;
2817       end Check_Prefixed_Call;
2818
2819       --------------------
2820       -- Insert_Default --
2821       --------------------
2822
2823       procedure Insert_Default is
2824          Actval : Node_Id;
2825          Assoc  : Node_Id;
2826
2827       begin
2828          --  Missing argument in call, nothing to insert
2829
2830          if No (Default_Value (F)) then
2831             return;
2832
2833          else
2834             --  Note that we do a full New_Copy_Tree, so that any associated
2835             --  Itypes are properly copied. This may not be needed any more,
2836             --  but it does no harm as a safety measure! Defaults of a generic
2837             --  formal may be out of bounds of the corresponding actual (see
2838             --  cc1311b) and an additional check may be required.
2839
2840             Actval :=
2841               New_Copy_Tree
2842                 (Default_Value (F),
2843                  New_Scope => Current_Scope,
2844                  New_Sloc  => Loc);
2845
2846             if Is_Concurrent_Type (Scope (Nam))
2847               and then Has_Discriminants (Scope (Nam))
2848             then
2849                Replace_Actual_Discriminants (N, Actval);
2850             end if;
2851
2852             if Is_Overloadable (Nam)
2853               and then Present (Alias (Nam))
2854             then
2855                if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
2856                  and then not Is_Tagged_Type (Etype (F))
2857                then
2858                   --  If default is a real literal, do not introduce a
2859                   --  conversion whose effect may depend on the run-time
2860                   --  size of universal real.
2861
2862                   if Nkind (Actval) = N_Real_Literal then
2863                      Set_Etype (Actval, Base_Type (Etype (F)));
2864                   else
2865                      Actval := Unchecked_Convert_To (Etype (F), Actval);
2866                   end if;
2867                end if;
2868
2869                if Is_Scalar_Type (Etype (F)) then
2870                   Enable_Range_Check (Actval);
2871                end if;
2872
2873                Set_Parent (Actval, N);
2874
2875                --  Resolve aggregates with their base type, to avoid scope
2876                --  anomalies: the subtype was first built in the subprogram
2877                --  declaration, and the current call may be nested.
2878
2879                if Nkind (Actval) = N_Aggregate
2880                  and then Has_Discriminants (Etype (Actval))
2881                then
2882                   Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
2883                else
2884                   Analyze_And_Resolve (Actval, Etype (Actval));
2885                end if;
2886
2887             else
2888                Set_Parent (Actval, N);
2889
2890                --  See note above concerning aggregates
2891
2892                if Nkind (Actval) = N_Aggregate
2893                  and then Has_Discriminants (Etype (Actval))
2894                then
2895                   Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
2896
2897                --  Resolve entities with their own type, which may differ
2898                --  from the type of a reference in a generic context (the
2899                --  view swapping mechanism did not anticipate the re-analysis
2900                --  of default values in calls).
2901
2902                elsif Is_Entity_Name (Actval) then
2903                   Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
2904
2905                else
2906                   Analyze_And_Resolve (Actval, Etype (Actval));
2907                end if;
2908             end if;
2909
2910             --  If default is a tag indeterminate function call, propagate
2911             --  tag to obtain proper dispatching.
2912
2913             if Is_Controlling_Formal (F)
2914               and then Nkind (Default_Value (F)) = N_Function_Call
2915             then
2916                Set_Is_Controlling_Actual (Actval);
2917             end if;
2918
2919          end if;
2920
2921          --  If the default expression raises constraint error, then just
2922          --  silently replace it with an N_Raise_Constraint_Error node,
2923          --  since we already gave the warning on the subprogram spec.
2924
2925          if Raises_Constraint_Error (Actval) then
2926             Rewrite (Actval,
2927               Make_Raise_Constraint_Error (Loc,
2928                 Reason => CE_Range_Check_Failed));
2929             Set_Raises_Constraint_Error (Actval);
2930             Set_Etype (Actval, Etype (F));
2931          end if;
2932
2933          Assoc :=
2934            Make_Parameter_Association (Loc,
2935              Explicit_Actual_Parameter => Actval,
2936              Selector_Name => Make_Identifier (Loc, Chars (F)));
2937
2938          --  Case of insertion is first named actual
2939
2940          if No (Prev) or else
2941             Nkind (Parent (Prev)) /= N_Parameter_Association
2942          then
2943             Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
2944             Set_First_Named_Actual (N, Actval);
2945
2946             if No (Prev) then
2947                if No (Parameter_Associations (N)) then
2948                   Set_Parameter_Associations (N, New_List (Assoc));
2949                else
2950                   Append (Assoc, Parameter_Associations (N));
2951                end if;
2952
2953             else
2954                Insert_After (Prev, Assoc);
2955             end if;
2956
2957          --  Case of insertion is not first named actual
2958
2959          else
2960             Set_Next_Named_Actual
2961               (Assoc, Next_Named_Actual (Parent (Prev)));
2962             Set_Next_Named_Actual (Parent (Prev), Actval);
2963             Append (Assoc, Parameter_Associations (N));
2964          end if;
2965
2966          Mark_Rewrite_Insertion (Assoc);
2967          Mark_Rewrite_Insertion (Actval);
2968
2969          Prev := Actval;
2970       end Insert_Default;
2971
2972       -------------------
2973       -- Same_Ancestor --
2974       -------------------
2975
2976       function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is
2977          FT1 : Entity_Id := T1;
2978          FT2 : Entity_Id := T2;
2979
2980       begin
2981          if Is_Private_Type (T1)
2982            and then Present (Full_View (T1))
2983          then
2984             FT1 := Full_View (T1);
2985          end if;
2986
2987          if Is_Private_Type (T2)
2988            and then Present (Full_View (T2))
2989          then
2990             FT2 := Full_View (T2);
2991          end if;
2992
2993          return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
2994       end Same_Ancestor;
2995
2996    --  Start of processing for Resolve_Actuals
2997
2998    begin
2999       Check_Argument_Order;
3000
3001       if Present (First_Actual (N)) then
3002          Check_Prefixed_Call;
3003       end if;
3004
3005       A := First_Actual (N);
3006       F := First_Formal (Nam);
3007       while Present (F) loop
3008          if No (A) and then Needs_No_Actuals (Nam) then
3009             null;
3010
3011          --  If we have an error in any actual or formal, indicated by
3012          --  a type of Any_Type, then abandon resolution attempt, and
3013          --  set result type to Any_Type.
3014
3015          elsif (Present (A) and then Etype (A) = Any_Type)
3016            or else Etype (F) = Any_Type
3017          then
3018             Set_Etype (N, Any_Type);
3019             return;
3020          end if;
3021
3022          --  Case where actual is present
3023
3024          --  If the actual is an entity, generate a reference to it now. We
3025          --  do this before the actual is resolved, because a formal of some
3026          --  protected subprogram, or a task discriminant, will be rewritten
3027          --  during expansion, and the reference to the source entity may
3028          --  be lost.
3029
3030          if Present (A)
3031            and then Is_Entity_Name (A)
3032            and then Comes_From_Source (N)
3033          then
3034             Orig_A := Entity (A);
3035
3036             if Present (Orig_A) then
3037                if Is_Formal (Orig_A)
3038                  and then Ekind (F) /= E_In_Parameter
3039                then
3040                   Generate_Reference (Orig_A, A, 'm');
3041                elsif not Is_Overloaded (A) then
3042                   Generate_Reference (Orig_A, A);
3043                end if;
3044             end if;
3045          end if;
3046
3047          if Present (A)
3048            and then (Nkind (Parent (A)) /= N_Parameter_Association
3049                        or else
3050                      Chars (Selector_Name (Parent (A))) = Chars (F))
3051          then
3052             --  If style checking mode on, check match of formal name
3053
3054             if Style_Check then
3055                if Nkind (Parent (A)) = N_Parameter_Association then
3056                   Check_Identifier (Selector_Name (Parent (A)), F);
3057                end if;
3058             end if;
3059
3060             --  If the formal is Out or In_Out, do not resolve and expand the
3061             --  conversion, because it is subsequently expanded into explicit
3062             --  temporaries and assignments. However, the object of the
3063             --  conversion can be resolved. An exception is the case of tagged
3064             --  type conversion with a class-wide actual. In that case we want
3065             --  the tag check to occur and no temporary will be needed (no
3066             --  representation change can occur) and the parameter is passed by
3067             --  reference, so we go ahead and resolve the type conversion.
3068             --  Another exception is the case of reference to component or
3069             --  subcomponent of a bit-packed array, in which case we want to
3070             --  defer expansion to the point the in and out assignments are
3071             --  performed.
3072
3073             if Ekind (F) /= E_In_Parameter
3074               and then Nkind (A) = N_Type_Conversion
3075               and then not Is_Class_Wide_Type (Etype (Expression (A)))
3076             then
3077                if Ekind (F) = E_In_Out_Parameter
3078                  and then Is_Array_Type (Etype (F))
3079                then
3080                   if Has_Aliased_Components (Etype (Expression (A)))
3081                     /= Has_Aliased_Components (Etype (F))
3082                   then
3083
3084                      --  In a view conversion, the conversion must be legal in
3085                      --  both directions, and thus both component types must be
3086                      --  aliased, or neither (4.6 (8)).
3087
3088                      --  The additional rule 4.6 (24.9.2) seems unduly
3089                      --  restrictive: the privacy requirement should not
3090                      --  apply to generic types, and should be checked in
3091                      --  an instance. ARG query is in order.
3092
3093                      Error_Msg_N
3094                        ("both component types in a view conversion must be"
3095                          & " aliased, or neither", A);
3096
3097                   elsif
3098                      not Same_Ancestor (Etype (F), Etype (Expression (A)))
3099                   then
3100                      if Is_By_Reference_Type (Etype (F))
3101                         or else Is_By_Reference_Type (Etype (Expression (A)))
3102                      then
3103                         Error_Msg_N
3104                           ("view conversion between unrelated by reference " &
3105                            "array types not allowed (\'A'I-00246)", A);
3106                      else
3107                         declare
3108                            Comp_Type : constant Entity_Id :=
3109                                          Component_Type
3110                                            (Etype (Expression (A)));
3111                         begin
3112                            if Comes_From_Source (A)
3113                              and then Ada_Version >= Ada_05
3114                              and then
3115                                ((Is_Private_Type (Comp_Type)
3116                                    and then not Is_Generic_Type (Comp_Type))
3117                                  or else Is_Tagged_Type (Comp_Type)
3118                                  or else Is_Volatile (Comp_Type))
3119                            then
3120                               Error_Msg_N
3121                                 ("component type of a view conversion cannot"
3122                                    & " be private, tagged, or volatile"
3123                                    & " (RM 4.6 (24))",
3124                                    Expression (A));
3125                            end if;
3126                         end;
3127                      end if;
3128                   end if;
3129                end if;
3130
3131                if (Conversion_OK (A)
3132                      or else Valid_Conversion (A, Etype (A), Expression (A)))
3133                  and then not Is_Ref_To_Bit_Packed_Array (Expression (A))
3134                then
3135                   Resolve (Expression (A));
3136                end if;
3137
3138             --  If the actual is a function call that returns a limited
3139             --  unconstrained object that needs finalization, create a
3140             --  transient scope for it, so that it can receive the proper
3141             --  finalization list.
3142
3143             elsif Nkind (A) = N_Function_Call
3144               and then Is_Limited_Record (Etype (F))
3145               and then not Is_Constrained (Etype (F))
3146               and then Expander_Active
3147               and then
3148                 (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
3149             then
3150                Establish_Transient_Scope (A, False);
3151
3152             else
3153                if Nkind (A) = N_Type_Conversion
3154                  and then Is_Array_Type (Etype (F))
3155                  and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
3156                  and then
3157                   (Is_Limited_Type (Etype (F))
3158                      or else Is_Limited_Type (Etype (Expression (A))))
3159                then
3160                   Error_Msg_N
3161                     ("conversion between unrelated limited array types " &
3162                      "not allowed (\A\I-00246)", A);
3163
3164                   if Is_Limited_Type (Etype (F)) then
3165                      Explain_Limited_Type (Etype (F), A);
3166                   end if;
3167
3168                   if Is_Limited_Type (Etype (Expression (A))) then
3169                      Explain_Limited_Type (Etype (Expression (A)), A);
3170                   end if;
3171                end if;
3172
3173                --  (Ada 2005: AI-251): If the actual is an allocator whose
3174                --  directly designated type is a class-wide interface, we build
3175                --  an anonymous access type to use it as the type of the
3176                --  allocator. Later, when the subprogram call is expanded, if
3177                --  the interface has a secondary dispatch table the expander
3178                --  will add a type conversion to force the correct displacement
3179                --  of the pointer.
3180
3181                if Nkind (A) = N_Allocator then
3182                   declare
3183                      DDT : constant Entity_Id :=
3184                              Directly_Designated_Type (Base_Type (Etype (F)));
3185
3186                      New_Itype : Entity_Id;
3187
3188                   begin
3189                      if Is_Class_Wide_Type (DDT)
3190                        and then Is_Interface (DDT)
3191                      then
3192                         New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
3193                         Set_Etype (New_Itype, Etype (A));
3194                         Set_Directly_Designated_Type (New_Itype,
3195                           Directly_Designated_Type (Etype (A)));
3196                         Set_Etype (A, New_Itype);
3197                      end if;
3198
3199                      --  Ada 2005, AI-162:If the actual is an allocator, the
3200                      --  innermost enclosing statement is the master of the
3201                      --  created object. This needs to be done with expansion
3202                      --  enabled only, otherwise the transient scope will not
3203                      --  be removed in the expansion of the wrapped construct.
3204
3205                      if (Is_Controlled (DDT) or else Has_Task (DDT))
3206                        and then Expander_Active
3207                      then
3208                         Establish_Transient_Scope (A, False);
3209                      end if;
3210                   end;
3211                end if;
3212
3213                --  (Ada 2005): The call may be to a primitive operation of
3214                --   a tagged synchronized type, declared outside of the type.
3215                --   In this case the controlling actual must be converted to
3216                --   its corresponding record type, which is the formal type.
3217                --   The actual may be a subtype, either because of a constraint
3218                --   or because it is a generic actual, so use base type to
3219                --   locate concurrent type.
3220
3221                if Is_Concurrent_Type (Etype (A))
3222                  and then Etype (F) =
3223                             Corresponding_Record_Type (Base_Type (Etype (A)))
3224                then
3225                   Rewrite (A,
3226                     Unchecked_Convert_To
3227                       (Corresponding_Record_Type (Etype (A)), A));
3228                end if;
3229
3230                Resolve (A, Etype (F));
3231             end if;
3232
3233             A_Typ := Etype (A);
3234             F_Typ := Etype (F);
3235
3236             --  For mode IN, if actual is an entity, and the type of the formal
3237             --  has warnings suppressed, then we reset Never_Set_In_Source for
3238             --  the calling entity. The reason for this is to catch cases like
3239             --  GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram
3240             --  uses trickery to modify an IN parameter.
3241
3242             if Ekind (F) = E_In_Parameter
3243               and then Is_Entity_Name (A)
3244               and then Present (Entity (A))
3245               and then Ekind (Entity (A)) = E_Variable
3246               and then Has_Warnings_Off (F_Typ)
3247             then
3248                Set_Never_Set_In_Source (Entity (A), False);
3249             end if;
3250
3251             --  Perform error checks for IN and IN OUT parameters
3252
3253             if Ekind (F) /= E_Out_Parameter then
3254
3255                --  Check unset reference. For scalar parameters, it is clearly
3256                --  wrong to pass an uninitialized value as either an IN or
3257                --  IN-OUT parameter. For composites, it is also clearly an
3258                --  error to pass a completely uninitialized value as an IN
3259                --  parameter, but the case of IN OUT is trickier. We prefer
3260                --  not to give a warning here. For example, suppose there is
3261                --  a routine that sets some component of a record to False.
3262                --  It is perfectly reasonable to make this IN-OUT and allow
3263                --  either initialized or uninitialized records to be passed
3264                --  in this case.
3265
3266                --  For partially initialized composite values, we also avoid
3267                --  warnings, since it is quite likely that we are passing a
3268                --  partially initialized value and only the initialized fields
3269                --  will in fact be read in the subprogram.
3270
3271                if Is_Scalar_Type (A_Typ)
3272                  or else (Ekind (F) = E_In_Parameter
3273                             and then not Is_Partially_Initialized_Type (A_Typ))
3274                then
3275                   Check_Unset_Reference (A);
3276                end if;
3277
3278                --  In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT
3279                --  actual to a nested call, since this is case of reading an
3280                --  out parameter, which is not allowed.
3281
3282                if Ada_Version = Ada_83
3283                  and then Is_Entity_Name (A)
3284                  and then Ekind (Entity (A)) = E_Out_Parameter
3285                then
3286                   Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
3287                end if;
3288             end if;
3289
3290             --  Case of OUT or IN OUT parameter
3291
3292             if Ekind (F) /= E_In_Parameter then
3293
3294                --  For an Out parameter, check for useless assignment. Note
3295                --  that we can't set Last_Assignment this early, because we may
3296                --  kill current values in Resolve_Call, and that call would
3297                --  clobber the Last_Assignment field.
3298
3299                --  Note: call Warn_On_Useless_Assignment before doing the check
3300                --  below for Is_OK_Variable_For_Out_Formal so that the setting
3301                --  of Referenced_As_LHS/Referenced_As_Out_Formal properly
3302                --  reflects the last assignment, not this one!
3303
3304                if Ekind (F) = E_Out_Parameter then
3305                   if Warn_On_Modified_As_Out_Parameter (F)
3306                     and then Is_Entity_Name (A)
3307                     and then Present (Entity (A))
3308                     and then Comes_From_Source (N)
3309                   then
3310                      Warn_On_Useless_Assignment (Entity (A), A);
3311                   end if;
3312                end if;
3313
3314                --  Validate the form of the actual. Note that the call to
3315                --  Is_OK_Variable_For_Out_Formal generates the required
3316                --  reference in this case.
3317
3318                if not Is_OK_Variable_For_Out_Formal (A) then
3319                   Error_Msg_NE ("actual for& must be a variable", A, F);
3320                end if;
3321
3322                --  What's the following about???
3323
3324                if Is_Entity_Name (A) then
3325                   Kill_Checks (Entity (A));
3326                else
3327                   Kill_All_Checks;
3328                end if;
3329             end if;
3330
3331             if Etype (A) = Any_Type then
3332                Set_Etype (N, Any_Type);
3333                return;
3334             end if;
3335
3336             --  Apply appropriate range checks for in, out, and in-out
3337             --  parameters. Out and in-out parameters also need a separate
3338             --  check, if there is a type conversion, to make sure the return
3339             --  value meets the constraints of the variable before the
3340             --  conversion.
3341
3342             --  Gigi looks at the check flag and uses the appropriate types.
3343             --  For now since one flag is used there is an optimization which
3344             --  might not be done in the In Out case since Gigi does not do
3345             --  any analysis. More thought required about this ???
3346
3347             if Ekind (F) = E_In_Parameter
3348               or else Ekind (F) = E_In_Out_Parameter
3349             then
3350                if Is_Scalar_Type (Etype (A)) then
3351                   Apply_Scalar_Range_Check (A, F_Typ);
3352
3353                elsif Is_Array_Type (Etype (A)) then
3354                   Apply_Length_Check (A, F_Typ);
3355
3356                elsif Is_Record_Type (F_Typ)
3357                  and then Has_Discriminants (F_Typ)
3358                  and then Is_Constrained (F_Typ)
3359                  and then (not Is_Derived_Type (F_Typ)
3360                              or else Comes_From_Source (Nam))
3361                then
3362                   Apply_Discriminant_Check (A, F_Typ);
3363
3364                elsif Is_Access_Type (F_Typ)
3365                  and then Is_Array_Type (Designated_Type (F_Typ))
3366                  and then Is_Constrained (Designated_Type (F_Typ))
3367                then
3368                   Apply_Length_Check (A, F_Typ);
3369
3370                elsif Is_Access_Type (F_Typ)
3371                  and then Has_Discriminants (Designated_Type (F_Typ))
3372                  and then Is_Constrained (Designated_Type (F_Typ))
3373                then
3374                   Apply_Discriminant_Check (A, F_Typ);
3375
3376                else
3377                   Apply_Range_Check (A, F_Typ);
3378                end if;
3379
3380                --  Ada 2005 (AI-231)
3381
3382                if Ada_Version >= Ada_05
3383                  and then Is_Access_Type (F_Typ)
3384                  and then Can_Never_Be_Null (F_Typ)
3385                  and then Known_Null (A)
3386                then
3387                   Apply_Compile_Time_Constraint_Error
3388                     (N      => A,
3389                      Msg    => "(Ada 2005) null not allowed in "
3390                                & "null-excluding formal?",
3391                      Reason => CE_Null_Not_Allowed);
3392                end if;
3393             end if;
3394
3395             if Ekind (F) = E_Out_Parameter
3396               or else Ekind (F) = E_In_Out_Parameter
3397             then
3398                if Nkind (A) = N_Type_Conversion then
3399                   if Is_Scalar_Type (A_Typ) then
3400                      Apply_Scalar_Range_Check
3401                        (Expression (A), Etype (Expression (A)), A_Typ);
3402                   else
3403                      Apply_Range_Check
3404                        (Expression (A), Etype (Expression (A)), A_Typ);
3405                   end if;
3406
3407                else
3408                   if Is_Scalar_Type (F_Typ) then
3409                      Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
3410
3411                   elsif Is_Array_Type (F_Typ)
3412                     and then Ekind (F) = E_Out_Parameter
3413                   then
3414                      Apply_Length_Check (A, F_Typ);
3415
3416                   else
3417                      Apply_Range_Check (A, A_Typ, F_Typ);
3418                   end if;
3419                end if;
3420             end if;
3421
3422             --  An actual associated with an access parameter is implicitly
3423             --  converted to the anonymous access type of the formal and must
3424             --  satisfy the legality checks for access conversions.
3425
3426             if Ekind (F_Typ) = E_Anonymous_Access_Type then
3427                if not Valid_Conversion (A, F_Typ, A) then
3428                   Error_Msg_N
3429                     ("invalid implicit conversion for access parameter", A);
3430                end if;
3431             end if;
3432
3433             --  Check bad case of atomic/volatile argument (RM C.6(12))
3434
3435             if Is_By_Reference_Type (Etype (F))
3436               and then Comes_From_Source (N)
3437             then
3438                if Is_Atomic_Object (A)
3439                  and then not Is_Atomic (Etype (F))
3440                then
3441                   Error_Msg_N
3442                     ("cannot pass atomic argument to non-atomic formal",
3443                      N);
3444
3445                elsif Is_Volatile_Object (A)
3446                  and then not Is_Volatile (Etype (F))
3447                then
3448                   Error_Msg_N
3449                     ("cannot pass volatile argument to non-volatile formal",
3450                      N);
3451                end if;
3452             end if;
3453
3454             --  Check that subprograms don't have improper controlling
3455             --  arguments (RM 3.9.2 (9))
3456
3457             --  A primitive operation may have an access parameter of an
3458             --  incomplete tagged type, but a dispatching call is illegal
3459             --  if the type is still incomplete.
3460
3461             if Is_Controlling_Formal (F) then
3462                Set_Is_Controlling_Actual (A);
3463
3464                if Ekind (Etype (F)) = E_Anonymous_Access_Type then
3465                   declare
3466                      Desig : constant Entity_Id := Designated_Type (Etype (F));
3467                   begin
3468                      if Ekind (Desig) = E_Incomplete_Type
3469                        and then No (Full_View (Desig))
3470                        and then No (Non_Limited_View (Desig))
3471                      then
3472                         Error_Msg_NE
3473                           ("premature use of incomplete type& " &
3474                            "in dispatching call", A, Desig);
3475                      end if;
3476                   end;
3477                end if;
3478
3479             elsif Nkind (A) = N_Explicit_Dereference then
3480                Validate_Remote_Access_To_Class_Wide_Type (A);
3481             end if;
3482
3483             if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
3484               and then not Is_Class_Wide_Type (F_Typ)
3485               and then not Is_Controlling_Formal (F)
3486             then
3487                Error_Msg_N ("class-wide argument not allowed here!", A);
3488
3489                if Is_Subprogram (Nam)
3490                  and then Comes_From_Source (Nam)
3491                then
3492                   Error_Msg_Node_2 := F_Typ;
3493                   Error_Msg_NE
3494                     ("& is not a dispatching operation of &!", A, Nam);
3495                end if;
3496
3497             elsif Is_Access_Type (A_Typ)
3498               and then Is_Access_Type (F_Typ)
3499               and then Ekind (F_Typ) /= E_Access_Subprogram_Type
3500               and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type
3501               and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
3502                          or else (Nkind (A) = N_Attribute_Reference
3503                                    and then
3504                                   Is_Class_Wide_Type (Etype (Prefix (A)))))
3505               and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
3506               and then not Is_Controlling_Formal (F)
3507             then
3508                Error_Msg_N
3509                  ("access to class-wide argument not allowed here!", A);
3510
3511                if Is_Subprogram (Nam)
3512                  and then Comes_From_Source (Nam)
3513                then
3514                   Error_Msg_Node_2 := Designated_Type (F_Typ);
3515                   Error_Msg_NE
3516                     ("& is not a dispatching operation of &!", A, Nam);
3517                end if;
3518             end if;
3519
3520             Eval_Actual (A);
3521
3522             --  If it is a named association, treat the selector_name as
3523             --  a proper identifier, and mark the corresponding entity.
3524
3525             if Nkind (Parent (A)) = N_Parameter_Association then
3526                Set_Entity (Selector_Name (Parent (A)), F);
3527                Generate_Reference (F, Selector_Name (Parent (A)));
3528                Set_Etype (Selector_Name (Parent (A)), F_Typ);
3529                Generate_Reference (F_Typ, N, ' ');
3530             end if;
3531
3532             Prev := A;
3533
3534             if Ekind (F) /= E_Out_Parameter then
3535                Check_Unset_Reference (A);
3536             end if;
3537
3538             Next_Actual (A);
3539
3540          --  Case where actual is not present
3541
3542          else
3543             Insert_Default;
3544          end if;
3545
3546          Next_Formal (F);
3547       end loop;
3548    end Resolve_Actuals;
3549
3550    -----------------------
3551    -- Resolve_Allocator --
3552    -----------------------
3553
3554    procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
3555       E        : constant Node_Id := Expression (N);
3556       Subtyp   : Entity_Id;
3557       Discrim  : Entity_Id;
3558       Constr   : Node_Id;
3559       Aggr     : Node_Id;
3560       Assoc    : Node_Id := Empty;
3561       Disc_Exp : Node_Id;
3562
3563       procedure Check_Allocator_Discrim_Accessibility
3564         (Disc_Exp  : Node_Id;
3565          Alloc_Typ : Entity_Id);
3566       --  Check that accessibility level associated with an access discriminant
3567       --  initialized in an allocator by the expression Disc_Exp is not deeper
3568       --  than the level of the allocator type Alloc_Typ. An error message is
3569       --  issued if this condition is violated. Specialized checks are done for
3570       --  the cases of a constraint expression which is an access attribute or
3571       --  an access discriminant.
3572
3573       function In_Dispatching_Context return Boolean;
3574       --  If the allocator is an actual in a call, it is allowed to be class-
3575       --  wide when the context is not because it is a controlling actual.
3576
3577       procedure Propagate_Coextensions (Root : Node_Id);
3578       --  Propagate all nested coextensions which are located one nesting
3579       --  level down the tree to the node Root. Example:
3580       --
3581       --    Top_Record
3582       --       Level_1_Coextension
3583       --          Level_2_Coextension
3584       --
3585       --  The algorithm is paired with delay actions done by the Expander. In
3586       --  the above example, assume all coextensions are controlled types.
3587       --  The cycle of analysis, resolution and expansion will yield:
3588       --
3589       --  1) Analyze Top_Record
3590       --  2) Analyze Level_1_Coextension
3591       --  3) Analyze Level_2_Coextension
3592       --  4) Resolve Level_2_Coextension. The allocator is marked as a
3593       --       coextension.
3594       --  5) Expand Level_2_Coextension. A temporary variable Temp_1 is
3595       --       generated to capture the allocated object. Temp_1 is attached
3596       --       to the coextension chain of Level_2_Coextension.
3597       --  6) Resolve Level_1_Coextension. The allocator is marked as a
3598       --       coextension. A forward tree traversal is performed which finds
3599       --       Level_2_Coextension's list and copies its contents into its
3600       --       own list.
3601       --  7) Expand Level_1_Coextension. A temporary variable Temp_2 is
3602       --       generated to capture the allocated object. Temp_2 is attached
3603       --       to the coextension chain of Level_1_Coextension. Currently, the
3604       --       contents of the list are [Temp_2, Temp_1].
3605       --  8) Resolve Top_Record. A forward tree traversal is performed which
3606       --       finds Level_1_Coextension's list and copies its contents into
3607       --       its own list.
3608       --  9) Expand Top_Record. Generate finalization calls for Temp_1 and
3609       --       Temp_2 and attach them to Top_Record's finalization list.
3610
3611       -------------------------------------------
3612       -- Check_Allocator_Discrim_Accessibility --
3613       -------------------------------------------
3614
3615       procedure Check_Allocator_Discrim_Accessibility
3616         (Disc_Exp  : Node_Id;
3617          Alloc_Typ : Entity_Id)
3618       is
3619       begin
3620          if Type_Access_Level (Etype (Disc_Exp)) >
3621             Type_Access_Level (Alloc_Typ)
3622          then
3623             Error_Msg_N
3624               ("operand type has deeper level than allocator type", Disc_Exp);
3625
3626          --  When the expression is an Access attribute the level of the prefix
3627          --  object must not be deeper than that of the allocator's type.
3628
3629          elsif Nkind (Disc_Exp) = N_Attribute_Reference
3630            and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
3631                       = Attribute_Access
3632            and then Object_Access_Level (Prefix (Disc_Exp))
3633                       > Type_Access_Level (Alloc_Typ)
3634          then
3635             Error_Msg_N
3636               ("prefix of attribute has deeper level than allocator type",
3637                Disc_Exp);
3638
3639          --  When the expression is an access discriminant the check is against
3640          --  the level of the prefix object.
3641
3642          elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
3643            and then Nkind (Disc_Exp) = N_Selected_Component
3644            and then Object_Access_Level (Prefix (Disc_Exp))
3645                       > Type_Access_Level (Alloc_Typ)
3646          then
3647             Error_Msg_N
3648               ("access discriminant has deeper level than allocator type",
3649                Disc_Exp);
3650
3651          --  All other cases are legal
3652
3653          else
3654             null;
3655          end if;
3656       end Check_Allocator_Discrim_Accessibility;
3657
3658       ----------------------------
3659       -- In_Dispatching_Context --
3660       ----------------------------
3661
3662       function In_Dispatching_Context return Boolean is
3663          Par : constant Node_Id := Parent (N);
3664       begin
3665          return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
3666            and then Is_Entity_Name (Name (Par))
3667            and then Is_Dispatching_Operation (Entity (Name (Par)));
3668       end In_Dispatching_Context;
3669
3670       ----------------------------
3671       -- Propagate_Coextensions --
3672       ----------------------------
3673
3674       procedure Propagate_Coextensions (Root : Node_Id) is
3675
3676          procedure Copy_List (From : Elist_Id; To : Elist_Id);
3677          --  Copy the contents of list From into list To, preserving the
3678          --  order of elements.
3679
3680          function Process_Allocator (Nod : Node_Id) return Traverse_Result;
3681          --  Recognize an allocator or a rewritten allocator node and add it
3682          --  along with its nested coextensions to the list of Root.
3683
3684          ---------------
3685          -- Copy_List --
3686          ---------------
3687
3688          procedure Copy_List (From : Elist_Id; To : Elist_Id) is
3689             From_Elmt : Elmt_Id;
3690          begin
3691             From_Elmt := First_Elmt (From);
3692             while Present (From_Elmt) loop
3693                Append_Elmt (Node (From_Elmt), To);
3694                Next_Elmt (From_Elmt);
3695             end loop;
3696          end Copy_List;
3697
3698          -----------------------
3699          -- Process_Allocator --
3700          -----------------------
3701
3702          function Process_Allocator (Nod : Node_Id) return Traverse_Result is
3703             Orig_Nod : Node_Id := Nod;
3704
3705          begin
3706             --  This is a possible rewritten subtype indication allocator. Any
3707             --  nested coextensions will appear as discriminant constraints.
3708
3709             if Nkind (Nod) = N_Identifier
3710               and then Present (Original_Node (Nod))
3711               and then Nkind (Original_Node (Nod)) = N_Subtype_Indication
3712             then
3713                declare
3714                   Discr      : Node_Id;
3715                   Discr_Elmt : Elmt_Id;
3716
3717                begin
3718                   if Is_Record_Type (Entity (Nod)) then
3719                      Discr_Elmt :=
3720                        First_Elmt (Discriminant_Constraint (Entity (Nod)));
3721                      while Present (Discr_Elmt) loop
3722                         Discr := Node (Discr_Elmt);
3723
3724                         if Nkind (Discr) = N_Identifier
3725                           and then Present (Original_Node (Discr))
3726                           and then Nkind (Original_Node (Discr)) = N_Allocator
3727                           and then Present (Coextensions (
3728                                      Original_Node (Discr)))
3729                         then
3730                            if No (Coextensions (Root)) then
3731                               Set_Coextensions (Root, New_Elmt_List);
3732                            end if;
3733
3734                            Copy_List
3735                              (From => Coextensions (Original_Node (Discr)),
3736                               To   => Coextensions (Root));
3737                         end if;
3738
3739                         Next_Elmt (Discr_Elmt);
3740                      end loop;
3741
3742                      --  There is no need to continue the traversal of this
3743                      --  subtree since all the information has already been
3744                      --  propagated.
3745
3746                      return Skip;
3747                   end if;
3748                end;
3749
3750             --  Case of either a stand alone allocator or a rewritten allocator
3751             --  with an aggregate.
3752
3753             else
3754                if Present (Original_Node (Nod)) then
3755                   Orig_Nod := Original_Node (Nod);
3756                end if;
3757
3758                if Nkind (Orig_Nod) = N_Allocator then
3759
3760                   --  Propagate the list of nested coextensions to the Root
3761                   --  allocator. This is done through list copy since a single
3762                   --  allocator may have multiple coextensions. Do not touch
3763                   --  coextensions roots.
3764
3765                   if not Is_Coextension_Root (Orig_Nod)
3766                     and then Present (Coextensions (Orig_Nod))
3767                   then
3768                      if No (Coextensions (Root)) then
3769                         Set_Coextensions (Root, New_Elmt_List);
3770                      end if;
3771
3772                      Copy_List
3773                        (From => Coextensions (Orig_Nod),
3774                         To   => Coextensions (Root));
3775                   end if;
3776
3777                   --  There is no need to continue the traversal of this
3778                   --  subtree since all the information has already been
3779                   --  propagated.
3780
3781                   return Skip;
3782                end if;
3783             end if;
3784
3785             --  Keep on traversing, looking for the next allocator
3786
3787             return OK;
3788          end Process_Allocator;
3789
3790          procedure Process_Allocators is
3791            new Traverse_Proc (Process_Allocator);
3792
3793       --  Start of processing for Propagate_Coextensions
3794
3795       begin
3796          Process_Allocators (Expression (Root));
3797       end Propagate_Coextensions;
3798
3799    --  Start of processing for Resolve_Allocator
3800
3801    begin
3802       --  Replace general access with specific type
3803
3804       if Ekind (Etype (N)) = E_Allocator_Type then
3805          Set_Etype (N, Base_Type (Typ));
3806       end if;
3807
3808       if Is_Abstract_Type (Typ) then
3809          Error_Msg_N ("type of allocator cannot be abstract",  N);
3810       end if;
3811
3812       --  For qualified expression, resolve the expression using the
3813       --  given subtype (nothing to do for type mark, subtype indication)
3814
3815       if Nkind (E) = N_Qualified_Expression then
3816          if Is_Class_Wide_Type (Etype (E))
3817            and then not Is_Class_Wide_Type (Designated_Type (Typ))
3818            and then not In_Dispatching_Context
3819          then
3820             Error_Msg_N
3821               ("class-wide allocator not allowed for this access type", N);
3822          end if;
3823
3824          Resolve (Expression (E), Etype (E));
3825          Check_Unset_Reference (Expression (E));
3826
3827          --  A qualified expression requires an exact match of the type,
3828          --  class-wide matching is not allowed.
3829
3830          if (Is_Class_Wide_Type (Etype (Expression (E)))
3831               or else Is_Class_Wide_Type (Etype (E)))
3832            and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
3833          then
3834             Wrong_Type (Expression (E), Etype (E));
3835          end if;
3836
3837          --  A special accessibility check is needed for allocators that
3838          --  constrain access discriminants. The level of the type of the
3839          --  expression used to constrain an access discriminant cannot be
3840          --  deeper than the type of the allocator (in contrast to access
3841          --  parameters, where the level of the actual can be arbitrary).
3842
3843          --  We can't use Valid_Conversion to perform this check because
3844          --  in general the type of the allocator is unrelated to the type
3845          --  of the access discriminant.
3846
3847          if Ekind (Typ) /= E_Anonymous_Access_Type
3848            or else Is_Local_Anonymous_Access (Typ)
3849          then
3850             Subtyp := Entity (Subtype_Mark (E));
3851
3852             Aggr := Original_Node (Expression (E));
3853
3854             if Has_Discriminants (Subtyp)
3855               and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate)
3856             then
3857                Discrim := First_Discriminant (Base_Type (Subtyp));
3858
3859                --  Get the first component expression of the aggregate
3860
3861                if Present (Expressions (Aggr)) then
3862                   Disc_Exp := First (Expressions (Aggr));
3863
3864                elsif Present (Component_Associations (Aggr)) then
3865                   Assoc := First (Component_Associations (Aggr));
3866
3867                   if Present (Assoc) then
3868                      Disc_Exp := Expression (Assoc);
3869                   else
3870                      Disc_Exp := Empty;
3871                   end if;
3872
3873                else
3874                   Disc_Exp := Empty;
3875                end if;
3876
3877                while Present (Discrim) and then Present (Disc_Exp) loop
3878                   if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
3879                      Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ);
3880                   end if;
3881
3882                   Next_Discriminant (Discrim);
3883
3884                   if Present (Discrim) then
3885                      if Present (Assoc) then
3886                         Next (Assoc);
3887                         Disc_Exp := Expression (Assoc);
3888
3889                      elsif Present (Next (Disc_Exp)) then
3890                         Next (Disc_Exp);
3891
3892                      else
3893                         Assoc := First (Component_Associations (Aggr));
3894
3895                         if Present (Assoc) then
3896                            Disc_Exp := Expression (Assoc);
3897                         else
3898                            Disc_Exp := Empty;
3899                         end if;
3900                      end if;
3901                   end if;
3902                end loop;
3903             end if;
3904          end if;
3905
3906       --  For a subtype mark or subtype indication, freeze the subtype
3907
3908       else
3909          Freeze_Expression (E);
3910
3911          if Is_Access_Constant (Typ) and then not No_Initialization (N) then
3912             Error_Msg_N
3913               ("initialization required for access-to-constant allocator", N);
3914          end if;
3915
3916          --  A special accessibility check is needed for allocators that
3917          --  constrain access discriminants. The level of the type of the
3918          --  expression used to constrain an access discriminant cannot be
3919          --  deeper than the type of the allocator (in contrast to access
3920          --  parameters, where the level of the actual can be arbitrary).
3921          --  We can't use Valid_Conversion to perform this check because
3922          --  in general the type of the allocator is unrelated to the type
3923          --  of the access discriminant.
3924
3925          if Nkind (Original_Node (E)) = N_Subtype_Indication
3926            and then (Ekind (Typ) /= E_Anonymous_Access_Type
3927                       or else Is_Local_Anonymous_Access (Typ))
3928          then
3929             Subtyp := Entity (Subtype_Mark (Original_Node (E)));
3930
3931             if Has_Discriminants (Subtyp) then
3932                Discrim := First_Discriminant (Base_Type (Subtyp));
3933                Constr := First (Constraints (Constraint (Original_Node (E))));
3934                while Present (Discrim) and then Present (Constr) loop
3935                   if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
3936                      if Nkind (Constr) = N_Discriminant_Association then
3937                         Disc_Exp := Original_Node (Expression (Constr));
3938                      else
3939                         Disc_Exp := Original_Node (Constr);
3940                      end if;
3941
3942                      Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ);
3943                   end if;
3944
3945                   Next_Discriminant (Discrim);
3946                   Next (Constr);
3947                end loop;
3948             end if;
3949          end if;
3950       end if;
3951
3952       --  Ada 2005 (AI-344): A class-wide allocator requires an accessibility
3953       --  check that the level of the type of the created object is not deeper
3954       --  than the level of the allocator's access type, since extensions can
3955       --  now occur at deeper levels than their ancestor types. This is a
3956       --  static accessibility level check; a run-time check is also needed in
3957       --  the case of an initialized allocator with a class-wide argument (see
3958       --  Expand_Allocator_Expression).
3959
3960       if Ada_Version >= Ada_05
3961         and then Is_Class_Wide_Type (Designated_Type (Typ))
3962       then
3963          declare
3964             Exp_Typ : Entity_Id;
3965
3966          begin
3967             if Nkind (E) = N_Qualified_Expression then
3968                Exp_Typ := Etype (E);
3969             elsif Nkind (E) = N_Subtype_Indication then
3970                Exp_Typ := Entity (Subtype_Mark (Original_Node (E)));
3971             else
3972                Exp_Typ := Entity (E);
3973             end if;
3974
3975             if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then
3976                if In_Instance_Body then
3977                   Error_Msg_N ("?type in allocator has deeper level than" &
3978                                " designated class-wide type", E);
3979                   Error_Msg_N ("\?Program_Error will be raised at run time",
3980                                E);
3981                   Rewrite (N,
3982                     Make_Raise_Program_Error (Sloc (N),
3983                       Reason => PE_Accessibility_Check_Failed));
3984                   Set_Etype (N, Typ);
3985
3986                --  Do not apply Ada 2005 accessibility checks on a class-wide
3987                --  allocator if the type given in the allocator is a formal
3988                --  type. A run-time check will be performed in the instance.
3989
3990                elsif not Is_Generic_Type (Exp_Typ) then
3991                   Error_Msg_N ("type in allocator has deeper level than" &
3992                                " designated class-wide type", E);
3993                end if;
3994             end if;
3995          end;
3996       end if;
3997
3998       --  Check for allocation from an empty storage pool
3999
4000       if No_Pool_Assigned (Typ) then
4001          declare
4002             Loc : constant Source_Ptr := Sloc (N);
4003          begin
4004             Error_Msg_N ("?allocation from empty storage pool!", N);
4005             Error_Msg_N ("\?Storage_Error will be raised at run time!", N);
4006             Insert_Action (N,
4007               Make_Raise_Storage_Error (Loc,
4008                 Reason => SE_Empty_Storage_Pool));
4009          end;
4010
4011       --  If the context is an unchecked conversion, as may happen within
4012       --  an inlined subprogram, the allocator is being resolved with its
4013       --  own anonymous type. In that case, if the target type has a specific
4014       --  storage pool, it must be inherited explicitly by the allocator type.
4015
4016       elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
4017         and then No (Associated_Storage_Pool (Typ))
4018       then
4019          Set_Associated_Storage_Pool
4020            (Typ, Associated_Storage_Pool (Etype (Parent (N))));
4021       end if;
4022
4023       --  An erroneous allocator may be rewritten as a raise Program_Error
4024       --  statement.
4025
4026       if Nkind (N) = N_Allocator then
4027
4028          --  An anonymous access discriminant is the definition of a
4029          --  coextension.
4030
4031          if Ekind (Typ) = E_Anonymous_Access_Type
4032            and then Nkind (Associated_Node_For_Itype (Typ)) =
4033                       N_Discriminant_Specification
4034          then
4035             --  Avoid marking an allocator as a dynamic coextension if it is
4036             --  within a static construct.
4037
4038             if not Is_Static_Coextension (N) then
4039                Set_Is_Dynamic_Coextension (N);
4040             end if;
4041
4042          --  Cleanup for potential static coextensions
4043
4044          else
4045             Set_Is_Dynamic_Coextension (N, False);
4046             Set_Is_Static_Coextension  (N, False);
4047          end if;
4048
4049          --  There is no need to propagate any nested coextensions if they
4050          --  are marked as static since they will be rewritten on the spot.
4051
4052          if not Is_Static_Coextension (N) then
4053             Propagate_Coextensions (N);
4054          end if;
4055       end if;
4056    end Resolve_Allocator;
4057
4058    ---------------------------
4059    -- Resolve_Arithmetic_Op --
4060    ---------------------------
4061
4062    --  Used for resolving all arithmetic operators except exponentiation
4063
4064    procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
4065       L   : constant Node_Id := Left_Opnd (N);
4066       R   : constant Node_Id := Right_Opnd (N);
4067       TL  : constant Entity_Id := Base_Type (Etype (L));
4068       TR  : constant Entity_Id := Base_Type (Etype (R));
4069       T   : Entity_Id;
4070       Rop : Node_Id;
4071
4072       B_Typ : constant Entity_Id := Base_Type (Typ);
4073       --  We do the resolution using the base type, because intermediate values
4074       --  in expressions always are of the base type, not a subtype of it.
4075
4076       function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean;
4077       --  Returns True if N is in a context that expects "any real type"
4078
4079       function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
4080       --  Return True iff given type is Integer or universal real/integer
4081
4082       procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
4083       --  Choose type of integer literal in fixed-point operation to conform
4084       --  to available fixed-point type. T is the type of the other operand,
4085       --  which is needed to determine the expected type of N.
4086
4087       procedure Set_Operand_Type (N : Node_Id);
4088       --  Set operand type to T if universal
4089
4090       -------------------------------
4091       -- Expected_Type_Is_Any_Real --
4092       -------------------------------
4093
4094       function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is
4095       begin
4096          --  N is the expression after "delta" in a fixed_point_definition;
4097          --  see RM-3.5.9(6):
4098
4099          return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition,
4100                                       N_Decimal_Fixed_Point_Definition,
4101
4102          --  N is one of the bounds in a real_range_specification;
4103          --  see RM-3.5.7(5):
4104
4105                                       N_Real_Range_Specification,
4106
4107          --  N is the expression of a delta_constraint;
4108          --  see RM-J.3(3):
4109
4110                                       N_Delta_Constraint);
4111       end Expected_Type_Is_Any_Real;
4112
4113       -----------------------------
4114       -- Is_Integer_Or_Universal --
4115       -----------------------------
4116
4117       function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
4118          T     : Entity_Id;
4119          Index : Interp_Index;
4120          It    : Interp;
4121
4122       begin
4123          if not Is_Overloaded (N) then
4124             T := Etype (N);
4125             return Base_Type (T) = Base_Type (Standard_Integer)
4126               or else T = Universal_Integer
4127               or else T = Universal_Real;
4128          else
4129             Get_First_Interp (N, Index, It);
4130             while Present (It.Typ) loop
4131                if Base_Type (It.Typ) = Base_Type (Standard_Integer)
4132                  or else It.Typ = Universal_Integer
4133                  or else It.Typ = Universal_Real
4134                then
4135                   return True;
4136                end if;
4137
4138                Get_Next_Interp (Index, It);
4139             end loop;
4140          end if;
4141
4142          return False;
4143       end Is_Integer_Or_Universal;
4144
4145       ----------------------------
4146       -- Set_Mixed_Mode_Operand --
4147       ----------------------------
4148
4149       procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
4150          Index : Interp_Index;
4151          It    : Interp;
4152
4153       begin
4154          if Universal_Interpretation (N) = Universal_Integer then
4155
4156             --  A universal integer literal is resolved as standard integer
4157             --  except in the case of a fixed-point result, where we leave it
4158             --  as universal (to be handled by Exp_Fixd later on)
4159
4160             if Is_Fixed_Point_Type (T) then
4161                Resolve (N, Universal_Integer);
4162             else
4163                Resolve (N, Standard_Integer);
4164             end if;
4165
4166          elsif Universal_Interpretation (N) = Universal_Real
4167            and then (T = Base_Type (Standard_Integer)
4168                       or else T = Universal_Integer
4169                       or else T = Universal_Real)
4170          then
4171             --  A universal real can appear in a fixed-type context. We resolve
4172             --  the literal with that context, even though this might raise an
4173             --  exception prematurely (the other operand may be zero).
4174
4175             Resolve (N, B_Typ);
4176
4177          elsif Etype (N) = Base_Type (Standard_Integer)
4178            and then T = Universal_Real
4179            and then Is_Overloaded (N)
4180          then
4181             --  Integer arg in mixed-mode operation. Resolve with universal
4182             --  type, in case preference rule must be applied.
4183
4184             Resolve (N, Universal_Integer);
4185
4186          elsif Etype (N) = T
4187            and then B_Typ /= Universal_Fixed
4188          then
4189             --  Not a mixed-mode operation, resolve with context
4190
4191             Resolve (N, B_Typ);
4192
4193          elsif Etype (N) = Any_Fixed then
4194
4195             --  N may itself be a mixed-mode operation, so use context type
4196
4197             Resolve (N, B_Typ);
4198
4199          elsif Is_Fixed_Point_Type (T)
4200            and then B_Typ = Universal_Fixed
4201            and then Is_Overloaded (N)
4202          then
4203             --  Must be (fixed * fixed) operation, operand must have one
4204             --  compatible interpretation.
4205
4206             Resolve (N, Any_Fixed);
4207
4208          elsif Is_Fixed_Point_Type (B_Typ)
4209            and then (T = Universal_Real
4210                       or else Is_Fixed_Point_Type (T))
4211            and then Is_Overloaded (N)
4212          then
4213             --  C * F(X) in a fixed context, where C is a real literal or a
4214             --  fixed-point expression. F must have either a fixed type
4215             --  interpretation or an integer interpretation, but not both.
4216
4217             Get_First_Interp (N, Index, It);
4218             while Present (It.Typ) loop
4219                if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
4220
4221                   if Analyzed (N) then
4222                      Error_Msg_N ("ambiguous operand in fixed operation", N);
4223                   else
4224                      Resolve (N, Standard_Integer);
4225                   end if;
4226
4227                elsif Is_Fixed_Point_Type (It.Typ) then
4228
4229                   if Analyzed (N) then
4230                      Error_Msg_N ("ambiguous operand in fixed operation", N);
4231                   else
4232                      Resolve (N, It.Typ);
4233                   end if;
4234                end if;
4235
4236                Get_Next_Interp (Index, It);
4237             end loop;
4238
4239             --  Reanalyze the literal with the fixed type of the context. If
4240             --  context is Universal_Fixed, we are within a conversion, leave
4241             --  the literal as a universal real because there is no usable
4242             --  fixed type, and the target of the conversion plays no role in
4243             --  the resolution.
4244
4245             declare
4246                Op2 : Node_Id;
4247                T2  : Entity_Id;
4248
4249             begin
4250                if N = L then
4251                   Op2 := R;
4252                else
4253                   Op2 := L;
4254                end if;
4255
4256                if B_Typ = Universal_Fixed
4257                   and then Nkind (Op2) = N_Real_Literal
4258                then
4259                   T2 := Universal_Real;
4260                else
4261                   T2 := B_Typ;
4262                end if;
4263
4264                Set_Analyzed (Op2, False);
4265                Resolve (Op2, T2);
4266             end;
4267
4268          else
4269             Resolve (N);
4270          end if;
4271       end Set_Mixed_Mode_Operand;
4272
4273       ----------------------
4274       -- Set_Operand_Type --
4275       ----------------------
4276
4277       procedure Set_Operand_Type (N : Node_Id) is
4278       begin
4279          if Etype (N) = Universal_Integer
4280            or else Etype (N) = Universal_Real
4281          then
4282             Set_Etype (N, T);
4283          end if;
4284       end Set_Operand_Type;
4285
4286    --  Start of processing for Resolve_Arithmetic_Op
4287
4288    begin
4289       if Comes_From_Source (N)
4290         and then Ekind (Entity (N)) = E_Function
4291         and then Is_Imported (Entity (N))
4292         and then Is_Intrinsic_Subprogram (Entity (N))
4293       then
4294          Resolve_Intrinsic_Operator (N, Typ);
4295          return;
4296
4297       --  Special-case for mixed-mode universal expressions or fixed point
4298       --  type operation: each argument is resolved separately. The same
4299       --  treatment is required if one of the operands of a fixed point
4300       --  operation is universal real, since in this case we don't do a
4301       --  conversion to a specific fixed-point type (instead the expander
4302       --  takes care of the case).
4303
4304       elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
4305         and then Present (Universal_Interpretation (L))
4306         and then Present (Universal_Interpretation (R))
4307       then
4308          Resolve (L, Universal_Interpretation (L));
4309          Resolve (R, Universal_Interpretation (R));
4310          Set_Etype (N, B_Typ);
4311
4312       elsif (B_Typ = Universal_Real
4313               or else Etype (N) = Universal_Fixed
4314               or else (Etype (N) = Any_Fixed
4315                         and then Is_Fixed_Point_Type (B_Typ))
4316               or else (Is_Fixed_Point_Type (B_Typ)
4317                         and then (Is_Integer_Or_Universal (L)
4318                                    or else
4319                                   Is_Integer_Or_Universal (R))))
4320         and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
4321       then
4322          if TL = Universal_Integer or else TR = Universal_Integer then
4323             Check_For_Visible_Operator (N, B_Typ);
4324          end if;
4325
4326          --  If context is a fixed type and one operand is integer, the
4327          --  other is resolved with the type of the context.
4328
4329          if Is_Fixed_Point_Type (B_Typ)
4330            and then (Base_Type (TL) = Base_Type (Standard_Integer)
4331                       or else TL = Universal_Integer)
4332          then
4333             Resolve (R, B_Typ);
4334             Resolve (L, TL);
4335
4336          elsif Is_Fixed_Point_Type (B_Typ)
4337            and then (Base_Type (TR) = Base_Type (Standard_Integer)
4338                       or else TR = Universal_Integer)
4339          then
4340             Resolve (L, B_Typ);
4341             Resolve (R, TR);
4342
4343          else
4344             Set_Mixed_Mode_Operand (L, TR);
4345             Set_Mixed_Mode_Operand (R, TL);
4346          end if;
4347
4348          --  Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed
4349          --  multiplying operators from being used when the expected type is
4350          --  also universal_fixed. Note that B_Typ will be Universal_Fixed in
4351          --  some cases where the expected type is actually Any_Real;
4352          --  Expected_Type_Is_Any_Real takes care of that case.
4353
4354          if Etype (N) = Universal_Fixed
4355            or else Etype (N) = Any_Fixed
4356          then
4357             if B_Typ = Universal_Fixed
4358               and then not Expected_Type_Is_Any_Real (N)
4359               and then not Nkind_In (Parent (N), N_Type_Conversion,
4360                                                  N_Unchecked_Type_Conversion)
4361             then
4362                Error_Msg_N ("type cannot be determined from context!", N);
4363                Error_Msg_N ("\explicit conversion to result type required", N);
4364
4365                Set_Etype (L, Any_Type);
4366                Set_Etype (R, Any_Type);
4367
4368             else
4369                if Ada_Version = Ada_83
4370                  and then Etype (N) = Universal_Fixed
4371                  and then not
4372                    Nkind_In (Parent (N), N_Type_Conversion,
4373                                          N_Unchecked_Type_Conversion)
4374                then
4375                   Error_Msg_N
4376                     ("(Ada 83) fixed-point operation "
4377                      & "needs explicit conversion", N);
4378                end if;
4379
4380                --  The expected type is "any real type" in contexts like
4381                --    type T is delta <universal_fixed-expression> ...
4382                --  in which case we need to set the type to Universal_Real
4383                --  so that static expression evaluation will work properly.
4384
4385                if Expected_Type_Is_Any_Real (N) then
4386                   Set_Etype (N, Universal_Real);
4387                else
4388                   Set_Etype (N, B_Typ);
4389                end if;
4390             end if;
4391
4392          elsif Is_Fixed_Point_Type (B_Typ)
4393            and then (Is_Integer_Or_Universal (L)
4394                        or else Nkind (L) = N_Real_Literal
4395                        or else Nkind (R) = N_Real_Literal
4396                        or else Is_Integer_Or_Universal (R))
4397          then
4398             Set_Etype (N, B_Typ);
4399
4400          elsif Etype (N) = Any_Fixed then
4401
4402             --  If no previous errors, this is only possible if one operand
4403             --  is overloaded and the context is universal. Resolve as such.
4404
4405             Set_Etype (N, B_Typ);
4406          end if;
4407
4408       else
4409          if (TL = Universal_Integer or else TL = Universal_Real)
4410               and then
4411             (TR = Universal_Integer or else TR = Universal_Real)
4412          then
4413             Check_For_Visible_Operator (N, B_Typ);
4414          end if;
4415
4416          --  If the context is Universal_Fixed and the operands are also
4417          --  universal fixed, this is an error, unless there is only one
4418          --  applicable fixed_point type (usually duration).
4419
4420          if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then
4421             T := Unique_Fixed_Point_Type (N);
4422
4423             if T  = Any_Type then
4424                Set_Etype (N, T);
4425                return;
4426             else
4427                Resolve (L, T);
4428                Resolve (R, T);
4429             end if;
4430
4431          else
4432             Resolve (L, B_Typ);
4433             Resolve (R, B_Typ);
4434          end if;
4435
4436          --  If one of the arguments was resolved to a non-universal type.
4437          --  label the result of the operation itself with the same type.
4438          --  Do the same for the universal argument, if any.
4439
4440          T := Intersect_Types (L, R);
4441          Set_Etype (N, Base_Type (T));
4442          Set_Operand_Type (L);
4443          Set_Operand_Type (R);
4444       end if;
4445
4446       Generate_Operator_Reference (N, Typ);
4447       Eval_Arithmetic_Op (N);
4448
4449       --  Set overflow and division checking bit. Much cleverer code needed
4450       --  here eventually and perhaps the Resolve routines should be separated
4451       --  for the various arithmetic operations, since they will need
4452       --  different processing. ???
4453
4454       if Nkind (N) in N_Op then
4455          if not Overflow_Checks_Suppressed (Etype (N)) then
4456             Enable_Overflow_Check (N);
4457          end if;
4458
4459          --  Give warning if explicit division by zero
4460
4461          if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod)
4462            and then not Division_Checks_Suppressed (Etype (N))
4463          then
4464             Rop := Right_Opnd (N);
4465
4466             if Compile_Time_Known_Value (Rop)
4467               and then ((Is_Integer_Type (Etype (Rop))
4468                            and then Expr_Value (Rop) = Uint_0)
4469                           or else
4470                         (Is_Real_Type (Etype (Rop))
4471                            and then Expr_Value_R (Rop) = Ureal_0))
4472             then
4473                --  Specialize the warning message according to the operation
4474
4475                case Nkind (N) is
4476                   when N_Op_Divide =>
4477                      Apply_Compile_Time_Constraint_Error
4478                        (N, "division by zero?", CE_Divide_By_Zero,
4479                         Loc => Sloc (Right_Opnd (N)));
4480
4481                   when N_Op_Rem =>
4482                      Apply_Compile_Time_Constraint_Error
4483                        (N, "rem with zero divisor?", CE_Divide_By_Zero,
4484                         Loc => Sloc (Right_Opnd (N)));
4485
4486                   when N_Op_Mod =>
4487                      Apply_Compile_Time_Constraint_Error
4488                        (N, "mod with zero divisor?", CE_Divide_By_Zero,
4489                         Loc => Sloc (Right_Opnd (N)));
4490
4491                   --  Division by zero can only happen with division, rem,
4492                   --  and mod operations.
4493
4494                   when others =>
4495                      raise Program_Error;
4496                end case;
4497
4498             --  Otherwise just set the flag to check at run time
4499
4500             else
4501                Activate_Division_Check (N);
4502             end if;
4503          end if;
4504
4505          --  If Restriction No_Implicit_Conditionals is active, then it is
4506          --  violated if either operand can be negative for mod, or for rem
4507          --  if both operands can be negative.
4508
4509          if Restrictions.Set (No_Implicit_Conditionals)
4510            and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
4511          then
4512             declare
4513                Lo : Uint;
4514                Hi : Uint;
4515                OK : Boolean;
4516
4517                LNeg : Boolean;
4518                RNeg : Boolean;
4519                --  Set if corresponding operand might be negative
4520
4521             begin
4522                Determine_Range (Left_Opnd (N), OK, Lo, Hi);
4523                LNeg := (not OK) or else Lo < 0;
4524
4525                Determine_Range (Right_Opnd (N), OK, Lo, Hi);
4526                RNeg := (not OK) or else Lo < 0;
4527
4528                if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg))
4529                     or else
4530                   (Nkind (N) = N_Op_Mod and then (LNeg or RNeg))
4531                then
4532                   Check_Restriction (No_Implicit_Conditionals, N);
4533                end if;
4534             end;
4535          end if;
4536       end if;
4537
4538       Check_Unset_Reference (L);
4539       Check_Unset_Reference (R);
4540    end Resolve_Arithmetic_Op;
4541
4542    ------------------
4543    -- Resolve_Call --
4544    ------------------
4545
4546    procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
4547       Loc     : constant Source_Ptr := Sloc (N);
4548       Subp    : constant Node_Id    := Name (N);
4549       Nam     : Entity_Id;
4550       I       : Interp_Index;
4551       It      : Interp;
4552       Norm_OK : Boolean;
4553       Scop    : Entity_Id;
4554       Rtype   : Entity_Id;
4555
4556    begin
4557       --  The context imposes a unique interpretation with type Typ on a
4558       --  procedure or function call. Find the entity of the subprogram that
4559       --  yields the expected type, and propagate the corresponding formal
4560       --  constraints on the actuals. The caller has established that an
4561       --  interpretation exists, and emitted an error if not unique.
4562
4563       --  First deal with the case of a call to an access-to-subprogram,
4564       --  dereference made explicit in Analyze_Call.
4565
4566       if Ekind (Etype (Subp)) = E_Subprogram_Type then
4567          if not Is_Overloaded (Subp) then
4568             Nam := Etype (Subp);
4569
4570          else
4571             --  Find the interpretation whose type (a subprogram type) has a
4572             --  return type that is compatible with the context. Analysis of
4573             --  the node has established that one exists.
4574
4575             Nam := Empty;
4576
4577             Get_First_Interp (Subp,  I, It);
4578             while Present (It.Typ) loop
4579                if Covers (Typ, Etype (It.Typ)) then
4580                   Nam := It.Typ;
4581                   exit;
4582                end if;
4583
4584                Get_Next_Interp (I, It);
4585             end loop;
4586
4587             if No (Nam) then
4588                raise Program_Error;
4589             end if;
4590          end if;
4591
4592          --  If the prefix is not an entity, then resolve it
4593
4594          if not Is_Entity_Name (Subp) then
4595             Resolve (Subp, Nam);
4596          end if;
4597
4598          --  For an indirect call, we always invalidate checks, since we do not
4599          --  know whether the subprogram is local or global. Yes we could do
4600          --  better here, e.g. by knowing that there are no local subprograms,
4601          --  but it does not seem worth the effort. Similarly, we kill all
4602          --  knowledge of current constant values.
4603
4604          Kill_Current_Values;
4605
4606       --  If this is a procedure call which is really an entry call, do
4607       --  the conversion of the procedure call to an entry call. Protected
4608       --  operations use the same circuitry because the name in the call
4609       --  can be an arbitrary expression with special resolution rules.
4610
4611       elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
4612         or else (Is_Entity_Name (Subp)
4613                   and then Ekind (Entity (Subp)) = E_Entry)
4614       then
4615          Resolve_Entry_Call (N, Typ);
4616          Check_Elab_Call (N);
4617
4618          --  Kill checks and constant values, as above for indirect case
4619          --  Who knows what happens when another task is activated?
4620
4621          Kill_Current_Values;
4622          return;
4623
4624       --  Normal subprogram call with name established in Resolve
4625
4626       elsif not (Is_Type (Entity (Subp))) then
4627          Nam := Entity (Subp);
4628          Set_Entity_With_Style_Check (Subp, Nam);
4629
4630       --  Otherwise we must have the case of an overloaded call
4631
4632       else
4633          pragma Assert (Is_Overloaded (Subp));
4634          Nam := Empty;  --  We know that it will be assigned in loop below
4635
4636          Get_First_Interp (Subp,  I, It);
4637          while Present (It.Typ) loop
4638             if Covers (Typ, It.Typ) then
4639                Nam := It.Nam;
4640                Set_Entity_With_Style_Check (Subp, Nam);
4641                exit;
4642             end if;
4643
4644             Get_Next_Interp (I, It);
4645          end loop;
4646       end if;
4647
4648       --  Check that a call to Current_Task does not occur in an entry body
4649
4650       if Is_RTE (Nam, RE_Current_Task) then
4651          declare
4652             P : Node_Id;
4653
4654          begin
4655             P := N;
4656             loop
4657                P := Parent (P);
4658
4659                --  Exclude calls that occur within the default of a formal
4660                --  parameter of the entry, since those are evaluated outside
4661                --  of the body.
4662
4663                exit when No (P) or else Nkind (P) = N_Parameter_Specification;
4664
4665                if Nkind (P) = N_Entry_Body
4666                  or else (Nkind (P) = N_Subprogram_Body
4667                            and then Is_Entry_Barrier_Function (P))
4668                then
4669                   Rtype := Etype (N);
4670                   Error_Msg_NE
4671                     ("?& should not be used in entry body (RM C.7(17))",
4672                      N, Nam);
4673                   Error_Msg_NE
4674                     ("\Program_Error will be raised at run time?", N, Nam);
4675                   Rewrite (N,
4676                     Make_Raise_Program_Error (Loc,
4677                       Reason => PE_Current_Task_In_Entry_Body));
4678                   Set_Etype (N, Rtype);
4679                   return;
4680                end if;
4681             end loop;
4682          end;
4683       end if;
4684
4685       --  Check that a procedure call does not occur in the context of the
4686       --  entry call statement of a conditional or timed entry call. Note that
4687       --  the case of a call to a subprogram renaming of an entry will also be
4688       --  rejected. The test for N not being an N_Entry_Call_Statement is
4689       --  defensive, covering the possibility that the processing of entry
4690       --  calls might reach this point due to later modifications of the code
4691       --  above.
4692
4693       if Nkind (Parent (N)) = N_Entry_Call_Alternative
4694         and then Nkind (N) /= N_Entry_Call_Statement
4695         and then Entry_Call_Statement (Parent (N)) = N
4696       then
4697          if Ada_Version < Ada_05 then
4698             Error_Msg_N ("entry call required in select statement", N);
4699
4700          --  Ada 2005 (AI-345): If a procedure_call_statement is used
4701          --  for a procedure_or_entry_call, the procedure_name or pro-
4702          --  cedure_prefix of the procedure_call_statement shall denote
4703          --  an entry renamed by a procedure, or (a view of) a primitive
4704          --  subprogram of a limited interface whose first parameter is
4705          --  a controlling parameter.
4706
4707          elsif Nkind (N) = N_Procedure_Call_Statement
4708            and then not Is_Renamed_Entry (Nam)
4709            and then not Is_Controlling_Limited_Procedure (Nam)
4710          then
4711             Error_Msg_N
4712              ("entry call or dispatching primitive of interface required", N);
4713          end if;
4714       end if;
4715
4716       --  Check that this is not a call to a protected procedure or
4717       --  entry from within a protected function.
4718
4719       if Ekind (Current_Scope) = E_Function
4720         and then Ekind (Scope (Current_Scope)) = E_Protected_Type
4721         and then Ekind (Nam) /= E_Function
4722         and then Scope (Nam) = Scope (Current_Scope)
4723       then
4724          Error_Msg_N ("within protected function, protected " &
4725            "object is constant", N);
4726          Error_Msg_N ("\cannot call operation that may modify it", N);
4727       end if;
4728
4729       --  Freeze the subprogram name if not in a spec-expression. Note that we
4730       --  freeze procedure calls as well as function calls. Procedure calls are
4731       --  not frozen according to the rules (RM 13.14(14)) because it is
4732       --  impossible to have a procedure call to a non-frozen procedure in pure
4733       --  Ada, but in the code that we generate in the expander, this rule
4734       --  needs extending because we can generate procedure calls that need
4735       --  freezing.
4736
4737       if Is_Entity_Name (Subp) and then not In_Spec_Expression then
4738          Freeze_Expression (Subp);
4739       end if;
4740
4741       --  For a predefined operator, the type of the result is the type imposed
4742       --  by context, except for a predefined operation on universal fixed.
4743       --  Otherwise The type of the call is the type returned by the subprogram
4744       --  being called.
4745
4746       if Is_Predefined_Op (Nam) then
4747          if Etype (N) /= Universal_Fixed then
4748             Set_Etype (N, Typ);
4749          end if;
4750
4751       --  If the subprogram returns an array type, and the context requires the
4752       --  component type of that array type, the node is really an indexing of
4753       --  the parameterless call. Resolve as such. A pathological case occurs
4754       --  when the type of the component is an access to the array type. In
4755       --  this case the call is truly ambiguous.
4756
4757       elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam))
4758         and then
4759           ((Is_Array_Type (Etype (Nam))
4760                    and then Covers (Typ, Component_Type (Etype (Nam))))
4761              or else (Is_Access_Type (Etype (Nam))
4762                         and then Is_Array_Type (Designated_Type (Etype (Nam)))
4763                         and then
4764                           Covers (Typ,
4765                             Component_Type (Designated_Type (Etype (Nam))))))
4766       then
4767          declare
4768             Index_Node : Node_Id;
4769             New_Subp   : Node_Id;
4770             Ret_Type   : constant Entity_Id := Etype (Nam);
4771
4772          begin
4773             if Is_Access_Type (Ret_Type)
4774               and then Ret_Type = Component_Type (Designated_Type (Ret_Type))
4775             then
4776                Error_Msg_N
4777                  ("cannot disambiguate function call and indexing", N);
4778             else
4779                New_Subp := Relocate_Node (Subp);
4780                Set_Entity (Subp, Nam);
4781
4782                if Component_Type (Ret_Type) /= Any_Type then
4783                   if Needs_No_Actuals (Nam) then
4784
4785                      --  Indexed call to a parameterless function
4786
4787                      Index_Node :=
4788                        Make_Indexed_Component (Loc,
4789                          Prefix =>
4790                            Make_Function_Call (Loc,
4791                              Name => New_Subp),
4792                          Expressions => Parameter_Associations (N));
4793                   else
4794                      --  An Ada 2005 prefixed call to a primitive operation
4795                      --  whose first parameter is the prefix. This prefix was
4796                      --  prepended to the parameter list, which is actually a
4797                      --  list of indices. Remove the prefix in order to build
4798                      --  the proper indexed component.
4799
4800                      Index_Node :=
4801                         Make_Indexed_Component (Loc,
4802                           Prefix =>
4803                             Make_Function_Call (Loc,
4804                                Name => New_Subp,
4805                                Parameter_Associations =>
4806                                  New_List
4807                                    (Remove_Head (Parameter_Associations (N)))),
4808                            Expressions => Parameter_Associations (N));
4809                   end if;
4810
4811                   --  Since we are correcting a node classification error made
4812                   --  by the parser, we call Replace rather than Rewrite.
4813
4814                   Replace (N, Index_Node);
4815                   Set_Etype (Prefix (N), Ret_Type);
4816                   Set_Etype (N, Typ);
4817                   Resolve_Indexed_Component (N, Typ);
4818                   Check_Elab_Call (Prefix (N));
4819                end if;
4820             end if;
4821
4822             return;
4823          end;
4824
4825       else
4826          Set_Etype (N, Etype (Nam));
4827       end if;
4828
4829       --  In the case where the call is to an overloaded subprogram, Analyze
4830       --  calls Normalize_Actuals once per overloaded subprogram. Therefore in
4831       --  such a case Normalize_Actuals needs to be called once more to order
4832       --  the actuals correctly. Otherwise the call will have the ordering
4833       --  given by the last overloaded subprogram whether this is the correct
4834       --  one being called or not.
4835
4836       if Is_Overloaded (Subp) then
4837          Normalize_Actuals (N, Nam, False, Norm_OK);
4838          pragma Assert (Norm_OK);
4839       end if;
4840
4841       --  In any case, call is fully resolved now. Reset Overload flag, to
4842       --  prevent subsequent overload resolution if node is analyzed again
4843
4844       Set_Is_Overloaded (Subp, False);
4845       Set_Is_Overloaded (N, False);
4846
4847       --  If we are calling the current subprogram from immediately within its
4848       --  body, then that is the case where we can sometimes detect cases of
4849       --  infinite recursion statically. Do not try this in case restriction
4850       --  No_Recursion is in effect anyway, and do it only for source calls.
4851
4852       if Comes_From_Source (N) then
4853          Scop := Current_Scope;
4854
4855          --  Issue warning for possible infinite recursion in the absence
4856          --  of the No_Recursion restriction.
4857
4858          if Nam = Scop
4859            and then not Restriction_Active (No_Recursion)
4860            and then Check_Infinite_Recursion (N)
4861          then
4862             --  Here we detected and flagged an infinite recursion, so we do
4863             --  not need to test the case below for further warnings. Also if
4864             --  we now have a raise SE node, we are all done.
4865
4866             if Nkind (N) = N_Raise_Storage_Error then
4867                return;
4868             end if;
4869
4870          --  If call is to immediately containing subprogram, then check for
4871          --  the case of a possible run-time detectable infinite recursion.
4872
4873          else
4874             Scope_Loop : while Scop /= Standard_Standard loop
4875                if Nam = Scop then
4876
4877                   --  Although in general case, recursion is not statically
4878                   --  checkable, the case of calling an immediately containing
4879                   --  subprogram is easy to catch.
4880
4881                   Check_Restriction (No_Recursion, N);
4882
4883                   --  If the recursive call is to a parameterless subprogram,
4884                   --  then even if we can't statically detect infinite
4885                   --  recursion, this is pretty suspicious, and we output a
4886                   --  warning. Furthermore, we will try later to detect some
4887                   --  cases here at run time by expanding checking code (see
4888                   --  Detect_Infinite_Recursion in package Exp_Ch6).
4889
4890                   --  If the recursive call is within a handler, do not emit a
4891                   --  warning, because this is a common idiom: loop until input
4892                   --  is correct, catch illegal input in handler and restart.
4893
4894                   if No (First_Formal (Nam))
4895                     and then Etype (Nam) = Standard_Void_Type
4896                     and then not Error_Posted (N)
4897                     and then Nkind (Parent (N)) /= N_Exception_Handler
4898                   then
4899                      --  For the case of a procedure call. We give the message
4900                      --  only if the call is the first statement in a sequence
4901                      --  of statements, or if all previous statements are
4902                      --  simple assignments. This is simply a heuristic to
4903                      --  decrease false positives, without losing too many good
4904                      --  warnings. The idea is that these previous statements
4905                      --  may affect global variables the procedure depends on.
4906
4907                      if Nkind (N) = N_Procedure_Call_Statement
4908                        and then Is_List_Member (N)
4909                      then
4910                         declare
4911                            P : Node_Id;
4912                         begin
4913                            P := Prev (N);
4914                            while Present (P) loop
4915                               if Nkind (P) /= N_Assignment_Statement then
4916                                  exit Scope_Loop;
4917                               end if;
4918
4919                               Prev (P);
4920                            end loop;
4921                         end;
4922                      end if;
4923
4924                      --  Do not give warning if we are in a conditional context
4925
4926                      declare
4927                         K : constant Node_Kind := Nkind (Parent (N));
4928                      begin
4929                         if (K = N_Loop_Statement
4930                             and then Present (Iteration_Scheme (Parent (N))))
4931                           or else K = N_If_Statement
4932                           or else K = N_Elsif_Part
4933                           or else K = N_Case_Statement_Alternative
4934                         then
4935                            exit Scope_Loop;
4936                         end if;
4937                      end;
4938
4939                      --  Here warning is to be issued
4940
4941                      Set_Has_Recursive_Call (Nam);
4942                      Error_Msg_N
4943                        ("?possible infinite recursion!", N);
4944                      Error_Msg_N
4945                        ("\?Storage_Error may be raised at run time!", N);
4946                   end if;
4947
4948                   exit Scope_Loop;
4949                end if;
4950
4951                Scop := Scope (Scop);
4952             end loop Scope_Loop;
4953          end if;
4954       end if;
4955
4956       --  If subprogram name is a predefined operator, it was given in
4957       --  functional notation. Replace call node with operator node, so
4958       --  that actuals can be resolved appropriately.
4959
4960       if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
4961          Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
4962          return;
4963
4964       elsif Present (Alias (Nam))
4965         and then Is_Predefined_Op (Alias (Nam))
4966       then
4967          Resolve_Actuals (N, Nam);
4968          Make_Call_Into_Operator (N, Typ, Alias (Nam));
4969          return;
4970       end if;
4971
4972       --  Create a transient scope if the resulting type requires it
4973
4974       --  There are 4 notable exceptions: in init procs, the transient scope
4975       --  overhead is not needed and even incorrect due to the actual expansion
4976       --  of adjust calls; the second case is enumeration literal pseudo calls;
4977       --  the third case is intrinsic subprograms (Unchecked_Conversion and
4978       --  source information functions) that do not use the secondary stack
4979       --  even though the return type is unconstrained; the fourth case is a
4980       --  call to a build-in-place function, since such functions may allocate
4981       --  their result directly in a target object, and cases where the result
4982       --  does get allocated in the secondary stack are checked for within the
4983       --  specialized Exp_Ch6 procedures for expanding build-in-place calls.
4984
4985       --  If this is an initialization call for a type whose initialization
4986       --  uses the secondary stack, we also need to create a transient scope
4987       --  for it, precisely because we will not do it within the init proc
4988       --  itself.
4989
4990       --  If the subprogram is marked Inline_Always, then even if it returns
4991       --  an unconstrained type the call does not require use of the secondary
4992       --  stack. However, inlining will only take place if the body to inline
4993       --  is already present. It may not be available if e.g. the subprogram is
4994       --  declared in a child instance.
4995
4996       if Is_Inlined (Nam)
4997         and then Has_Pragma_Inline_Always (Nam)
4998         and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
4999         and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
5000       then
5001          null;
5002
5003       elsif Expander_Active
5004         and then Is_Type (Etype (Nam))
5005         and then Requires_Transient_Scope (Etype (Nam))
5006         and then not Is_Build_In_Place_Function (Nam)
5007         and then Ekind (Nam) /= E_Enumeration_Literal
5008         and then not Within_Init_Proc
5009         and then not Is_Intrinsic_Subprogram (Nam)
5010       then
5011          Establish_Transient_Scope (N, Sec_Stack => True);
5012
5013          --  If the call appears within the bounds of a loop, it will
5014          --  be rewritten and reanalyzed, nothing left to do here.
5015
5016          if Nkind (N) /= N_Function_Call then
5017             return;
5018          end if;
5019
5020       elsif Is_Init_Proc (Nam)
5021         and then not Within_Init_Proc
5022       then
5023          Check_Initialization_Call (N, Nam);
5024       end if;
5025
5026       --  A protected function cannot be called within the definition of the
5027       --  enclosing protected type.
5028
5029       if Is_Protected_Type (Scope (Nam))
5030         and then In_Open_Scopes (Scope (Nam))
5031         and then not Has_Completion (Scope (Nam))
5032       then
5033          Error_Msg_NE
5034            ("& cannot be called before end of protected definition", N, Nam);
5035       end if;
5036
5037       --  Propagate interpretation to actuals, and add default expressions
5038       --  where needed.
5039
5040       if Present (First_Formal (Nam)) then
5041          Resolve_Actuals (N, Nam);
5042
5043          --  Overloaded literals are rewritten as function calls, for
5044          --  purpose of resolution. After resolution, we can replace
5045          --  the call with the literal itself.
5046
5047       elsif Ekind (Nam) = E_Enumeration_Literal then
5048          Copy_Node (Subp, N);
5049          Resolve_Entity_Name (N, Typ);
5050
5051          --  Avoid validation, since it is a static function call
5052
5053          Generate_Reference (Nam, Subp);
5054          return;
5055       end if;
5056
5057       --  If the subprogram is not global, then kill all saved values and
5058       --  checks. This is a bit conservative, since in many cases we could do
5059       --  better, but it is not worth the effort. Similarly, we kill constant
5060       --  values. However we do not need to do this for internal entities
5061       --  (unless they are inherited user-defined subprograms), since they
5062       --  are not in the business of molesting local values.
5063
5064       --  If the flag Suppress_Value_Tracking_On_Calls is set, then we also
5065       --  kill all checks and values for calls to global subprograms. This
5066       --  takes care of the case where an access to a local subprogram is
5067       --  taken, and could be passed directly or indirectly and then called
5068       --  from almost any context.
5069
5070       --  Note: we do not do this step till after resolving the actuals. That
5071       --  way we still take advantage of the current value information while
5072       --  scanning the actuals.
5073
5074       --  We suppress killing values if we are processing the nodes associated
5075       --  with N_Freeze_Entity nodes. Otherwise the declaration of a tagged
5076       --  type kills all the values as part of analyzing the code that
5077       --  initializes the dispatch tables.
5078
5079       if Inside_Freezing_Actions = 0
5080         and then (not Is_Library_Level_Entity (Nam)
5081                    or else Suppress_Value_Tracking_On_Call (Current_Scope))
5082         and then (Comes_From_Source (Nam)
5083                    or else (Present (Alias (Nam))
5084                              and then Comes_From_Source (Alias (Nam))))
5085       then
5086          Kill_Current_Values;
5087       end if;
5088
5089       --  If we are warning about unread OUT parameters, this is the place to
5090       --  set Last_Assignment for OUT and IN OUT parameters. We have to do this
5091       --  after the above call to Kill_Current_Values (since that call clears
5092       --  the Last_Assignment field of all local variables).
5093
5094       if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters)
5095         and then Comes_From_Source (N)
5096         and then In_Extended_Main_Source_Unit (N)
5097       then
5098          declare
5099             F : Entity_Id;
5100             A : Node_Id;
5101
5102          begin
5103             F := First_Formal (Nam);
5104             A := First_Actual (N);
5105             while Present (F) and then Present (A) loop
5106                if (Ekind (F) = E_Out_Parameter
5107                      or else Ekind (F) = E_In_Out_Parameter)
5108                  and then Warn_On_Modified_As_Out_Parameter (F)
5109                  and then Is_Entity_Name (A)
5110                  and then Present (Entity (A))
5111                  and then Comes_From_Source (N)
5112                  and then Safe_To_Capture_Value (N, Entity (A))
5113                then
5114                   Set_Last_Assignment (Entity (A), A);
5115                end if;
5116
5117                Next_Formal (F);
5118                Next_Actual (A);
5119             end loop;
5120          end;
5121       end if;
5122
5123       --  If the subprogram is a primitive operation, check whether or not
5124       --  it is a correct dispatching call.
5125
5126       if Is_Overloadable (Nam)
5127         and then Is_Dispatching_Operation (Nam)
5128       then
5129          Check_Dispatching_Call (N);
5130
5131       elsif Ekind (Nam) /= E_Subprogram_Type
5132         and then Is_Abstract_Subprogram (Nam)
5133         and then not In_Instance
5134       then
5135          Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
5136       end if;
5137
5138       --  If this is a dispatching call, generate the appropriate reference,
5139       --  for better source navigation in GPS.
5140
5141       if Is_Overloadable (Nam)
5142         and then Present (Controlling_Argument (N))
5143       then
5144          Generate_Reference (Nam, Subp, 'R');
5145       else
5146          Generate_Reference (Nam, Subp);
5147       end if;
5148
5149       if Is_Intrinsic_Subprogram (Nam) then
5150          Check_Intrinsic_Call (N);
5151       end if;
5152
5153       --  Check for violation of restriction No_Specific_Termination_Handlers
5154
5155       if Is_RTE (Nam, RE_Set_Specific_Handler)
5156            or else
5157          Is_RTE (Nam, RE_Specific_Handler)
5158       then
5159          Check_Restriction (No_Specific_Termination_Handlers, N);
5160       end if;
5161
5162       --  All done, evaluate call and deal with elaboration issues
5163
5164       Eval_Call (N);
5165       Check_Elab_Call (N);
5166    end Resolve_Call;
5167
5168    -------------------------------
5169    -- Resolve_Character_Literal --
5170    -------------------------------
5171
5172    procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
5173       B_Typ : constant Entity_Id := Base_Type (Typ);
5174       C     : Entity_Id;
5175
5176    begin
5177       --  Verify that the character does belong to the type of the context
5178
5179       Set_Etype (N, B_Typ);
5180       Eval_Character_Literal (N);
5181
5182       --  Wide_Wide_Character literals must always be defined, since the set
5183       --  of wide wide character literals is complete, i.e. if a character
5184       --  literal is accepted by the parser, then it is OK for wide wide
5185       --  character (out of range character literals are rejected).
5186
5187       if Root_Type (B_Typ) = Standard_Wide_Wide_Character then
5188          return;
5189
5190       --  Always accept character literal for type Any_Character, which
5191       --  occurs in error situations and in comparisons of literals, both
5192       --  of which should accept all literals.
5193
5194       elsif B_Typ = Any_Character then
5195          return;
5196
5197       --  For Standard.Character or a type derived from it, check that
5198       --  the literal is in range
5199
5200       elsif Root_Type (B_Typ) = Standard_Character then
5201          if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
5202             return;
5203          end if;
5204
5205       --  For Standard.Wide_Character or a type derived from it, check
5206       --  that the literal is in range
5207
5208       elsif Root_Type (B_Typ) = Standard_Wide_Character then
5209          if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
5210             return;
5211          end if;
5212
5213       --  For Standard.Wide_Wide_Character or a type derived from it, we
5214       --  know the literal is in range, since the parser checked!
5215
5216       elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
5217          return;
5218
5219       --  If the entity is already set, this has already been resolved in
5220       --  a generic context, or comes from expansion. Nothing else to do.
5221
5222       elsif Present (Entity (N)) then
5223          return;
5224
5225       --  Otherwise we have a user defined character type, and we can use
5226       --  the standard visibility mechanisms to locate the referenced entity
5227
5228       else
5229          C := Current_Entity (N);
5230          while Present (C) loop
5231             if Etype (C) = B_Typ then
5232                Set_Entity_With_Style_Check (N, C);
5233                Generate_Reference (C, N);
5234                return;
5235             end if;
5236
5237             C := Homonym (C);
5238          end loop;
5239       end if;
5240
5241       --  If we fall through, then the literal does not match any of the
5242       --  entries of the enumeration type. This isn't just a constraint
5243       --  error situation, it is an illegality (see RM 4.2).
5244
5245       Error_Msg_NE
5246         ("character not defined for }", N, First_Subtype (B_Typ));
5247    end Resolve_Character_Literal;
5248
5249    ---------------------------
5250    -- Resolve_Comparison_Op --
5251    ---------------------------
5252
5253    --  Context requires a boolean type, and plays no role in resolution.
5254    --  Processing identical to that for equality operators. The result
5255    --  type is the base type, which matters when pathological subtypes of
5256    --  booleans with limited ranges are used.
5257
5258    procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
5259       L : constant Node_Id := Left_Opnd (N);
5260       R : constant Node_Id := Right_Opnd (N);
5261       T : Entity_Id;
5262
5263    begin
5264       --  If this is an intrinsic operation which is not predefined, use
5265       --  the types of its declared arguments to resolve the possibly
5266       --  overloaded operands. Otherwise the operands are unambiguous and
5267       --  specify the expected type.
5268
5269       if Scope (Entity (N)) /= Standard_Standard then
5270          T := Etype (First_Entity (Entity (N)));
5271
5272       else
5273          T := Find_Unique_Type (L, R);
5274
5275          if T = Any_Fixed then
5276             T := Unique_Fixed_Point_Type (L);
5277          end if;
5278       end if;
5279
5280       Set_Etype (N, Base_Type (Typ));
5281       Generate_Reference (T, N, ' ');
5282
5283       if T /= Any_Type then
5284          if T = Any_String
5285            or else T = Any_Composite
5286            or else T = Any_Character
5287          then
5288             if T = Any_Character then
5289                Ambiguous_Character (L);
5290             else
5291                Error_Msg_N ("ambiguous operands for comparison", N);
5292             end if;
5293
5294             Set_Etype (N, Any_Type);
5295             return;
5296
5297          else
5298             Resolve (L, T);
5299             Resolve (R, T);
5300             Check_Unset_Reference (L);
5301             Check_Unset_Reference (R);
5302             Generate_Operator_Reference (N, T);
5303             Eval_Relational_Op (N);
5304          end if;
5305       end if;
5306    end Resolve_Comparison_Op;
5307
5308    ------------------------------------
5309    -- Resolve_Conditional_Expression --
5310    ------------------------------------
5311
5312    procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
5313       Condition : constant Node_Id := First (Expressions (N));
5314       Then_Expr : constant Node_Id := Next (Condition);
5315       Else_Expr : constant Node_Id := Next (Then_Expr);
5316
5317    begin
5318       Resolve (Condition, Standard_Boolean);
5319       Resolve (Then_Expr, Typ);
5320       Resolve (Else_Expr, Typ);
5321
5322       Set_Etype (N, Typ);
5323       Eval_Conditional_Expression (N);
5324    end Resolve_Conditional_Expression;
5325
5326    -----------------------------------------
5327    -- Resolve_Discrete_Subtype_Indication --
5328    -----------------------------------------
5329
5330    procedure Resolve_Discrete_Subtype_Indication
5331      (N   : Node_Id;
5332       Typ : Entity_Id)
5333    is
5334       R : Node_Id;
5335       S : Entity_Id;
5336
5337    begin
5338       Analyze (Subtype_Mark (N));
5339       S := Entity (Subtype_Mark (N));
5340
5341       if Nkind (Constraint (N)) /= N_Range_Constraint then
5342          Error_Msg_N ("expect range constraint for discrete type", N);
5343          Set_Etype (N, Any_Type);
5344
5345       else
5346          R := Range_Expression (Constraint (N));
5347
5348          if R = Error then
5349             return;
5350          end if;
5351
5352          Analyze (R);
5353
5354          if Base_Type (S) /= Base_Type (Typ) then
5355             Error_Msg_NE
5356               ("expect subtype of }", N, First_Subtype (Typ));
5357
5358             --  Rewrite the constraint as a range of Typ
5359             --  to allow compilation to proceed further.
5360
5361             Set_Etype (N, Typ);
5362             Rewrite (Low_Bound (R),
5363               Make_Attribute_Reference (Sloc (Low_Bound (R)),
5364                 Prefix =>         New_Occurrence_Of (Typ, Sloc (R)),
5365                 Attribute_Name => Name_First));
5366             Rewrite (High_Bound (R),
5367               Make_Attribute_Reference (Sloc (High_Bound (R)),
5368                 Prefix =>         New_Occurrence_Of (Typ, Sloc (R)),
5369                 Attribute_Name => Name_First));
5370
5371          else
5372             Resolve (R, Typ);
5373             Set_Etype (N, Etype (R));
5374
5375             --  Additionally, we must check that the bounds are compatible
5376             --  with the given subtype, which might be different from the
5377             --  type of the context.
5378
5379             Apply_Range_Check (R, S);
5380
5381             --  ??? If the above check statically detects a Constraint_Error
5382             --  it replaces the offending bound(s) of the range R with a
5383             --  Constraint_Error node. When the itype which uses these bounds
5384             --  is frozen the resulting call to Duplicate_Subexpr generates
5385             --  a new temporary for the bounds.
5386
5387             --  Unfortunately there are other itypes that are also made depend
5388             --  on these bounds, so when Duplicate_Subexpr is called they get
5389             --  a forward reference to the newly created temporaries and Gigi
5390             --  aborts on such forward references. This is probably sign of a
5391             --  more fundamental problem somewhere else in either the order of
5392             --  itype freezing or the way certain itypes are constructed.
5393
5394             --  To get around this problem we call Remove_Side_Effects right
5395             --  away if either bounds of R are a Constraint_Error.
5396
5397             declare
5398                L : constant Node_Id := Low_Bound (R);
5399                H : constant Node_Id := High_Bound (R);
5400
5401             begin
5402                if Nkind (L) = N_Raise_Constraint_Error then
5403                   Remove_Side_Effects (L);
5404                end if;
5405
5406                if Nkind (H) = N_Raise_Constraint_Error then
5407                   Remove_Side_Effects (H);
5408                end if;
5409             end;
5410
5411             Check_Unset_Reference (Low_Bound  (R));
5412             Check_Unset_Reference (High_Bound (R));
5413          end if;
5414       end if;
5415    end Resolve_Discrete_Subtype_Indication;
5416
5417    -------------------------
5418    -- Resolve_Entity_Name --
5419    -------------------------
5420
5421    --  Used to resolve identifiers and expanded names
5422
5423    procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
5424       E : constant Entity_Id := Entity (N);
5425
5426    begin
5427       --  If garbage from errors, set to Any_Type and return
5428
5429       if No (E) and then Total_Errors_Detected /= 0 then
5430          Set_Etype (N, Any_Type);
5431          return;
5432       end if;
5433
5434       --  Replace named numbers by corresponding literals. Note that this is
5435       --  the one case where Resolve_Entity_Name must reset the Etype, since
5436       --  it is currently marked as universal.
5437
5438       if Ekind (E) = E_Named_Integer then
5439          Set_Etype (N, Typ);
5440          Eval_Named_Integer (N);
5441
5442       elsif Ekind (E) = E_Named_Real then
5443          Set_Etype (N, Typ);
5444          Eval_Named_Real (N);
5445
5446       --  Allow use of subtype only if it is a concurrent type where we are
5447       --  currently inside the body. This will eventually be expanded
5448       --  into a call to Self (for tasks) or _object (for protected
5449       --  objects). Any other use of a subtype is invalid.
5450
5451       elsif Is_Type (E) then
5452          if Is_Concurrent_Type (E)
5453            and then In_Open_Scopes (E)
5454          then
5455             null;
5456          else
5457             Error_Msg_N
5458                ("invalid use of subtype mark in expression or call", N);
5459          end if;
5460
5461       --  Check discriminant use if entity is discriminant in current scope,
5462       --  i.e. discriminant of record or concurrent type currently being
5463       --  analyzed. Uses in corresponding body are unrestricted.
5464
5465       elsif Ekind (E) = E_Discriminant
5466         and then Scope (E) = Current_Scope
5467         and then not Has_Completion (Current_Scope)
5468       then
5469          Check_Discriminant_Use (N);
5470
5471       --  A parameterless generic function cannot appear in a context that
5472       --  requires resolution.
5473
5474       elsif Ekind (E) = E_Generic_Function then
5475          Error_Msg_N ("illegal use of generic function", N);
5476
5477       elsif Ekind (E) = E_Out_Parameter
5478         and then Ada_Version = Ada_83
5479         and then (Nkind (Parent (N)) in N_Op
5480                     or else (Nkind (Parent (N)) = N_Assignment_Statement
5481                               and then N = Expression (Parent (N)))
5482                     or else Nkind (Parent (N)) = N_Explicit_Dereference)
5483       then
5484          Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
5485
5486       --  In all other cases, just do the possible static evaluation
5487
5488       else
5489          --  A deferred constant that appears in an expression must have
5490          --  a completion, unless it has been removed by in-place expansion
5491          --  of an aggregate.
5492
5493          if Ekind (E) = E_Constant
5494            and then Comes_From_Source (E)
5495            and then No (Constant_Value (E))
5496            and then Is_Frozen (Etype (E))
5497            and then not In_Spec_Expression
5498            and then not Is_Imported (E)
5499          then
5500
5501             if No_Initialization (Parent (E))
5502               or else (Present (Full_View (E))
5503                         and then No_Initialization (Parent (Full_View (E))))
5504             then
5505                null;
5506             else
5507                Error_Msg_N (
5508                  "deferred constant is frozen before completion", N);
5509             end if;
5510          end if;
5511
5512          Eval_Entity_Name (N);
5513       end if;
5514    end Resolve_Entity_Name;
5515
5516    -------------------
5517    -- Resolve_Entry --
5518    -------------------
5519
5520    procedure Resolve_Entry (Entry_Name : Node_Id) is
5521       Loc    : constant Source_Ptr := Sloc (Entry_Name);
5522       Nam    : Entity_Id;
5523       New_N  : Node_Id;
5524       S      : Entity_Id;
5525       Tsk    : Entity_Id;
5526       E_Name : Node_Id;
5527       Index  : Node_Id;
5528
5529       function Actual_Index_Type (E : Entity_Id) return Entity_Id;
5530       --  If the bounds of the entry family being called depend on task
5531       --  discriminants, build a new index subtype where a discriminant is
5532       --  replaced with the value of the discriminant of the target task.
5533       --  The target task is the prefix of the entry name in the call.
5534
5535       -----------------------
5536       -- Actual_Index_Type --
5537       -----------------------
5538
5539       function Actual_Index_Type (E : Entity_Id) return Entity_Id is
5540          Typ   : constant Entity_Id := Entry_Index_Type (E);
5541          Tsk   : constant Entity_Id := Scope (E);
5542          Lo    : constant Node_Id   := Type_Low_Bound  (Typ);
5543          Hi    : constant Node_Id   := Type_High_Bound (Typ);
5544          New_T : Entity_Id;
5545
5546          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
5547          --  If the bound is given by a discriminant, replace with a reference
5548          --  to the discriminant of the same name in the target task.
5549          --  If the entry name is the target of a requeue statement and the
5550          --  entry is in the current protected object, the bound to be used
5551          --  is the discriminal of the object (see apply_range_checks for
5552          --  details of the transformation).
5553
5554          -----------------------------
5555          -- Actual_Discriminant_Ref --
5556          -----------------------------
5557
5558          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
5559             Typ : constant Entity_Id := Etype (Bound);
5560             Ref : Node_Id;
5561
5562          begin
5563             Remove_Side_Effects (Bound);
5564
5565             if not Is_Entity_Name (Bound)
5566               or else Ekind (Entity (Bound)) /= E_Discriminant
5567             then
5568                return Bound;
5569
5570             elsif Is_Protected_Type (Tsk)
5571               and then In_Open_Scopes (Tsk)
5572               and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
5573             then
5574                return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
5575
5576             else
5577                Ref :=
5578                  Make_Selected_Component (Loc,
5579                    Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
5580                    Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
5581                Analyze (Ref);
5582                Resolve (Ref, Typ);
5583                return Ref;
5584             end if;
5585          end Actual_Discriminant_Ref;
5586
5587       --  Start of processing for Actual_Index_Type
5588
5589       begin
5590          if not Has_Discriminants (Tsk)
5591            or else (not Is_Entity_Name (Lo)
5592                      and then not Is_Entity_Name (Hi))
5593          then
5594             return Entry_Index_Type (E);
5595
5596          else
5597             New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
5598             Set_Etype        (New_T, Base_Type (Typ));
5599             Set_Size_Info    (New_T, Typ);
5600             Set_RM_Size      (New_T, RM_Size (Typ));
5601             Set_Scalar_Range (New_T,
5602               Make_Range (Sloc (Entry_Name),
5603                 Low_Bound  => Actual_Discriminant_Ref (Lo),
5604                 High_Bound => Actual_Discriminant_Ref (Hi)));
5605
5606             return New_T;
5607          end if;
5608       end Actual_Index_Type;
5609
5610    --  Start of processing of Resolve_Entry
5611
5612    begin
5613       --  Find name of entry being called, and resolve prefix of name
5614       --  with its own type. The prefix can be overloaded, and the name
5615       --  and signature of the entry must be taken into account.
5616
5617       if Nkind (Entry_Name) = N_Indexed_Component then
5618
5619          --  Case of dealing with entry family within the current tasks
5620
5621          E_Name := Prefix (Entry_Name);
5622
5623       else
5624          E_Name := Entry_Name;
5625       end if;
5626
5627       if Is_Entity_Name (E_Name) then
5628          --  Entry call to an entry (or entry family) in the current task.
5629          --  This is legal even though the task will deadlock. Rewrite as
5630          --  call to current task.
5631
5632          --  This can also be a call to an entry in  an enclosing task.
5633          --  If this is a single task, we have to retrieve its name,
5634          --  because the scope of the entry is the task type, not the
5635          --  object. If the enclosing task is a task type, the identity
5636          --  of the task is given by its own self variable.
5637
5638          --  Finally this can be a requeue on an entry of the same task
5639          --  or protected object.
5640
5641          S := Scope (Entity (E_Name));
5642
5643          for J in reverse 0 .. Scope_Stack.Last loop
5644
5645             if Is_Task_Type (Scope_Stack.Table (J).Entity)
5646               and then not Comes_From_Source (S)
5647             then
5648                --  S is an enclosing task or protected object. The concurrent
5649                --  declaration has been converted into a type declaration, and
5650                --  the object itself has an object declaration that follows
5651                --  the type in the same declarative part.
5652
5653                Tsk := Next_Entity (S);
5654                while Etype (Tsk) /= S loop
5655                   Next_Entity (Tsk);
5656                end loop;
5657
5658                S := Tsk;
5659                exit;
5660
5661             elsif S = Scope_Stack.Table (J).Entity then
5662
5663                --  Call to current task. Will be transformed into call to Self
5664
5665                exit;
5666
5667             end if;
5668          end loop;
5669
5670          New_N :=
5671            Make_Selected_Component (Loc,
5672              Prefix => New_Occurrence_Of (S, Loc),
5673              Selector_Name =>
5674                New_Occurrence_Of (Entity (E_Name), Loc));
5675          Rewrite (E_Name, New_N);
5676          Analyze (E_Name);
5677
5678       elsif Nkind (Entry_Name) = N_Selected_Component
5679         and then Is_Overloaded (Prefix (Entry_Name))
5680       then
5681          --  Use the entry name (which must be unique at this point) to
5682          --  find the prefix that returns the corresponding task type or
5683          --  protected type.
5684
5685          declare
5686             Pref : constant Node_Id := Prefix (Entry_Name);
5687             Ent  : constant Entity_Id :=  Entity (Selector_Name (Entry_Name));
5688             I    : Interp_Index;
5689             It   : Interp;
5690
5691          begin
5692             Get_First_Interp (Pref, I, It);
5693             while Present (It.Typ) loop
5694                if Scope (Ent) = It.Typ then
5695                   Set_Etype (Pref, It.Typ);
5696                   exit;
5697                end if;
5698
5699                Get_Next_Interp (I, It);
5700             end loop;
5701          end;
5702       end if;
5703
5704       if Nkind (Entry_Name) = N_Selected_Component then
5705          Resolve (Prefix (Entry_Name));
5706
5707       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
5708          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
5709          Resolve (Prefix (Prefix (Entry_Name)));
5710          Index :=  First (Expressions (Entry_Name));
5711          Resolve (Index, Entry_Index_Type (Nam));
5712
5713          --  Up to this point the expression could have been the actual
5714          --  in a simple entry call, and be given by a named association.
5715
5716          if Nkind (Index) = N_Parameter_Association then
5717             Error_Msg_N ("expect expression for entry index", Index);
5718          else
5719             Apply_Range_Check (Index, Actual_Index_Type (Nam));
5720          end if;
5721       end if;
5722    end Resolve_Entry;
5723
5724    ------------------------
5725    -- Resolve_Entry_Call --
5726    ------------------------
5727
5728    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
5729       Entry_Name  : constant Node_Id    := Name (N);
5730       Loc         : constant Source_Ptr := Sloc (Entry_Name);
5731       Actuals     : List_Id;
5732       First_Named : Node_Id;
5733       Nam         : Entity_Id;
5734       Norm_OK     : Boolean;
5735       Obj         : Node_Id;
5736       Was_Over    : Boolean;
5737
5738    begin
5739       --  We kill all checks here, because it does not seem worth the
5740       --  effort to do anything better, an entry call is a big operation.
5741
5742       Kill_All_Checks;
5743
5744       --  Processing of the name is similar for entry calls and protected
5745       --  operation calls. Once the entity is determined, we can complete
5746       --  the resolution of the actuals.
5747
5748       --  The selector may be overloaded, in the case of a protected object
5749       --  with overloaded functions. The type of the context is used for
5750       --  resolution.
5751
5752       if Nkind (Entry_Name) = N_Selected_Component
5753         and then Is_Overloaded (Selector_Name (Entry_Name))
5754         and then Typ /= Standard_Void_Type
5755       then
5756          declare
5757             I  : Interp_Index;
5758             It : Interp;
5759
5760          begin
5761             Get_First_Interp (Selector_Name (Entry_Name), I, It);
5762             while Present (It.Typ) loop
5763                if Covers (Typ, It.Typ) then
5764                   Set_Entity (Selector_Name (Entry_Name), It.Nam);
5765                   Set_Etype  (Entry_Name, It.Typ);
5766
5767                   Generate_Reference (It.Typ, N, ' ');
5768                end if;
5769
5770                Get_Next_Interp (I, It);
5771             end loop;
5772          end;
5773       end if;
5774
5775       Resolve_Entry (Entry_Name);
5776
5777       if Nkind (Entry_Name) = N_Selected_Component then
5778
5779          --  Simple entry call
5780
5781          Nam := Entity (Selector_Name (Entry_Name));
5782          Obj := Prefix (Entry_Name);
5783          Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
5784
5785       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
5786
5787          --  Call to member of entry family
5788
5789          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
5790          Obj := Prefix (Prefix (Entry_Name));
5791          Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
5792       end if;
5793
5794       --  We cannot in general check the maximum depth of protected entry
5795       --  calls at compile time. But we can tell that any protected entry
5796       --  call at all violates a specified nesting depth of zero.
5797
5798       if Is_Protected_Type (Scope (Nam)) then
5799          Check_Restriction (Max_Entry_Queue_Length, N);
5800       end if;
5801
5802       --  Use context type to disambiguate a protected function that can be
5803       --  called without actuals and that returns an array type, and where
5804       --  the argument list may be an indexing of the returned value.
5805
5806       if Ekind (Nam) = E_Function
5807         and then Needs_No_Actuals (Nam)
5808         and then Present (Parameter_Associations (N))
5809         and then
5810           ((Is_Array_Type (Etype (Nam))
5811              and then Covers (Typ, Component_Type (Etype (Nam))))
5812
5813             or else (Is_Access_Type (Etype (Nam))
5814                       and then Is_Array_Type (Designated_Type (Etype (Nam)))
5815                       and then Covers (Typ,
5816                         Component_Type (Designated_Type (Etype (Nam))))))
5817       then
5818          declare
5819             Index_Node : Node_Id;
5820
5821          begin
5822             Index_Node :=
5823               Make_Indexed_Component (Loc,
5824                 Prefix =>
5825                   Make_Function_Call (Loc,
5826                     Name => Relocate_Node (Entry_Name)),
5827                 Expressions => Parameter_Associations (N));
5828
5829             --  Since we are correcting a node classification error made by
5830             --  the parser, we call Replace rather than Rewrite.
5831
5832             Replace (N, Index_Node);
5833             Set_Etype (Prefix (N), Etype (Nam));
5834             Set_Etype (N, Typ);
5835             Resolve_Indexed_Component (N, Typ);
5836             return;
5837          end;
5838       end if;
5839
5840       --  The operation name may have been overloaded. Order the actuals
5841       --  according to the formals of the resolved entity, and set the
5842       --  return type to that of the operation.
5843
5844       if Was_Over then
5845          Normalize_Actuals (N, Nam, False, Norm_OK);
5846          pragma Assert (Norm_OK);
5847          Set_Etype (N, Etype (Nam));
5848       end if;
5849
5850       Resolve_Actuals (N, Nam);
5851       Generate_Reference (Nam, Entry_Name);
5852
5853       if Ekind (Nam) = E_Entry
5854         or else Ekind (Nam) = E_Entry_Family
5855       then
5856          Check_Potentially_Blocking_Operation (N);
5857       end if;
5858
5859       --  Verify that a procedure call cannot masquerade as an entry
5860       --  call where an entry call is expected.
5861
5862       if Ekind (Nam) = E_Procedure then
5863          if Nkind (Parent (N)) = N_Entry_Call_Alternative
5864            and then N = Entry_Call_Statement (Parent (N))
5865          then
5866             Error_Msg_N ("entry call required in select statement", N);
5867
5868          elsif Nkind (Parent (N)) = N_Triggering_Alternative
5869            and then N = Triggering_Statement (Parent (N))
5870          then
5871             Error_Msg_N ("triggering statement cannot be procedure call", N);
5872
5873          elsif Ekind (Scope (Nam)) = E_Task_Type
5874            and then not In_Open_Scopes (Scope (Nam))
5875          then
5876             Error_Msg_N ("task has no entry with this name", Entry_Name);
5877          end if;
5878       end if;
5879
5880       --  After resolution, entry calls and protected procedure calls
5881       --  are changed into entry calls, for expansion. The structure
5882       --  of the node does not change, so it can safely be done in place.
5883       --  Protected function calls must keep their structure because they
5884       --  are subexpressions.
5885
5886       if Ekind (Nam) /= E_Function then
5887
5888          --  A protected operation that is not a function may modify the
5889          --  corresponding object, and cannot apply to a constant.
5890          --  If this is an internal call, the prefix is the type itself.
5891
5892          if Is_Protected_Type (Scope (Nam))
5893            and then not Is_Variable (Obj)
5894            and then (not Is_Entity_Name (Obj)
5895                        or else not Is_Type (Entity (Obj)))
5896          then
5897             Error_Msg_N
5898               ("prefix of protected procedure or entry call must be variable",
5899                Entry_Name);
5900          end if;
5901
5902          Actuals := Parameter_Associations (N);
5903          First_Named := First_Named_Actual (N);
5904
5905          Rewrite (N,
5906            Make_Entry_Call_Statement (Loc,
5907              Name                   => Entry_Name,
5908              Parameter_Associations => Actuals));
5909
5910          Set_First_Named_Actual (N, First_Named);
5911          Set_Analyzed (N, True);
5912
5913       --  Protected functions can return on the secondary stack, in which
5914       --  case we must trigger the transient scope mechanism.
5915
5916       elsif Expander_Active
5917         and then Requires_Transient_Scope (Etype (Nam))
5918       then
5919          Establish_Transient_Scope (N, Sec_Stack => True);
5920       end if;
5921    end Resolve_Entry_Call;
5922
5923    -------------------------
5924    -- Resolve_Equality_Op --
5925    -------------------------
5926
5927    --  Both arguments must have the same type, and the boolean context
5928    --  does not participate in the resolution. The first pass verifies
5929    --  that the interpretation is not ambiguous, and the type of the left
5930    --  argument is correctly set, or is Any_Type in case of ambiguity.
5931    --  If both arguments are strings or aggregates, allocators, or Null,
5932    --  they are ambiguous even though they carry a single (universal) type.
5933    --  Diagnose this case here.
5934
5935    procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
5936       L : constant Node_Id   := Left_Opnd (N);
5937       R : constant Node_Id   := Right_Opnd (N);
5938       T : Entity_Id := Find_Unique_Type (L, R);
5939
5940       function Find_Unique_Access_Type return Entity_Id;
5941       --  In the case of allocators, make a last-ditch attempt to find a single
5942       --  access type with the right designated type. This is semantically
5943       --  dubious, and of no interest to any real code, but c48008a makes it
5944       --  all worthwhile.
5945
5946       -----------------------------
5947       -- Find_Unique_Access_Type --
5948       -----------------------------
5949
5950       function Find_Unique_Access_Type return Entity_Id is
5951          Acc : Entity_Id;
5952          E   : Entity_Id;
5953          S   : Entity_Id;
5954
5955       begin
5956          if Ekind (Etype (R)) =  E_Allocator_Type then
5957             Acc := Designated_Type (Etype (R));
5958          elsif Ekind (Etype (L)) =  E_Allocator_Type then
5959             Acc := Designated_Type (Etype (L));
5960          else
5961             return Empty;
5962          end if;
5963
5964          S := Current_Scope;
5965          while S /= Standard_Standard loop
5966             E := First_Entity (S);
5967             while Present (E) loop
5968                if Is_Type (E)
5969                  and then Is_Access_Type (E)
5970                  and then Ekind (E) /= E_Allocator_Type
5971                  and then Designated_Type (E) = Base_Type (Acc)
5972                then
5973                   return E;
5974                end if;
5975
5976                Next_Entity (E);
5977             end loop;
5978
5979             S := Scope (S);
5980          end loop;
5981
5982          return Empty;
5983       end Find_Unique_Access_Type;
5984
5985    --  Start of processing for Resolve_Equality_Op
5986
5987    begin
5988       Set_Etype (N, Base_Type (Typ));
5989       Generate_Reference (T, N, ' ');
5990
5991       if T = Any_Fixed then
5992          T := Unique_Fixed_Point_Type (L);
5993       end if;
5994
5995       if T /= Any_Type then
5996          if T = Any_String
5997            or else T = Any_Composite
5998            or else T = Any_Character
5999          then
6000             if T = Any_Character then
6001                Ambiguous_Character (L);
6002             else
6003                Error_Msg_N ("ambiguous operands for equality", N);
6004             end if;
6005
6006             Set_Etype (N, Any_Type);
6007             return;
6008
6009          elsif T = Any_Access
6010            or else Ekind (T) = E_Allocator_Type
6011            or else Ekind (T) = E_Access_Attribute_Type
6012          then
6013             T := Find_Unique_Access_Type;
6014
6015             if No (T) then
6016                Error_Msg_N ("ambiguous operands for equality", N);
6017                Set_Etype (N, Any_Type);
6018                return;
6019             end if;
6020          end if;
6021
6022          Resolve (L, T);
6023          Resolve (R, T);
6024
6025          --  If the unique type is a class-wide type then it will be expanded
6026          --  into a dispatching call to the predefined primitive. Therefore we
6027          --  check here for potential violation of such restriction.
6028
6029          if Is_Class_Wide_Type (T) then
6030             Check_Restriction (No_Dispatching_Calls, N);
6031          end if;
6032
6033          if Warn_On_Redundant_Constructs
6034            and then Comes_From_Source (N)
6035            and then Is_Entity_Name (R)
6036            and then Entity (R) = Standard_True
6037            and then Comes_From_Source (R)
6038          then
6039             Error_Msg_N ("?comparison with True is redundant!", R);
6040          end if;
6041
6042          Check_Unset_Reference (L);
6043          Check_Unset_Reference (R);
6044          Generate_Operator_Reference (N, T);
6045
6046          --  If this is an inequality, it may be the implicit inequality
6047          --  created for a user-defined operation, in which case the corres-
6048          --  ponding equality operation is not intrinsic, and the operation
6049          --  cannot be constant-folded. Else fold.
6050
6051          if Nkind (N) = N_Op_Eq
6052            or else Comes_From_Source (Entity (N))
6053            or else Ekind (Entity (N)) = E_Operator
6054            or else Is_Intrinsic_Subprogram
6055              (Corresponding_Equality (Entity (N)))
6056          then
6057             Eval_Relational_Op (N);
6058
6059          elsif Nkind (N) = N_Op_Ne
6060            and then Is_Abstract_Subprogram (Entity (N))
6061          then
6062             Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
6063          end if;
6064
6065          --  Ada 2005:  If one operand is an anonymous access type, convert
6066          --  the other operand to it, to ensure that the underlying types
6067          --  match in the back-end. Same for access_to_subprogram, and the
6068          --  conversion verifies that the types are subtype conformant.
6069
6070          --  We apply the same conversion in the case one of the operands is
6071          --  a private subtype of the type of the other.
6072
6073          --  Why the Expander_Active test here ???
6074
6075          if Expander_Active
6076            and then
6077              (Ekind (T) =  E_Anonymous_Access_Type
6078                or else Ekind (T) = E_Anonymous_Access_Subprogram_Type
6079                or else Is_Private_Type (T))
6080          then
6081             if Etype (L) /= T then
6082                Rewrite (L,
6083                  Make_Unchecked_Type_Conversion (Sloc (L),
6084                    Subtype_Mark => New_Occurrence_Of (T, Sloc (L)),
6085                    Expression   => Relocate_Node (L)));
6086                Analyze_And_Resolve (L, T);
6087             end if;
6088
6089             if (Etype (R)) /= T then
6090                Rewrite (R,
6091                   Make_Unchecked_Type_Conversion (Sloc (R),
6092                     Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)),
6093                     Expression   => Relocate_Node (R)));
6094                Analyze_And_Resolve (R, T);
6095             end if;
6096          end if;
6097       end if;
6098    end Resolve_Equality_Op;
6099
6100    ----------------------------------
6101    -- Resolve_Explicit_Dereference --
6102    ----------------------------------
6103
6104    procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
6105       Loc   : constant Source_Ptr := Sloc (N);
6106       New_N : Node_Id;
6107       P     : constant Node_Id := Prefix (N);
6108       I     : Interp_Index;
6109       It    : Interp;
6110
6111    begin
6112       Check_Fully_Declared_Prefix (Typ, P);
6113
6114       if Is_Overloaded (P) then
6115
6116          --  Use the context type to select the prefix that has the correct
6117          --  designated type.
6118
6119          Get_First_Interp (P, I, It);
6120          while Present (It.Typ) loop
6121             exit when Is_Access_Type (It.Typ)
6122               and then Covers (Typ, Designated_Type (It.Typ));
6123             Get_Next_Interp (I, It);
6124          end loop;
6125
6126          if Present (It.Typ) then
6127             Resolve (P, It.Typ);
6128          else
6129             --  If no interpretation covers the designated type of the prefix,
6130             --  this is the pathological case where not all implementations of
6131             --  the prefix allow the interpretation of the node as a call. Now
6132             --  that the expected type is known, Remove other interpretations
6133             --  from prefix, rewrite it as a call, and resolve again, so that
6134             --  the proper call node is generated.
6135
6136             Get_First_Interp (P, I, It);
6137             while Present (It.Typ) loop
6138                if Ekind (It.Typ) /= E_Access_Subprogram_Type then
6139                   Remove_Interp (I);
6140                end if;
6141
6142                Get_Next_Interp (I, It);
6143             end loop;
6144
6145             New_N :=
6146               Make_Function_Call (Loc,
6147                 Name =>
6148                   Make_Explicit_Dereference (Loc,
6149                     Prefix => P),
6150                 Parameter_Associations => New_List);
6151
6152             Save_Interps (N, New_N);
6153             Rewrite (N, New_N);
6154             Analyze_And_Resolve (N, Typ);
6155             return;
6156          end if;
6157
6158          Set_Etype (N, Designated_Type (It.Typ));
6159
6160       else
6161          Resolve (P);
6162       end if;
6163
6164       if Is_Access_Type (Etype (P)) then
6165          Apply_Access_Check (N);
6166       end if;
6167
6168       --  If the designated type is a packed unconstrained array type, and the
6169       --  explicit dereference is not in the context of an attribute reference,
6170       --  then we must compute and set the actual subtype, since it is needed
6171       --  by Gigi. The reason we exclude the attribute case is that this is
6172       --  handled fine by Gigi, and in fact we use such attributes to build the
6173       --  actual subtype. We also exclude generated code (which builds actual
6174       --  subtypes directly if they are needed).
6175
6176       if Is_Array_Type (Etype (N))
6177         and then Is_Packed (Etype (N))
6178         and then not Is_Constrained (Etype (N))
6179         and then Nkind (Parent (N)) /= N_Attribute_Reference
6180         and then Comes_From_Source (N)
6181       then
6182          Set_Etype (N, Get_Actual_Subtype (N));
6183       end if;
6184
6185       --  Note: there is no Eval processing required for an explicit deference,
6186       --  because the type is known to be an allocators, and allocator
6187       --  expressions can never be static.
6188
6189    end Resolve_Explicit_Dereference;
6190
6191    -------------------------------
6192    -- Resolve_Indexed_Component --
6193    -------------------------------
6194
6195    procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
6196       Name       : constant Node_Id := Prefix  (N);
6197       Expr       : Node_Id;
6198       Array_Type : Entity_Id := Empty; -- to prevent junk warning
6199       Index      : Node_Id;
6200
6201    begin
6202       if Is_Overloaded (Name) then
6203
6204          --  Use the context type to select the prefix that yields the correct
6205          --  component type.
6206
6207          declare
6208             I     : Interp_Index;
6209             It    : Interp;
6210             I1    : Interp_Index := 0;
6211             P     : constant Node_Id := Prefix (N);
6212             Found : Boolean := False;
6213
6214          begin
6215             Get_First_Interp (P, I, It);
6216             while Present (It.Typ) loop
6217                if (Is_Array_Type (It.Typ)
6218                      and then Covers (Typ, Component_Type (It.Typ)))
6219                  or else (Is_Access_Type (It.Typ)
6220                             and then Is_Array_Type (Designated_Type (It.Typ))
6221                             and then Covers
6222                               (Typ, Component_Type (Designated_Type (It.Typ))))
6223                then
6224                   if Found then
6225                      It := Disambiguate (P, I1, I, Any_Type);
6226
6227                      if It = No_Interp then
6228                         Error_Msg_N ("ambiguous prefix for indexing",  N);
6229                         Set_Etype (N, Typ);
6230                         return;
6231
6232                      else
6233                         Found := True;
6234                         Array_Type := It.Typ;
6235                         I1 := I;
6236                      end if;
6237
6238                   else
6239                      Found := True;
6240                      Array_Type := It.Typ;
6241                      I1 := I;
6242                   end if;
6243                end if;
6244
6245                Get_Next_Interp (I, It);
6246             end loop;
6247          end;
6248
6249       else
6250          Array_Type := Etype (Name);
6251       end if;
6252
6253       Resolve (Name, Array_Type);
6254       Array_Type := Get_Actual_Subtype_If_Available (Name);
6255
6256       --  If prefix is access type, dereference to get real array type.
6257       --  Note: we do not apply an access check because the expander always
6258       --  introduces an explicit dereference, and the check will happen there.
6259
6260       if Is_Access_Type (Array_Type) then
6261          Array_Type := Designated_Type (Array_Type);
6262       end if;
6263
6264       --  If name was overloaded, set component type correctly now
6265       --  If a misplaced call to an entry family (which has no index types)
6266       --  return. Error will be diagnosed from calling context.
6267
6268       if Is_Array_Type (Array_Type) then
6269          Set_Etype (N, Component_Type (Array_Type));
6270       else
6271          return;
6272       end if;
6273
6274       Index := First_Index (Array_Type);
6275       Expr  := First (Expressions (N));
6276
6277       --  The prefix may have resolved to a string literal, in which case its
6278       --  etype has a special representation. This is only possible currently
6279       --  if the prefix is a static concatenation, written in functional
6280       --  notation.
6281
6282       if Ekind (Array_Type) = E_String_Literal_Subtype then
6283          Resolve (Expr, Standard_Positive);
6284
6285       else
6286          while Present (Index) and Present (Expr) loop
6287             Resolve (Expr, Etype (Index));
6288             Check_Unset_Reference (Expr);
6289
6290             if Is_Scalar_Type (Etype (Expr)) then
6291                Apply_Scalar_Range_Check (Expr, Etype (Index));
6292             else
6293                Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
6294             end if;
6295
6296             Next_Index (Index);
6297             Next (Expr);
6298          end loop;
6299       end if;
6300
6301       --  Do not generate the warning on suspicious index if we are analyzing
6302       --  package Ada.Tags; otherwise we will report the warning with the
6303       --  Prims_Ptr field of the dispatch table.
6304
6305       if Scope (Etype (Prefix (N))) = Standard_Standard
6306         or else not
6307           Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))),
6308                   Ada_Tags)
6309       then
6310          Warn_On_Suspicious_Index (Name, First (Expressions (N)));
6311          Eval_Indexed_Component (N);
6312       end if;
6313    end Resolve_Indexed_Component;
6314
6315    -----------------------------
6316    -- Resolve_Integer_Literal --
6317    -----------------------------
6318
6319    procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
6320    begin
6321       Set_Etype (N, Typ);
6322       Eval_Integer_Literal (N);
6323    end Resolve_Integer_Literal;
6324
6325    --------------------------------
6326    -- Resolve_Intrinsic_Operator --
6327    --------------------------------
6328
6329    procedure Resolve_Intrinsic_Operator  (N : Node_Id; Typ : Entity_Id) is
6330       Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
6331       Op   : Entity_Id;
6332       Arg1 : Node_Id;
6333       Arg2 : Node_Id;
6334
6335    begin
6336       Op := Entity (N);
6337       while Scope (Op) /= Standard_Standard loop
6338          Op := Homonym (Op);
6339          pragma Assert (Present (Op));
6340       end loop;
6341
6342       Set_Entity (N, Op);
6343       Set_Is_Overloaded (N, False);
6344
6345       --  If the operand type is private, rewrite with suitable conversions on
6346       --  the operands and the result, to expose the proper underlying numeric
6347       --  type.
6348
6349       if Is_Private_Type (Typ) then
6350          Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd  (N));
6351
6352          if Nkind (N) = N_Op_Expon then
6353             Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
6354          else
6355             Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
6356          end if;
6357
6358          Save_Interps (Left_Opnd (N),  Expression (Arg1));
6359          Save_Interps (Right_Opnd (N), Expression (Arg2));
6360
6361          Set_Left_Opnd  (N, Arg1);
6362          Set_Right_Opnd (N, Arg2);
6363
6364          Set_Etype (N, Btyp);
6365          Rewrite (N, Unchecked_Convert_To (Typ, N));
6366          Resolve (N, Typ);
6367
6368       elsif Typ /= Etype (Left_Opnd (N))
6369         or else Typ /= Etype (Right_Opnd (N))
6370       then
6371          --  Add explicit conversion where needed, and save interpretations
6372          --  in case operands are overloaded.
6373
6374          Arg1 := Convert_To (Typ, Left_Opnd  (N));
6375          Arg2 := Convert_To (Typ, Right_Opnd (N));
6376
6377          if Nkind (Arg1) = N_Type_Conversion then
6378             Save_Interps (Left_Opnd (N), Expression (Arg1));
6379          else
6380             Save_Interps (Left_Opnd (N), Arg1);
6381          end if;
6382
6383          if Nkind (Arg2) = N_Type_Conversion then
6384             Save_Interps (Right_Opnd (N), Expression (Arg2));
6385          else
6386             Save_Interps (Right_Opnd (N), Arg2);
6387          end if;
6388
6389          Rewrite (Left_Opnd  (N), Arg1);
6390          Rewrite (Right_Opnd (N), Arg2);
6391          Analyze (Arg1);
6392          Analyze (Arg2);
6393          Resolve_Arithmetic_Op (N, Typ);
6394
6395       else
6396          Resolve_Arithmetic_Op (N, Typ);
6397       end if;
6398    end Resolve_Intrinsic_Operator;
6399
6400    --------------------------------------
6401    -- Resolve_Intrinsic_Unary_Operator --
6402    --------------------------------------
6403
6404    procedure Resolve_Intrinsic_Unary_Operator
6405      (N   : Node_Id;
6406       Typ : Entity_Id)
6407    is
6408       Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
6409       Op   : Entity_Id;
6410       Arg2 : Node_Id;
6411
6412    begin
6413       Op := Entity (N);
6414       while Scope (Op) /= Standard_Standard loop
6415          Op := Homonym (Op);
6416          pragma Assert (Present (Op));
6417       end loop;
6418
6419       Set_Entity (N, Op);
6420
6421       if Is_Private_Type (Typ) then
6422          Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
6423          Save_Interps (Right_Opnd (N), Expression (Arg2));
6424
6425          Set_Right_Opnd (N, Arg2);
6426
6427          Set_Etype (N, Btyp);
6428          Rewrite (N, Unchecked_Convert_To (Typ, N));
6429          Resolve (N, Typ);
6430
6431       else
6432          Resolve_Unary_Op (N, Typ);
6433       end if;
6434    end Resolve_Intrinsic_Unary_Operator;
6435
6436    ------------------------
6437    -- Resolve_Logical_Op --
6438    ------------------------
6439
6440    procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
6441       B_Typ : Entity_Id;
6442       N_Opr : constant Node_Kind := Nkind (N);
6443
6444    begin
6445       --  Predefined operations on scalar types yield the base type. On the
6446       --  other hand, logical operations on arrays yield the type of the
6447       --  arguments (and the context).
6448
6449       if Is_Array_Type (Typ) then
6450          B_Typ := Typ;
6451       else
6452          B_Typ := Base_Type (Typ);
6453       end if;
6454
6455       --  The following test is required because the operands of the operation
6456       --  may be literals, in which case the resulting type appears to be
6457       --  compatible with a signed integer type, when in fact it is compatible
6458       --  only with modular types. If the context itself is universal, the
6459       --  operation is illegal.
6460
6461       if not Valid_Boolean_Arg (Typ) then
6462          Error_Msg_N ("invalid context for logical operation", N);
6463          Set_Etype (N, Any_Type);
6464          return;
6465
6466       elsif Typ = Any_Modular then
6467          Error_Msg_N
6468            ("no modular type available in this context", N);
6469          Set_Etype (N, Any_Type);
6470          return;
6471       elsif Is_Modular_Integer_Type (Typ)
6472         and then Etype (Left_Opnd (N)) = Universal_Integer
6473         and then Etype (Right_Opnd (N)) = Universal_Integer
6474       then
6475          Check_For_Visible_Operator (N, B_Typ);
6476       end if;
6477
6478       Resolve (Left_Opnd (N), B_Typ);
6479       Resolve (Right_Opnd (N), B_Typ);
6480
6481       Check_Unset_Reference (Left_Opnd  (N));
6482       Check_Unset_Reference (Right_Opnd (N));
6483
6484       Set_Etype (N, B_Typ);
6485       Generate_Operator_Reference (N, B_Typ);
6486       Eval_Logical_Op (N);
6487
6488       --  Check for violation of restriction No_Direct_Boolean_Operators
6489       --  if the operator was not eliminated by the Eval_Logical_Op call.
6490
6491       if Nkind (N) = N_Opr
6492         and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
6493       then
6494          Check_Restriction (No_Direct_Boolean_Operators, N);
6495       end if;
6496    end Resolve_Logical_Op;
6497
6498    ---------------------------
6499    -- Resolve_Membership_Op --
6500    ---------------------------
6501
6502    --  The context can only be a boolean type, and does not determine
6503    --  the arguments. Arguments should be unambiguous, but the preference
6504    --  rule for universal types applies.
6505
6506    procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
6507       pragma Warnings (Off, Typ);
6508
6509       L : constant Node_Id   := Left_Opnd (N);
6510       R : constant Node_Id   := Right_Opnd (N);
6511       T : Entity_Id;
6512
6513    begin
6514       if L = Error or else R = Error then
6515          return;
6516       end if;
6517
6518       if not Is_Overloaded (R)
6519         and then
6520           (Etype (R) = Universal_Integer or else
6521            Etype (R) = Universal_Real)
6522         and then Is_Overloaded (L)
6523       then
6524          T := Etype (R);
6525
6526       --  Ada 2005 (AI-251): Give support to the following case:
6527
6528       --      type I is interface;
6529       --      type T is tagged ...
6530
6531       --      function Test (O : I'Class) is
6532       --      begin
6533       --         return O in T'Class.
6534       --      end Test;
6535
6536       --  In this case we have nothing else to do; the membership test will be
6537       --  done at run-time.
6538
6539       elsif Ada_Version >= Ada_05
6540         and then Is_Class_Wide_Type (Etype (L))
6541         and then Is_Interface (Etype (L))
6542         and then Is_Class_Wide_Type (Etype (R))
6543         and then not Is_Interface (Etype (R))
6544       then
6545          return;
6546
6547       else
6548          T := Intersect_Types (L, R);
6549       end if;
6550
6551       Resolve (L, T);
6552       Check_Unset_Reference (L);
6553
6554       if Nkind (R) = N_Range
6555         and then not Is_Scalar_Type (T)
6556       then
6557          Error_Msg_N ("scalar type required for range", R);
6558       end if;
6559
6560       if Is_Entity_Name (R) then
6561          Freeze_Expression (R);
6562       else
6563          Resolve (R, T);
6564          Check_Unset_Reference (R);
6565       end if;
6566
6567       Eval_Membership_Op (N);
6568    end Resolve_Membership_Op;
6569
6570    ------------------
6571    -- Resolve_Null --
6572    ------------------
6573
6574    procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
6575    begin
6576       --  Handle restriction against anonymous null access values This
6577       --  restriction can be turned off using -gnatdj.
6578
6579       --  Ada 2005 (AI-231): Remove restriction
6580
6581       if Ada_Version < Ada_05
6582         and then not Debug_Flag_J
6583         and then Ekind (Typ) = E_Anonymous_Access_Type
6584         and then Comes_From_Source (N)
6585       then
6586          --  In the common case of a call which uses an explicitly null
6587          --  value for an access parameter, give specialized error message.
6588
6589          if Nkind_In (Parent (N), N_Procedure_Call_Statement,
6590                                   N_Function_Call)
6591          then
6592             Error_Msg_N
6593               ("null is not allowed as argument for an access parameter", N);
6594
6595          --  Standard message for all other cases (are there any?)
6596
6597          else
6598             Error_Msg_N
6599               ("null cannot be of an anonymous access type", N);
6600          end if;
6601       end if;
6602
6603       --  In a distributed context, null for a remote access to subprogram
6604       --  may need to be replaced with a special record aggregate. In this
6605       --  case, return after having done the transformation.
6606
6607       if (Ekind (Typ) = E_Record_Type
6608            or else Is_Remote_Access_To_Subprogram_Type (Typ))
6609         and then Remote_AST_Null_Value (N, Typ)
6610       then
6611          return;
6612       end if;
6613
6614       --  The null literal takes its type from the context
6615
6616       Set_Etype (N, Typ);
6617    end Resolve_Null;
6618
6619    -----------------------
6620    -- Resolve_Op_Concat --
6621    -----------------------
6622
6623    procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
6624
6625       --  We wish to avoid deep recursion, because concatenations are often
6626       --  deeply nested, as in A&B&...&Z. Therefore, we walk down the left
6627       --  operands nonrecursively until we find something that is not a simple
6628       --  concatenation (A in this case). We resolve that, and then walk back
6629       --  up the tree following Parent pointers, calling Resolve_Op_Concat_Rest
6630       --  to do the rest of the work at each level. The Parent pointers allow
6631       --  us to avoid recursion, and thus avoid running out of memory. See also
6632       --  Sem_Ch4.Analyze_Concatenation, where a similar hack is used.
6633
6634       NN  : Node_Id := N;
6635       Op1 : Node_Id;
6636
6637    begin
6638       --  The following code is equivalent to:
6639
6640       --    Resolve_Op_Concat_First (NN, Typ);
6641       --    Resolve_Op_Concat_Arg (N, ...);
6642       --    Resolve_Op_Concat_Rest (N, Typ);
6643
6644       --  where the Resolve_Op_Concat_Arg call recurses back here if the left
6645       --  operand is a concatenation.
6646
6647       --  Walk down left operands
6648
6649       loop
6650          Resolve_Op_Concat_First (NN, Typ);
6651          Op1 := Left_Opnd (NN);
6652          exit when not (Nkind (Op1) = N_Op_Concat
6653                          and then not Is_Array_Type (Component_Type (Typ))
6654                          and then Entity (Op1) = Entity (NN));
6655          NN := Op1;
6656       end loop;
6657
6658       --  Now (given the above example) NN is A&B and Op1 is A
6659
6660       --  First resolve Op1 ...
6661
6662       Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd  (NN));
6663
6664       --  ... then walk NN back up until we reach N (where we started), calling
6665       --  Resolve_Op_Concat_Rest along the way.
6666
6667       loop
6668          Resolve_Op_Concat_Rest (NN, Typ);
6669          exit when NN = N;
6670          NN := Parent (NN);
6671       end loop;
6672    end Resolve_Op_Concat;
6673
6674    ---------------------------
6675    -- Resolve_Op_Concat_Arg --
6676    ---------------------------
6677
6678    procedure Resolve_Op_Concat_Arg
6679      (N       : Node_Id;
6680       Arg     : Node_Id;
6681       Typ     : Entity_Id;
6682       Is_Comp : Boolean)
6683    is
6684       Btyp : constant Entity_Id := Base_Type (Typ);
6685
6686    begin
6687       if In_Instance then
6688          if Is_Comp
6689            or else (not Is_Overloaded (Arg)
6690                      and then Etype (Arg) /= Any_Composite
6691                      and then Covers (Component_Type (Typ), Etype (Arg)))
6692          then
6693             Resolve (Arg, Component_Type (Typ));
6694          else
6695             Resolve (Arg, Btyp);
6696          end if;
6697
6698       elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
6699          if Nkind (Arg) = N_Aggregate
6700            and then Is_Composite_Type (Component_Type (Typ))
6701          then
6702             if Is_Private_Type (Component_Type (Typ)) then
6703                Resolve (Arg, Btyp);
6704             else
6705                Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
6706                Set_Etype (Arg, Any_Type);
6707             end if;
6708
6709          else
6710             if Is_Overloaded (Arg)
6711               and then Has_Compatible_Type (Arg, Typ)
6712               and then Etype (Arg) /= Any_Type
6713             then
6714                declare
6715                   I    : Interp_Index;
6716                   It   : Interp;
6717                   Func : Entity_Id;
6718
6719                begin
6720                   Get_First_Interp (Arg, I, It);
6721                   Func := It.Nam;
6722                   Get_Next_Interp (I, It);
6723
6724                   --  Special-case the error message when the overloading is
6725                   --  caused by a function that yields an array and can be
6726                   --  called without parameters.
6727
6728                   if It.Nam = Func then
6729                      Error_Msg_Sloc := Sloc (Func);
6730                      Error_Msg_N ("ambiguous call to function#", Arg);
6731                      Error_Msg_NE
6732                        ("\\interpretation as call yields&", Arg, Typ);
6733                      Error_Msg_NE
6734                        ("\\interpretation as indexing of call yields&",
6735                          Arg, Component_Type (Typ));
6736
6737                   else
6738                      Error_Msg_N
6739                        ("ambiguous operand for concatenation!", Arg);
6740                      Get_First_Interp (Arg, I, It);
6741                      while Present (It.Nam) loop
6742                         Error_Msg_Sloc := Sloc (It.Nam);
6743
6744                         if Base_Type (It.Typ) = Base_Type (Typ)
6745                           or else Base_Type (It.Typ) =
6746                             Base_Type (Component_Type (Typ))
6747                         then
6748                            Error_Msg_N ("\\possible interpretation#", Arg);
6749                         end if;
6750
6751                         Get_Next_Interp (I, It);
6752                      end loop;
6753                   end if;
6754                end;
6755             end if;
6756
6757             Resolve (Arg, Component_Type (Typ));
6758
6759             if Nkind (Arg) = N_String_Literal then
6760                Set_Etype (Arg, Component_Type (Typ));
6761             end if;
6762
6763             if Arg = Left_Opnd (N) then
6764                Set_Is_Component_Left_Opnd (N);
6765             else
6766                Set_Is_Component_Right_Opnd (N);
6767             end if;
6768          end if;
6769
6770       else
6771          Resolve (Arg, Btyp);
6772       end if;
6773
6774       Check_Unset_Reference (Arg);
6775    end Resolve_Op_Concat_Arg;
6776
6777    -----------------------------
6778    -- Resolve_Op_Concat_First --
6779    -----------------------------
6780
6781    procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is
6782       Btyp : constant Entity_Id := Base_Type (Typ);
6783       Op1  : constant Node_Id := Left_Opnd (N);
6784       Op2  : constant Node_Id := Right_Opnd (N);
6785
6786    begin
6787       --  The parser folds an enormous sequence of concatenations of string
6788       --  literals into "" & "...", where the Is_Folded_In_Parser flag is set
6789       --  in the right. If the expression resolves to a predefined "&"
6790       --  operator, all is well. Otherwise, the parser's folding is wrong, so
6791       --  we give an error. See P_Simple_Expression in Par.Ch4.
6792
6793       if Nkind (Op2) = N_String_Literal
6794         and then Is_Folded_In_Parser (Op2)
6795         and then Ekind (Entity (N)) = E_Function
6796       then
6797          pragma Assert (Nkind (Op1) = N_String_Literal  --  should be ""
6798                and then String_Length (Strval (Op1)) = 0);
6799          Error_Msg_N ("too many user-defined concatenations", N);
6800          return;
6801       end if;
6802
6803       Set_Etype (N, Btyp);
6804
6805       if Is_Limited_Composite (Btyp) then
6806          Error_Msg_N ("concatenation not available for limited array", N);
6807          Explain_Limited_Type (Btyp, N);
6808       end if;
6809    end Resolve_Op_Concat_First;
6810
6811    ----------------------------
6812    -- Resolve_Op_Concat_Rest --
6813    ----------------------------
6814
6815    procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is
6816       Op1  : constant Node_Id := Left_Opnd (N);
6817       Op2  : constant Node_Id := Right_Opnd (N);
6818
6819    begin
6820       Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd  (N));
6821
6822       Generate_Operator_Reference (N, Typ);
6823
6824       if Is_String_Type (Typ) then
6825          Eval_Concatenation (N);
6826       end if;
6827
6828       --  If this is not a static concatenation, but the result is a
6829       --  string type (and not an array of strings) ensure that static
6830       --  string operands have their subtypes properly constructed.
6831
6832       if Nkind (N) /= N_String_Literal
6833         and then Is_Character_Type (Component_Type (Typ))
6834       then
6835          Set_String_Literal_Subtype (Op1, Typ);
6836          Set_String_Literal_Subtype (Op2, Typ);
6837       end if;
6838    end Resolve_Op_Concat_Rest;
6839
6840    ----------------------
6841    -- Resolve_Op_Expon --
6842    ----------------------
6843
6844    procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
6845       B_Typ : constant Entity_Id := Base_Type (Typ);
6846
6847    begin
6848       --  Catch attempts to do fixed-point exponentiation with universal
6849       --  operands, which is a case where the illegality is not caught during
6850       --  normal operator analysis.
6851
6852       if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
6853          Error_Msg_N ("exponentiation not available for fixed point", N);
6854          return;
6855       end if;
6856
6857       if Comes_From_Source (N)
6858         and then Ekind (Entity (N)) = E_Function
6859         and then Is_Imported (Entity (N))
6860         and then Is_Intrinsic_Subprogram (Entity (N))
6861       then
6862          Resolve_Intrinsic_Operator (N, Typ);
6863          return;
6864       end if;
6865
6866       if Etype (Left_Opnd (N)) = Universal_Integer
6867         or else Etype (Left_Opnd (N)) = Universal_Real
6868       then
6869          Check_For_Visible_Operator (N, B_Typ);
6870       end if;
6871
6872       --  We do the resolution using the base type, because intermediate values
6873       --  in expressions always are of the base type, not a subtype of it.
6874
6875       Resolve (Left_Opnd (N), B_Typ);
6876       Resolve (Right_Opnd (N), Standard_Integer);
6877
6878       Check_Unset_Reference (Left_Opnd  (N));
6879       Check_Unset_Reference (Right_Opnd (N));
6880
6881       Set_Etype (N, B_Typ);
6882       Generate_Operator_Reference (N, B_Typ);
6883       Eval_Op_Expon (N);
6884
6885       --  Set overflow checking bit. Much cleverer code needed here eventually
6886       --  and perhaps the Resolve routines should be separated for the various
6887       --  arithmetic operations, since they will need different processing. ???
6888
6889       if Nkind (N) in N_Op then
6890          if not Overflow_Checks_Suppressed (Etype (N)) then
6891             Enable_Overflow_Check (N);
6892          end if;
6893       end if;
6894    end Resolve_Op_Expon;
6895
6896    --------------------
6897    -- Resolve_Op_Not --
6898    --------------------
6899
6900    procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
6901       B_Typ : Entity_Id;
6902
6903       function Parent_Is_Boolean return Boolean;
6904       --  This function determines if the parent node is a boolean operator
6905       --  or operation (comparison op, membership test, or short circuit form)
6906       --  and the not in question is the left operand of this operation.
6907       --  Note that if the not is in parens, then false is returned.
6908
6909       -----------------------
6910       -- Parent_Is_Boolean --
6911       -----------------------
6912
6913       function Parent_Is_Boolean return Boolean is
6914       begin
6915          if Paren_Count (N) /= 0 then
6916             return False;
6917
6918          else
6919             case Nkind (Parent (N)) is
6920                when N_Op_And   |
6921                     N_Op_Eq    |
6922                     N_Op_Ge    |
6923                     N_Op_Gt    |
6924                     N_Op_Le    |
6925                     N_Op_Lt    |
6926                     N_Op_Ne    |
6927                     N_Op_Or    |
6928                     N_Op_Xor   |
6929                     N_In       |
6930                     N_Not_In   |
6931                     N_And_Then |
6932                     N_Or_Else  =>
6933
6934                   return Left_Opnd (Parent (N)) = N;
6935
6936                when others =>
6937                   return False;
6938             end case;
6939          end if;
6940       end Parent_Is_Boolean;
6941
6942    --  Start of processing for Resolve_Op_Not
6943
6944    begin
6945       --  Predefined operations on scalar types yield the base type. On the
6946       --  other hand, logical operations on arrays yield the type of the
6947       --  arguments (and the context).
6948
6949       if Is_Array_Type (Typ) then
6950          B_Typ := Typ;
6951       else
6952          B_Typ := Base_Type (Typ);
6953       end if;
6954
6955       --  Straightforward case of incorrect arguments
6956
6957       if not Valid_Boolean_Arg (Typ) then
6958          Error_Msg_N ("invalid operand type for operator&", N);
6959          Set_Etype (N, Any_Type);
6960          return;
6961
6962       --  Special case of probable missing parens
6963
6964       elsif Typ = Universal_Integer or else Typ = Any_Modular then
6965          if Parent_Is_Boolean then
6966             Error_Msg_N
6967               ("operand of not must be enclosed in parentheses",
6968                Right_Opnd (N));
6969          else
6970             Error_Msg_N
6971               ("no modular type available in this context", N);
6972          end if;
6973
6974          Set_Etype (N, Any_Type);
6975          return;
6976
6977       --  OK resolution of not
6978
6979       else
6980          --  Warn if non-boolean types involved. This is a case like not a < b
6981          --  where a and b are modular, where we will get (not a) < b and most
6982          --  likely not (a < b) was intended.
6983
6984          if Warn_On_Questionable_Missing_Parens
6985            and then not Is_Boolean_Type (Typ)
6986            and then Parent_Is_Boolean
6987          then
6988             Error_Msg_N ("?not expression should be parenthesized here!", N);
6989          end if;
6990
6991          --  Warn on double negation if checking redundant constructs
6992
6993          if Warn_On_Redundant_Constructs
6994            and then Comes_From_Source (N)
6995            and then Comes_From_Source (Right_Opnd (N))
6996            and then Root_Type (Typ) = Standard_Boolean
6997            and then Nkind (Right_Opnd (N)) = N_Op_Not
6998          then
6999             Error_Msg_N ("redundant double negation?", N);
7000          end if;
7001
7002          --  Complete resolution and evaluation of NOT
7003
7004          Resolve (Right_Opnd (N), B_Typ);
7005          Check_Unset_Reference (Right_Opnd (N));
7006          Set_Etype (N, B_Typ);
7007          Generate_Operator_Reference (N, B_Typ);
7008          Eval_Op_Not (N);
7009       end if;
7010    end Resolve_Op_Not;
7011
7012    -----------------------------
7013    -- Resolve_Operator_Symbol --
7014    -----------------------------
7015
7016    --  Nothing to be done, all resolved already
7017
7018    procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
7019       pragma Warnings (Off, N);
7020       pragma Warnings (Off, Typ);
7021
7022    begin
7023       null;
7024    end Resolve_Operator_Symbol;
7025
7026    ----------------------------------
7027    -- Resolve_Qualified_Expression --
7028    ----------------------------------
7029
7030    procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
7031       pragma Warnings (Off, Typ);
7032
7033       Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
7034       Expr       : constant Node_Id   := Expression (N);
7035
7036    begin
7037       Resolve (Expr, Target_Typ);
7038
7039       --  A qualified expression requires an exact match of the type,
7040       --  class-wide matching is not allowed. However, if the qualifying
7041       --  type is specific and the expression has a class-wide type, it
7042       --  may still be okay, since it can be the result of the expansion
7043       --  of a call to a dispatching function, so we also have to check
7044       --  class-wideness of the type of the expression's original node.
7045
7046       if (Is_Class_Wide_Type (Target_Typ)
7047            or else
7048              (Is_Class_Wide_Type (Etype (Expr))
7049                and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
7050         and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
7051       then
7052          Wrong_Type (Expr, Target_Typ);
7053       end if;
7054
7055       --  If the target type is unconstrained, then we reset the type of
7056       --  the result from the type of the expression. For other cases, the
7057       --  actual subtype of the expression is the target type.
7058
7059       if Is_Composite_Type (Target_Typ)
7060         and then not Is_Constrained (Target_Typ)
7061       then
7062          Set_Etype (N, Etype (Expr));
7063       end if;
7064
7065       Eval_Qualified_Expression (N);
7066    end Resolve_Qualified_Expression;
7067
7068    -------------------
7069    -- Resolve_Range --
7070    -------------------
7071
7072    procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
7073       L : constant Node_Id := Low_Bound (N);
7074       H : constant Node_Id := High_Bound (N);
7075
7076    begin
7077       Set_Etype (N, Typ);
7078       Resolve (L, Typ);
7079       Resolve (H, Typ);
7080
7081       Check_Unset_Reference (L);
7082       Check_Unset_Reference (H);
7083
7084       --  We have to check the bounds for being within the base range as
7085       --  required for a non-static context. Normally this is automatic and
7086       --  done as part of evaluating expressions, but the N_Range node is an
7087       --  exception, since in GNAT we consider this node to be a subexpression,
7088       --  even though in Ada it is not. The circuit in Sem_Eval could check for
7089       --  this, but that would put the test on the main evaluation path for
7090       --  expressions.
7091
7092       Check_Non_Static_Context (L);
7093       Check_Non_Static_Context (H);
7094
7095       --  Check for an ambiguous range over character literals. This will
7096       --  happen with a membership test involving only literals.
7097
7098       if Typ = Any_Character then
7099          Ambiguous_Character (L);
7100          Set_Etype (N, Any_Type);
7101          return;
7102       end if;
7103
7104       --  If bounds are static, constant-fold them, so size computations
7105       --  are identical between front-end and back-end. Do not perform this
7106       --  transformation while analyzing generic units, as type information
7107       --  would then be lost when reanalyzing the constant node in the
7108       --  instance.
7109
7110       if Is_Discrete_Type (Typ) and then Expander_Active then
7111          if Is_OK_Static_Expression (L) then
7112             Fold_Uint  (L, Expr_Value (L), Is_Static_Expression (L));
7113          end if;
7114
7115          if Is_OK_Static_Expression (H) then
7116             Fold_Uint  (H, Expr_Value (H), Is_Static_Expression (H));
7117          end if;
7118       end if;
7119    end Resolve_Range;
7120
7121    --------------------------
7122    -- Resolve_Real_Literal --
7123    --------------------------
7124
7125    procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
7126       Actual_Typ : constant Entity_Id := Etype (N);
7127
7128    begin
7129       --  Special processing for fixed-point literals to make sure that the
7130       --  value is an exact multiple of small where this is required. We
7131       --  skip this for the universal real case, and also for generic types.
7132
7133       if Is_Fixed_Point_Type (Typ)
7134         and then Typ /= Universal_Fixed
7135         and then Typ /= Any_Fixed
7136         and then not Is_Generic_Type (Typ)
7137       then
7138          declare
7139             Val   : constant Ureal := Realval (N);
7140             Cintr : constant Ureal := Val / Small_Value (Typ);
7141             Cint  : constant Uint  := UR_Trunc (Cintr);
7142             Den   : constant Uint  := Norm_Den (Cintr);
7143             Stat  : Boolean;
7144
7145          begin
7146             --  Case of literal is not an exact multiple of the Small
7147
7148             if Den /= 1 then
7149
7150                --  For a source program literal for a decimal fixed-point
7151                --  type, this is statically illegal (RM 4.9(36)).
7152
7153                if Is_Decimal_Fixed_Point_Type (Typ)
7154                  and then Actual_Typ = Universal_Real
7155                  and then Comes_From_Source (N)
7156                then
7157                   Error_Msg_N ("value has extraneous low order digits", N);
7158                end if;
7159
7160                --  Generate a warning if literal from source
7161
7162                if Is_Static_Expression (N)
7163                  and then Warn_On_Bad_Fixed_Value
7164                then
7165                   Error_Msg_N
7166                     ("?static fixed-point value is not a multiple of Small!",
7167                      N);
7168                end if;
7169
7170                --  Replace literal by a value that is the exact representation
7171                --  of a value of the type, i.e. a multiple of the small value,
7172                --  by truncation, since Machine_Rounds is false for all GNAT
7173                --  fixed-point types (RM 4.9(38)).
7174
7175                Stat := Is_Static_Expression (N);
7176                Rewrite (N,
7177                  Make_Real_Literal (Sloc (N),
7178                    Realval => Small_Value (Typ) * Cint));
7179
7180                Set_Is_Static_Expression (N, Stat);
7181             end if;
7182
7183             --  In all cases, set the corresponding integer field
7184
7185             Set_Corresponding_Integer_Value (N, Cint);
7186          end;
7187       end if;
7188
7189       --  Now replace the actual type by the expected type as usual
7190
7191       Set_Etype (N, Typ);
7192       Eval_Real_Literal (N);
7193    end Resolve_Real_Literal;
7194
7195    -----------------------
7196    -- Resolve_Reference --
7197    -----------------------
7198
7199    procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
7200       P : constant Node_Id := Prefix (N);
7201
7202    begin
7203       --  Replace general access with specific type
7204
7205       if Ekind (Etype (N)) = E_Allocator_Type then
7206          Set_Etype (N, Base_Type (Typ));
7207       end if;
7208
7209       Resolve (P, Designated_Type (Etype (N)));
7210
7211       --  If we are taking the reference of a volatile entity, then treat
7212       --  it as a potential modification of this entity. This is much too
7213       --  conservative, but is necessary because remove side effects can
7214       --  result in transformations of normal assignments into reference
7215       --  sequences that otherwise fail to notice the modification.
7216
7217       if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
7218          Note_Possible_Modification (P, Sure => False);
7219       end if;
7220    end Resolve_Reference;
7221
7222    --------------------------------
7223    -- Resolve_Selected_Component --
7224    --------------------------------
7225
7226    procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
7227       Comp  : Entity_Id;
7228       Comp1 : Entity_Id        := Empty; -- prevent junk warning
7229       P     : constant Node_Id := Prefix  (N);
7230       S     : constant Node_Id := Selector_Name (N);
7231       T     : Entity_Id        := Etype (P);
7232       I     : Interp_Index;
7233       I1    : Interp_Index := 0; -- prevent junk warning
7234       It    : Interp;
7235       It1   : Interp;
7236       Found : Boolean;
7237
7238       function Init_Component return Boolean;
7239       --  Check whether this is the initialization of a component within an
7240       --  init proc (by assignment or call to another init proc). If true,
7241       --  there is no need for a discriminant check.
7242
7243       --------------------
7244       -- Init_Component --
7245       --------------------
7246
7247       function Init_Component return Boolean is
7248       begin
7249          return Inside_Init_Proc
7250            and then Nkind (Prefix (N)) = N_Identifier
7251            and then Chars (Prefix (N)) = Name_uInit
7252            and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
7253       end Init_Component;
7254
7255    --  Start of processing for Resolve_Selected_Component
7256
7257    begin
7258       if Is_Overloaded (P) then
7259
7260          --  Use the context type to select the prefix that has a selector
7261          --  of the correct name and type.
7262
7263          Found := False;
7264          Get_First_Interp (P, I, It);
7265
7266          Search : while Present (It.Typ) loop
7267             if Is_Access_Type (It.Typ) then
7268                T := Designated_Type (It.Typ);
7269             else
7270                T := It.Typ;
7271             end if;
7272
7273             if Is_Record_Type (T) then
7274
7275                --  The visible components of a class-wide type are those of
7276                --  the root type.
7277
7278                if Is_Class_Wide_Type (T) then
7279                   T := Etype (T);
7280                end if;
7281
7282                Comp := First_Entity (T);
7283                while Present (Comp) loop
7284                   if Chars (Comp) = Chars (S)
7285                     and then Covers (Etype (Comp), Typ)
7286                   then
7287                      if not Found then
7288                         Found := True;
7289                         I1  := I;
7290                         It1 := It;
7291                         Comp1 := Comp;
7292
7293                      else
7294                         It := Disambiguate (P, I1, I, Any_Type);
7295
7296                         if It = No_Interp then
7297                            Error_Msg_N
7298                              ("ambiguous prefix for selected component",  N);
7299                            Set_Etype (N, Typ);
7300                            return;
7301
7302                         else
7303                            It1 := It;
7304
7305                            --  There may be an implicit dereference. Retrieve
7306                            --  designated record type.
7307
7308                            if Is_Access_Type (It1.Typ) then
7309                               T := Designated_Type (It1.Typ);
7310                            else
7311                               T := It1.Typ;
7312                            end if;
7313
7314                            if Scope (Comp1) /= T then
7315
7316                               --  Resolution chooses the new interpretation.
7317                               --  Find the component with the right name.
7318
7319                               Comp1 := First_Entity (T);
7320                               while Present (Comp1)
7321                                 and then Chars (Comp1) /= Chars (S)
7322                               loop
7323                                  Comp1 := Next_Entity (Comp1);
7324                               end loop;
7325                            end if;
7326
7327                            exit Search;
7328                         end if;
7329                      end if;
7330                   end if;
7331
7332                   Comp := Next_Entity (Comp);
7333                end loop;
7334
7335             end if;
7336
7337             Get_Next_Interp (I, It);
7338          end loop Search;
7339
7340          Resolve (P, It1.Typ);
7341          Set_Etype (N, Typ);
7342          Set_Entity_With_Style_Check (S, Comp1);
7343
7344       else
7345          --  Resolve prefix with its type
7346
7347          Resolve (P, T);
7348       end if;
7349
7350       --  Generate cross-reference. We needed to wait until full overloading
7351       --  resolution was complete to do this, since otherwise we can't tell if
7352       --  we are an Lvalue of not.
7353
7354       if May_Be_Lvalue (N) then
7355          Generate_Reference (Entity (S), S, 'm');
7356       else
7357          Generate_Reference (Entity (S), S, 'r');
7358       end if;
7359
7360       --  If prefix is an access type, the node will be transformed into an
7361       --  explicit dereference during expansion. The type of the node is the
7362       --  designated type of that of the prefix.
7363
7364       if Is_Access_Type (Etype (P)) then
7365          T := Designated_Type (Etype (P));
7366          Check_Fully_Declared_Prefix (T, P);
7367       else
7368          T := Etype (P);
7369       end if;
7370
7371       if Has_Discriminants (T)
7372         and then (Ekind (Entity (S)) = E_Component
7373                    or else
7374                   Ekind (Entity (S)) = E_Discriminant)
7375         and then Present (Original_Record_Component (Entity (S)))
7376         and then Ekind (Original_Record_Component (Entity (S))) = E_Component
7377         and then Present (Discriminant_Checking_Func
7378                            (Original_Record_Component (Entity (S))))
7379         and then not Discriminant_Checks_Suppressed (T)
7380         and then not Init_Component
7381       then
7382          Set_Do_Discriminant_Check (N);
7383       end if;
7384
7385       if Ekind (Entity (S)) = E_Void then
7386          Error_Msg_N ("premature use of component", S);
7387       end if;
7388
7389       --  If the prefix is a record conversion, this may be a renamed
7390       --  discriminant whose bounds differ from those of the original
7391       --  one, so we must ensure that a range check is performed.
7392
7393       if Nkind (P) = N_Type_Conversion
7394         and then Ekind (Entity (S)) = E_Discriminant
7395         and then Is_Discrete_Type (Typ)
7396       then
7397          Set_Etype (N, Base_Type (Typ));
7398       end if;
7399
7400       --  Note: No Eval processing is required, because the prefix is of a
7401       --  record type, or protected type, and neither can possibly be static.
7402
7403    end Resolve_Selected_Component;
7404
7405    -------------------
7406    -- Resolve_Shift --
7407    -------------------
7408
7409    procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
7410       B_Typ : constant Entity_Id := Base_Type (Typ);
7411       L     : constant Node_Id   := Left_Opnd  (N);
7412       R     : constant Node_Id   := Right_Opnd (N);
7413
7414    begin
7415       --  We do the resolution using the base type, because intermediate values
7416       --  in expressions always are of the base type, not a subtype of it.
7417
7418       Resolve (L, B_Typ);
7419       Resolve (R, Standard_Natural);
7420
7421       Check_Unset_Reference (L);
7422       Check_Unset_Reference (R);
7423
7424       Set_Etype (N, B_Typ);
7425       Generate_Operator_Reference (N, B_Typ);
7426       Eval_Shift (N);
7427    end Resolve_Shift;
7428
7429    ---------------------------
7430    -- Resolve_Short_Circuit --
7431    ---------------------------
7432
7433    procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
7434       B_Typ : constant Entity_Id := Base_Type (Typ);
7435       L     : constant Node_Id   := Left_Opnd  (N);
7436       R     : constant Node_Id   := Right_Opnd (N);
7437
7438    begin
7439       Resolve (L, B_Typ);
7440       Resolve (R, B_Typ);
7441
7442       --  Check for issuing warning for always False assert/check, this happens
7443       --  when assertions are turned off, in which case the pragma Assert/Check
7444       --  was transformed into:
7445
7446       --     if False and then <condition> then ...
7447
7448       --  and we detect this pattern
7449
7450       if Warn_On_Assertion_Failure
7451         and then Is_Entity_Name (R)
7452         and then Entity (R) = Standard_False
7453         and then Nkind (Parent (N)) = N_If_Statement
7454         and then Nkind (N) = N_And_Then
7455         and then Is_Entity_Name (L)
7456         and then Entity (L) = Standard_False
7457       then
7458          declare
7459             Orig : constant Node_Id := Original_Node (Parent (N));
7460
7461          begin
7462             if Nkind (Orig) = N_Pragma
7463               and then Pragma_Name (Orig) = Name_Assert
7464             then
7465                --  Don't want to warn if original condition is explicit False
7466
7467                declare
7468                   Expr : constant Node_Id :=
7469                            Original_Node
7470                              (Expression
7471                                (First (Pragma_Argument_Associations (Orig))));
7472                begin
7473                   if Is_Entity_Name (Expr)
7474                     and then Entity (Expr) = Standard_False
7475                   then
7476                      null;
7477                   else
7478                      --  Issue warning. Note that we don't want to make this
7479                      --  an unconditional warning, because if the assert is
7480                      --  within deleted code we do not want the warning. But
7481                      --  we do not want the deletion of the IF/AND-THEN to
7482                      --  take this message with it. We achieve this by making
7483                      --  sure that the expanded code points to the Sloc of
7484                      --  the expression, not the original pragma.
7485
7486                      Error_Msg_N ("?assertion would fail at run-time", Orig);
7487                   end if;
7488                end;
7489
7490             --  Similar processing for Check pragma
7491
7492             elsif Nkind (Orig) = N_Pragma
7493               and then Pragma_Name (Orig) = Name_Check
7494             then
7495                --  Don't want to warn if original condition is explicit False
7496
7497                declare
7498                   Expr : constant Node_Id :=
7499                            Original_Node
7500                              (Expression
7501                                 (Next (First
7502                                   (Pragma_Argument_Associations (Orig)))));
7503                begin
7504                   if Is_Entity_Name (Expr)
7505                     and then Entity (Expr) = Standard_False
7506                   then
7507                      null;
7508                   else
7509                      Error_Msg_N ("?check would fail at run-time", Orig);
7510                   end if;
7511                end;
7512             end if;
7513          end;
7514       end if;
7515
7516       --  Continue with processing of short circuit
7517
7518       Check_Unset_Reference (L);
7519       Check_Unset_Reference (R);
7520
7521       Set_Etype (N, B_Typ);
7522       Eval_Short_Circuit (N);
7523    end Resolve_Short_Circuit;
7524
7525    -------------------
7526    -- Resolve_Slice --
7527    -------------------
7528
7529    procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
7530       Name       : constant Node_Id := Prefix (N);
7531       Drange     : constant Node_Id := Discrete_Range (N);
7532       Array_Type : Entity_Id        := Empty;
7533       Index      : Node_Id;
7534
7535    begin
7536       if Is_Overloaded (Name) then
7537
7538          --  Use the context type to select the prefix that yields the
7539          --  correct array type.
7540
7541          declare
7542             I      : Interp_Index;
7543             I1     : Interp_Index := 0;
7544             It     : Interp;
7545             P      : constant Node_Id := Prefix (N);
7546             Found  : Boolean := False;
7547
7548          begin
7549             Get_First_Interp (P, I,  It);
7550             while Present (It.Typ) loop
7551                if (Is_Array_Type (It.Typ)
7552                     and then Covers (Typ,  It.Typ))
7553                  or else (Is_Access_Type (It.Typ)
7554                            and then Is_Array_Type (Designated_Type (It.Typ))
7555                            and then Covers (Typ, Designated_Type (It.Typ)))
7556                then
7557                   if Found then
7558                      It := Disambiguate (P, I1, I, Any_Type);
7559
7560                      if It = No_Interp then
7561                         Error_Msg_N ("ambiguous prefix for slicing",  N);
7562                         Set_Etype (N, Typ);
7563                         return;
7564                      else
7565                         Found := True;
7566                         Array_Type := It.Typ;
7567                         I1 := I;
7568                      end if;
7569                   else
7570                      Found := True;
7571                      Array_Type := It.Typ;
7572                      I1 := I;
7573                   end if;
7574                end if;
7575
7576                Get_Next_Interp (I, It);
7577             end loop;
7578          end;
7579
7580       else
7581          Array_Type := Etype (Name);
7582       end if;
7583
7584       Resolve (Name, Array_Type);
7585
7586       if Is_Access_Type (Array_Type) then
7587          Apply_Access_Check (N);
7588          Array_Type := Designated_Type (Array_Type);
7589
7590          --  If the prefix is an access to an unconstrained array, we must use
7591          --  the actual subtype of the object to perform the index checks. The
7592          --  object denoted by the prefix is implicit in the node, so we build
7593          --  an explicit representation for it in order to compute the actual
7594          --  subtype.
7595
7596          if not Is_Constrained (Array_Type) then
7597             Remove_Side_Effects (Prefix (N));
7598
7599             declare
7600                Obj : constant Node_Id :=
7601                        Make_Explicit_Dereference (Sloc (N),
7602                          Prefix => New_Copy_Tree (Prefix (N)));
7603             begin
7604                Set_Etype (Obj, Array_Type);
7605                Set_Parent (Obj, Parent (N));
7606                Array_Type := Get_Actual_Subtype (Obj);
7607             end;
7608          end if;
7609
7610       elsif Is_Entity_Name (Name)
7611         or else (Nkind (Name) = N_Function_Call
7612                   and then not Is_Constrained (Etype (Name)))
7613       then
7614          Array_Type := Get_Actual_Subtype (Name);
7615
7616       --  If the name is a selected component that depends on discriminants,
7617       --  build an actual subtype for it. This can happen only when the name
7618       --  itself is overloaded; otherwise the actual subtype is created when
7619       --  the selected component is analyzed.
7620
7621       elsif Nkind (Name) = N_Selected_Component
7622         and then Full_Analysis
7623         and then Depends_On_Discriminant (First_Index (Array_Type))
7624       then
7625          declare
7626             Act_Decl : constant Node_Id :=
7627                          Build_Actual_Subtype_Of_Component (Array_Type, Name);
7628          begin
7629             Insert_Action (N, Act_Decl);
7630             Array_Type := Defining_Identifier (Act_Decl);
7631          end;
7632       end if;
7633
7634       --  If name was overloaded, set slice type correctly now
7635
7636       Set_Etype (N, Array_Type);
7637
7638       --  If the range is specified by a subtype mark, no resolution is
7639       --  necessary. Else resolve the bounds, and apply needed checks.
7640
7641       if not Is_Entity_Name (Drange) then
7642          Index := First_Index (Array_Type);
7643          Resolve (Drange, Base_Type (Etype (Index)));
7644
7645          if Nkind (Drange) = N_Range
7646
7647             --  Do not apply the range check to nodes associated with the
7648             --  frontend expansion of the dispatch table. We first check
7649             --  if Ada.Tags is already loaded to void the addition of an
7650             --  undesired dependence on such run-time unit.
7651
7652            and then
7653              (VM_Target /= No_VM
7654               or else not
7655                 (RTU_Loaded (Ada_Tags)
7656                   and then Nkind (Prefix (N)) = N_Selected_Component
7657                   and then Present (Entity (Selector_Name (Prefix (N))))
7658                   and then Entity (Selector_Name (Prefix (N))) =
7659                                         RTE_Record_Component (RE_Prims_Ptr)))
7660          then
7661             Apply_Range_Check (Drange, Etype (Index));
7662          end if;
7663       end if;
7664
7665       Set_Slice_Subtype (N);
7666
7667       if Nkind (Drange) = N_Range then
7668          Warn_On_Suspicious_Index (Name, Low_Bound  (Drange));
7669          Warn_On_Suspicious_Index (Name, High_Bound (Drange));
7670       end if;
7671
7672       Eval_Slice (N);
7673    end Resolve_Slice;
7674
7675    ----------------------------
7676    -- Resolve_String_Literal --
7677    ----------------------------
7678
7679    procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
7680       C_Typ      : constant Entity_Id  := Component_Type (Typ);
7681       R_Typ      : constant Entity_Id  := Root_Type (C_Typ);
7682       Loc        : constant Source_Ptr := Sloc (N);
7683       Str        : constant String_Id  := Strval (N);
7684       Strlen     : constant Nat        := String_Length (Str);
7685       Subtype_Id : Entity_Id;
7686       Need_Check : Boolean;
7687
7688    begin
7689       --  For a string appearing in a concatenation, defer creation of the
7690       --  string_literal_subtype until the end of the resolution of the
7691       --  concatenation, because the literal may be constant-folded away. This
7692       --  is a useful optimization for long concatenation expressions.
7693
7694       --  If the string is an aggregate built for a single character (which
7695       --  happens in a non-static context) or a is null string to which special
7696       --  checks may apply, we build the subtype. Wide strings must also get a
7697       --  string subtype if they come from a one character aggregate. Strings
7698       --  generated by attributes might be static, but it is often hard to
7699       --  determine whether the enclosing context is static, so we generate
7700       --  subtypes for them as well, thus losing some rarer optimizations ???
7701       --  Same for strings that come from a static conversion.
7702
7703       Need_Check :=
7704         (Strlen = 0 and then Typ /= Standard_String)
7705           or else Nkind (Parent (N)) /= N_Op_Concat
7706           or else (N /= Left_Opnd (Parent (N))
7707                     and then N /= Right_Opnd (Parent (N)))
7708           or else ((Typ = Standard_Wide_String
7709                       or else Typ = Standard_Wide_Wide_String)
7710                     and then Nkind (Original_Node (N)) /= N_String_Literal);
7711
7712       --  If the resolving type is itself a string literal subtype, we
7713       --  can just reuse it, since there is no point in creating another.
7714
7715       if Ekind (Typ) = E_String_Literal_Subtype then
7716          Subtype_Id := Typ;
7717
7718       elsif Nkind (Parent (N)) = N_Op_Concat
7719         and then not Need_Check
7720         and then not Nkind_In (Original_Node (N), N_Character_Literal,
7721                                                   N_Attribute_Reference,
7722                                                   N_Qualified_Expression,
7723                                                   N_Type_Conversion)
7724       then
7725          Subtype_Id := Typ;
7726
7727       --  Otherwise we must create a string literal subtype. Note that the
7728       --  whole idea of string literal subtypes is simply to avoid the need
7729       --  for building a full fledged array subtype for each literal.
7730
7731       else
7732          Set_String_Literal_Subtype (N, Typ);
7733          Subtype_Id := Etype (N);
7734       end if;
7735
7736       if Nkind (Parent (N)) /= N_Op_Concat
7737         or else Need_Check
7738       then
7739          Set_Etype (N, Subtype_Id);
7740          Eval_String_Literal (N);
7741       end if;
7742
7743       if Is_Limited_Composite (Typ)
7744         or else Is_Private_Composite (Typ)
7745       then
7746          Error_Msg_N ("string literal not available for private array", N);
7747          Set_Etype (N, Any_Type);
7748          return;
7749       end if;
7750
7751       --  The validity of a null string has been checked in the
7752       --  call to  Eval_String_Literal.
7753
7754       if Strlen = 0 then
7755          return;
7756
7757       --  Always accept string literal with component type Any_Character, which
7758       --  occurs in error situations and in comparisons of literals, both of
7759       --  which should accept all literals.
7760
7761       elsif R_Typ = Any_Character then
7762          return;
7763
7764       --  If the type is bit-packed, then we always transform the string
7765       --  literal into a full fledged aggregate.
7766
7767       elsif Is_Bit_Packed_Array (Typ) then
7768          null;
7769
7770       --  Deal with cases of Wide_Wide_String, Wide_String, and String
7771
7772       else
7773          --  For Standard.Wide_Wide_String, or any other type whose component
7774          --  type is Standard.Wide_Wide_Character, we know that all the
7775          --  characters in the string must be acceptable, since the parser
7776          --  accepted the characters as valid character literals.
7777
7778          if R_Typ = Standard_Wide_Wide_Character then
7779             null;
7780
7781          --  For the case of Standard.String, or any other type whose component
7782          --  type is Standard.Character, we must make sure that there are no
7783          --  wide characters in the string, i.e. that it is entirely composed
7784          --  of characters in range of type Character.
7785
7786          --  If the string literal is the result of a static concatenation, the
7787          --  test has already been performed on the components, and need not be
7788          --  repeated.
7789
7790          elsif R_Typ = Standard_Character
7791            and then Nkind (Original_Node (N)) /= N_Op_Concat
7792          then
7793             for J in 1 .. Strlen loop
7794                if not In_Character_Range (Get_String_Char (Str, J)) then
7795
7796                   --  If we are out of range, post error. This is one of the
7797                   --  very few places that we place the flag in the middle of
7798                   --  a token, right under the offending wide character.
7799
7800                   Error_Msg
7801                     ("literal out of range of type Standard.Character",
7802                      Source_Ptr (Int (Loc) + J));
7803                   return;
7804                end if;
7805             end loop;
7806
7807          --  For the case of Standard.Wide_String, or any other type whose
7808          --  component type is Standard.Wide_Character, we must make sure that
7809          --  there are no wide characters in the string, i.e. that it is
7810          --  entirely composed of characters in range of type Wide_Character.
7811
7812          --  If the string literal is the result of a static concatenation,
7813          --  the test has already been performed on the components, and need
7814          --  not be repeated.
7815
7816          elsif R_Typ = Standard_Wide_Character
7817            and then Nkind (Original_Node (N)) /= N_Op_Concat
7818          then
7819             for J in 1 .. Strlen loop
7820                if not In_Wide_Character_Range (Get_String_Char (Str, J)) then
7821
7822                   --  If we are out of range, post error. This is one of the
7823                   --  very few places that we place the flag in the middle of
7824                   --  a token, right under the offending wide character.
7825
7826                   --  This is not quite right, because characters in general
7827                   --  will take more than one character position ???
7828
7829                   Error_Msg
7830                     ("literal out of range of type Standard.Wide_Character",
7831                      Source_Ptr (Int (Loc) + J));
7832                   return;
7833                end if;
7834             end loop;
7835
7836          --  If the root type is not a standard character, then we will convert
7837          --  the string into an aggregate and will let the aggregate code do
7838          --  the checking. Standard Wide_Wide_Character is also OK here.
7839
7840          else
7841             null;
7842          end if;
7843
7844          --  See if the component type of the array corresponding to the string
7845          --  has compile time known bounds. If yes we can directly check
7846          --  whether the evaluation of the string will raise constraint error.
7847          --  Otherwise we need to transform the string literal into the
7848          --  corresponding character aggregate and let the aggregate
7849          --  code do the checking.
7850
7851          if Is_Standard_Character_Type (R_Typ) then
7852
7853             --  Check for the case of full range, where we are definitely OK
7854
7855             if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
7856                return;
7857             end if;
7858
7859             --  Here the range is not the complete base type range, so check
7860
7861             declare
7862                Comp_Typ_Lo : constant Node_Id :=
7863                                Type_Low_Bound (Component_Type (Typ));
7864                Comp_Typ_Hi : constant Node_Id :=
7865                                Type_High_Bound (Component_Type (Typ));
7866
7867                Char_Val : Uint;
7868
7869             begin
7870                if Compile_Time_Known_Value (Comp_Typ_Lo)
7871                  and then Compile_Time_Known_Value (Comp_Typ_Hi)
7872                then
7873                   for J in 1 .. Strlen loop
7874                      Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
7875
7876                      if Char_Val < Expr_Value (Comp_Typ_Lo)
7877                        or else Char_Val > Expr_Value (Comp_Typ_Hi)
7878                      then
7879                         Apply_Compile_Time_Constraint_Error
7880                           (N, "character out of range?", CE_Range_Check_Failed,
7881                            Loc => Source_Ptr (Int (Loc) + J));
7882                      end if;
7883                   end loop;
7884
7885                   return;
7886                end if;
7887             end;
7888          end if;
7889       end if;
7890
7891       --  If we got here we meed to transform the string literal into the
7892       --  equivalent qualified positional array aggregate. This is rather
7893       --  heavy artillery for this situation, but it is hard work to avoid.
7894
7895       declare
7896          Lits : constant List_Id    := New_List;
7897          P    : Source_Ptr := Loc + 1;
7898          C    : Char_Code;
7899
7900       begin
7901          --  Build the character literals, we give them source locations that
7902          --  correspond to the string positions, which is a bit tricky given
7903          --  the possible presence of wide character escape sequences.
7904
7905          for J in 1 .. Strlen loop
7906             C := Get_String_Char (Str, J);
7907             Set_Character_Literal_Name (C);
7908
7909             Append_To (Lits,
7910               Make_Character_Literal (P,
7911                 Chars              => Name_Find,
7912                 Char_Literal_Value => UI_From_CC (C)));
7913
7914             if In_Character_Range (C) then
7915                P := P + 1;
7916
7917             --  Should we have a call to Skip_Wide here ???
7918             --  ???     else
7919             --             Skip_Wide (P);
7920
7921             end if;
7922          end loop;
7923
7924          Rewrite (N,
7925            Make_Qualified_Expression (Loc,
7926              Subtype_Mark => New_Reference_To (Typ, Loc),
7927              Expression   =>
7928                Make_Aggregate (Loc, Expressions => Lits)));
7929
7930          Analyze_And_Resolve (N, Typ);
7931       end;
7932    end Resolve_String_Literal;
7933
7934    -----------------------------
7935    -- Resolve_Subprogram_Info --
7936    -----------------------------
7937
7938    procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
7939    begin
7940       Set_Etype (N, Typ);
7941    end Resolve_Subprogram_Info;
7942
7943    -----------------------------
7944    -- Resolve_Type_Conversion --
7945    -----------------------------
7946
7947    procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
7948       Conv_OK     : constant Boolean := Conversion_OK (N);
7949       Operand     : constant Node_Id := Expression (N);
7950       Operand_Typ : constant Entity_Id := Etype (Operand);
7951       Target_Typ  : constant Entity_Id := Etype (N);
7952       Rop         : Node_Id;
7953       Orig_N      : Node_Id;
7954       Orig_T      : Node_Id;
7955
7956    begin
7957       if not Conv_OK
7958         and then not Valid_Conversion (N, Target_Typ, Operand)
7959       then
7960          return;
7961       end if;
7962
7963       if Etype (Operand) = Any_Fixed then
7964
7965          --  Mixed-mode operation involving a literal. Context must be a fixed
7966          --  type which is applied to the literal subsequently.
7967
7968          if Is_Fixed_Point_Type (Typ) then
7969             Set_Etype (Operand, Universal_Real);
7970
7971          elsif Is_Numeric_Type (Typ)
7972            and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide)
7973            and then (Etype (Right_Opnd (Operand)) = Universal_Real
7974                        or else
7975                      Etype (Left_Opnd  (Operand)) = Universal_Real)
7976          then
7977             --  Return if expression is ambiguous
7978
7979             if Unique_Fixed_Point_Type (N) = Any_Type then
7980                return;
7981
7982             --  If nothing else, the available fixed type is Duration
7983
7984             else
7985                Set_Etype (Operand, Standard_Duration);
7986             end if;
7987
7988             --  Resolve the real operand with largest available precision
7989
7990             if Etype (Right_Opnd (Operand)) = Universal_Real then
7991                Rop := New_Copy_Tree (Right_Opnd (Operand));
7992             else
7993                Rop := New_Copy_Tree (Left_Opnd (Operand));
7994             end if;
7995
7996             Resolve (Rop, Universal_Real);
7997
7998             --  If the operand is a literal (it could be a non-static and
7999             --  illegal exponentiation) check whether the use of Duration
8000             --  is potentially inaccurate.
8001
8002             if Nkind (Rop) = N_Real_Literal
8003               and then Realval (Rop) /= Ureal_0
8004               and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
8005             then
8006                Error_Msg_N
8007                  ("?universal real operand can only " &
8008                   "be interpreted as Duration!",
8009                   Rop);
8010                Error_Msg_N
8011                  ("\?precision will be lost in the conversion!", Rop);
8012             end if;
8013
8014          elsif Is_Numeric_Type (Typ)
8015            and then Nkind (Operand) in N_Op
8016            and then Unique_Fixed_Point_Type (N) /= Any_Type
8017          then
8018             Set_Etype (Operand, Standard_Duration);
8019
8020          else
8021             Error_Msg_N ("invalid context for mixed mode operation", N);
8022             Set_Etype (Operand, Any_Type);
8023             return;
8024          end if;
8025       end if;
8026
8027       Resolve (Operand);
8028
8029       --  Note: we do the Eval_Type_Conversion call before applying the
8030       --  required checks for a subtype conversion. This is important,
8031       --  since both are prepared under certain circumstances to change
8032       --  the type conversion to a constraint error node, but in the case
8033       --  of Eval_Type_Conversion this may reflect an illegality in the
8034       --  static case, and we would miss the illegality (getting only a
8035       --  warning message), if we applied the type conversion checks first.
8036
8037       Eval_Type_Conversion (N);
8038
8039       --  Even when evaluation is not possible, we may be able to simplify
8040       --  the conversion or its expression. This needs to be done before
8041       --  applying checks, since otherwise the checks may use the original
8042       --  expression and defeat the simplifications. This is specifically
8043       --  the case for elimination of the floating-point Truncation
8044       --  attribute in float-to-int conversions.
8045
8046       Simplify_Type_Conversion (N);
8047
8048       --  If after evaluation we still have a type conversion, then we
8049       --  may need to apply checks required for a subtype conversion.
8050
8051       --  Skip these type conversion checks if universal fixed operands
8052       --  operands involved, since range checks are handled separately for
8053       --  these cases (in the appropriate Expand routines in unit Exp_Fixd).
8054
8055       if Nkind (N) = N_Type_Conversion
8056         and then not Is_Generic_Type (Root_Type (Target_Typ))
8057         and then Target_Typ  /= Universal_Fixed
8058         and then Operand_Typ /= Universal_Fixed
8059       then
8060          Apply_Type_Conversion_Checks (N);
8061       end if;
8062
8063       --  Issue warning for conversion of simple object to its own type
8064       --  We have to test the original nodes, since they may have been
8065       --  rewritten by various optimizations.
8066
8067       Orig_N := Original_Node (N);
8068
8069       if Warn_On_Redundant_Constructs
8070         and then Comes_From_Source (Orig_N)
8071         and then Nkind (Orig_N) = N_Type_Conversion
8072         and then not In_Instance
8073       then
8074          Orig_N := Original_Node (Expression (Orig_N));
8075          Orig_T := Target_Typ;
8076
8077          --  If the node is part of a larger expression, the Target_Type
8078          --  may not be the original type of the node if the context is a
8079          --  condition. Recover original type to see if conversion is needed.
8080
8081          if Is_Boolean_Type (Orig_T)
8082           and then Nkind (Parent (N)) in N_Op
8083          then
8084             Orig_T := Etype (Parent (N));
8085          end if;
8086
8087          if Is_Entity_Name (Orig_N)
8088            and then
8089              (Etype (Entity (Orig_N)) = Orig_T
8090                 or else
8091                   (Ekind (Entity (Orig_N)) = E_Loop_Parameter
8092                      and then Covers (Orig_T, Etype (Entity (Orig_N)))))
8093          then
8094             Error_Msg_Node_2 := Orig_T;
8095             Error_Msg_NE
8096               ("?redundant conversion, & is of type &!", N, Entity (Orig_N));
8097          end if;
8098       end if;
8099
8100       --  Ada 2005 (AI-251): Handle class-wide interface type conversions.
8101       --  No need to perform any interface conversion if the type of the
8102       --  expression coincides with the target type.
8103
8104       if Ada_Version >= Ada_05
8105         and then Expander_Active
8106         and then Operand_Typ /= Target_Typ
8107       then
8108          declare
8109             Opnd   : Entity_Id := Operand_Typ;
8110             Target : Entity_Id := Target_Typ;
8111
8112          begin
8113             if Is_Access_Type (Opnd) then
8114                Opnd := Directly_Designated_Type (Opnd);
8115             end if;
8116
8117             if Is_Access_Type (Target_Typ) then
8118                Target := Directly_Designated_Type (Target);
8119             end if;
8120
8121             if Opnd = Target then
8122                null;
8123
8124             --  Conversion from interface type
8125
8126             elsif Is_Interface (Opnd) then
8127
8128                --  Ada 2005 (AI-217): Handle entities from limited views
8129
8130                if From_With_Type (Opnd) then
8131                   Error_Msg_Qual_Level := 99;
8132                   Error_Msg_NE ("missing with-clause on package &", N,
8133                     Cunit_Entity (Get_Source_Unit (Base_Type (Opnd))));
8134                   Error_Msg_N
8135                     ("type conversions require visibility of the full view",
8136                      N);
8137
8138                elsif From_With_Type (Target)
8139                  and then not
8140                    (Is_Access_Type (Target_Typ)
8141                       and then Present (Non_Limited_View (Etype (Target))))
8142                then
8143                   Error_Msg_Qual_Level := 99;
8144                   Error_Msg_NE ("missing with-clause on package &", N,
8145                     Cunit_Entity (Get_Source_Unit (Base_Type (Target))));
8146                   Error_Msg_N
8147                     ("type conversions require visibility of the full view",
8148                      N);
8149
8150                else
8151                   Expand_Interface_Conversion (N, Is_Static => False);
8152                end if;
8153
8154             --  Conversion to interface type
8155
8156             elsif Is_Interface (Target) then
8157
8158                --  Handle subtypes
8159
8160                if Ekind (Opnd) = E_Protected_Subtype
8161                  or else Ekind (Opnd) = E_Task_Subtype
8162                then
8163                   Opnd := Etype (Opnd);
8164                end if;
8165
8166                if not Interface_Present_In_Ancestor
8167                         (Typ   => Opnd,
8168                          Iface => Target)
8169                then
8170                   if Is_Class_Wide_Type (Opnd) then
8171
8172                      --  The static analysis is not enough to know if the
8173                      --  interface is implemented or not. Hence we must pass
8174                      --  the work to the expander to generate code to evaluate
8175                      --  the conversion at run-time.
8176
8177                      Expand_Interface_Conversion (N, Is_Static => False);
8178
8179                   else
8180                      Error_Msg_Name_1 := Chars (Etype (Target));
8181                      Error_Msg_Name_2 := Chars (Opnd);
8182                      Error_Msg_N
8183                        ("wrong interface conversion (% is not a progenitor " &
8184                         "of %)", N);
8185                   end if;
8186
8187                else
8188                   Expand_Interface_Conversion (N);
8189                end if;
8190             end if;
8191          end;
8192       end if;
8193    end Resolve_Type_Conversion;
8194
8195    ----------------------
8196    -- Resolve_Unary_Op --
8197    ----------------------
8198
8199    procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
8200       B_Typ : constant Entity_Id := Base_Type (Typ);
8201       R     : constant Node_Id   := Right_Opnd (N);
8202       OK    : Boolean;
8203       Lo    : Uint;
8204       Hi    : Uint;
8205
8206    begin
8207       --  Deal with intrinsic unary operators
8208
8209       if Comes_From_Source (N)
8210         and then Ekind (Entity (N)) = E_Function
8211         and then Is_Imported (Entity (N))
8212         and then Is_Intrinsic_Subprogram (Entity (N))
8213       then
8214          Resolve_Intrinsic_Unary_Operator (N, Typ);
8215          return;
8216       end if;
8217
8218       --  Deal with universal cases
8219
8220       if Etype (R) = Universal_Integer
8221            or else
8222          Etype (R) = Universal_Real
8223       then
8224          Check_For_Visible_Operator (N, B_Typ);
8225       end if;
8226
8227       Set_Etype (N, B_Typ);
8228       Resolve (R, B_Typ);
8229
8230       --  Generate warning for expressions like abs (x mod 2)
8231
8232       if Warn_On_Redundant_Constructs
8233         and then Nkind (N) = N_Op_Abs
8234       then
8235          Determine_Range (Right_Opnd (N), OK, Lo, Hi);
8236
8237          if OK and then Hi >= Lo and then Lo >= 0 then
8238             Error_Msg_N
8239              ("?abs applied to known non-negative value has no effect", N);
8240          end if;
8241       end if;
8242
8243       --  Deal with reference generation
8244
8245       Check_Unset_Reference (R);
8246       Generate_Operator_Reference (N, B_Typ);
8247       Eval_Unary_Op (N);
8248
8249       --  Set overflow checking bit. Much cleverer code needed here eventually
8250       --  and perhaps the Resolve routines should be separated for the various
8251       --  arithmetic operations, since they will need different processing ???
8252
8253       if Nkind (N) in N_Op then
8254          if not Overflow_Checks_Suppressed (Etype (N)) then
8255             Enable_Overflow_Check (N);
8256          end if;
8257       end if;
8258
8259       --  Generate warning for expressions like -5 mod 3 for integers. No
8260       --  need to worry in the floating-point case, since parens do not affect
8261       --  the result so there is no point in giving in a warning.
8262
8263       declare
8264          Norig : constant Node_Id := Original_Node (N);
8265          Rorig : Node_Id;
8266          Val   : Uint;
8267          HB    : Uint;
8268          LB    : Uint;
8269          Lval  : Uint;
8270          Opnd  : Node_Id;
8271
8272       begin
8273          if Warn_On_Questionable_Missing_Parens
8274            and then Comes_From_Source (Norig)
8275            and then Is_Integer_Type (Typ)
8276            and then Nkind (Norig) = N_Op_Minus
8277          then
8278             Rorig := Original_Node (Right_Opnd (Norig));
8279
8280             --  We are looking for cases where the right operand is not
8281             --  parenthesized, and is a binary operator, multiply, divide, or
8282             --  mod. These are the cases where the grouping can affect results.
8283
8284             if Paren_Count (Rorig) = 0
8285               and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide)
8286             then
8287                --  For mod, we always give the warning, since the value is
8288                --  affected by the parenthesization (e.g. (-5) mod 315 /=
8289                --  (5 mod 315)). But for the other cases, the only concern is
8290                --  overflow, e.g. for the case of 8 big signed (-(2 * 64)
8291                --  overflows, but (-2) * 64 does not). So we try to give the
8292                --  message only when overflow is possible.
8293
8294                if Nkind (Rorig) /= N_Op_Mod
8295                  and then Compile_Time_Known_Value (R)
8296                then
8297                   Val := Expr_Value (R);
8298
8299                   if Compile_Time_Known_Value (Type_High_Bound (Typ)) then
8300                      HB := Expr_Value (Type_High_Bound (Typ));
8301                   else
8302                      HB := Expr_Value (Type_High_Bound (Base_Type (Typ)));
8303                   end if;
8304
8305                   if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
8306                      LB := Expr_Value (Type_Low_Bound (Typ));
8307                   else
8308                      LB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
8309                   end if;
8310
8311                   --  Note that the test below is deliberately excluding
8312                   --  the largest negative number, since that is a potentially
8313                   --  troublesome case (e.g. -2 * x, where the result is the
8314                   --  largest negative integer has an overflow with 2 * x).
8315
8316                   if Val > LB and then Val <= HB then
8317                      return;
8318                   end if;
8319                end if;
8320
8321                --  For the multiplication case, the only case we have to worry
8322                --  about is when (-a)*b is exactly the largest negative number
8323                --  so that -(a*b) can cause overflow. This can only happen if
8324                --  a is a power of 2, and more generally if any operand is a
8325                --  constant that is not a power of 2, then the parentheses
8326                --  cannot affect whether overflow occurs. We only bother to
8327                --  test the left most operand
8328
8329                --  Loop looking at left operands for one that has known value
8330
8331                Opnd := Rorig;
8332                Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop
8333                   if Compile_Time_Known_Value (Left_Opnd (Opnd)) then
8334                      Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd)));
8335
8336                      --  Operand value of 0 or 1 skips warning
8337
8338                      if Lval <= 1 then
8339                         return;
8340
8341                      --  Otherwise check power of 2, if power of 2, warn, if
8342                      --  anything else, skip warning.
8343
8344                      else
8345                         while Lval /= 2 loop
8346                            if Lval mod 2 = 1 then
8347                               return;
8348                            else
8349                               Lval := Lval / 2;
8350                            end if;
8351                         end loop;
8352
8353                         exit Opnd_Loop;
8354                      end if;
8355                   end if;
8356
8357                   --  Keep looking at left operands
8358
8359                   Opnd := Left_Opnd (Opnd);
8360                end loop Opnd_Loop;
8361
8362                --  For rem or "/" we can only have a problematic situation
8363                --  if the divisor has a value of minus one or one. Otherwise
8364                --  overflow is impossible (divisor > 1) or we have a case of
8365                --  division by zero in any case.
8366
8367                if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem)
8368                  and then Compile_Time_Known_Value (Right_Opnd (Rorig))
8369                  and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
8370                then
8371                   return;
8372                end if;
8373
8374                --  If we fall through warning should be issued
8375
8376                Error_Msg_N
8377                  ("?unary minus expression should be parenthesized here!", N);
8378             end if;
8379          end if;
8380       end;
8381    end Resolve_Unary_Op;
8382
8383    ----------------------------------
8384    -- Resolve_Unchecked_Expression --
8385    ----------------------------------
8386
8387    procedure Resolve_Unchecked_Expression
8388      (N   : Node_Id;
8389       Typ : Entity_Id)
8390    is
8391    begin
8392       Resolve (Expression (N), Typ, Suppress => All_Checks);
8393       Set_Etype (N, Typ);
8394    end Resolve_Unchecked_Expression;
8395
8396    ---------------------------------------
8397    -- Resolve_Unchecked_Type_Conversion --
8398    ---------------------------------------
8399
8400    procedure Resolve_Unchecked_Type_Conversion
8401      (N   : Node_Id;
8402       Typ : Entity_Id)
8403    is
8404       pragma Warnings (Off, Typ);
8405
8406       Operand   : constant Node_Id   := Expression (N);
8407       Opnd_Type : constant Entity_Id := Etype (Operand);
8408
8409    begin
8410       --  Resolve operand using its own type
8411
8412       Resolve (Operand, Opnd_Type);
8413       Eval_Unchecked_Conversion (N);
8414
8415    end Resolve_Unchecked_Type_Conversion;
8416
8417    ------------------------------
8418    -- Rewrite_Operator_As_Call --
8419    ------------------------------
8420
8421    procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
8422       Loc     : constant Source_Ptr := Sloc (N);
8423       Actuals : constant List_Id    := New_List;
8424       New_N   : Node_Id;
8425
8426    begin
8427       if Nkind (N) in  N_Binary_Op then
8428          Append (Left_Opnd (N), Actuals);
8429       end if;
8430
8431       Append (Right_Opnd (N), Actuals);
8432
8433       New_N :=
8434         Make_Function_Call (Sloc => Loc,
8435           Name => New_Occurrence_Of (Nam, Loc),
8436           Parameter_Associations => Actuals);
8437
8438       Preserve_Comes_From_Source (New_N, N);
8439       Preserve_Comes_From_Source (Name (New_N), N);
8440       Rewrite (N, New_N);
8441       Set_Etype (N, Etype (Nam));
8442    end Rewrite_Operator_As_Call;
8443
8444    ------------------------------
8445    -- Rewrite_Renamed_Operator --
8446    ------------------------------
8447
8448    procedure Rewrite_Renamed_Operator
8449      (N   : Node_Id;
8450       Op  : Entity_Id;
8451       Typ : Entity_Id)
8452    is
8453       Nam       : constant Name_Id := Chars (Op);
8454       Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
8455       Op_Node   : Node_Id;
8456
8457    begin
8458       --  Rewrite the operator node using the real operator, not its
8459       --  renaming. Exclude user-defined intrinsic operations of the same
8460       --  name, which are treated separately and rewritten as calls.
8461
8462       if Ekind (Op) /= E_Function
8463         or else Chars (N) /= Nam
8464       then
8465          Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
8466          Set_Chars      (Op_Node, Nam);
8467          Set_Etype      (Op_Node, Etype (N));
8468          Set_Entity     (Op_Node, Op);
8469          Set_Right_Opnd (Op_Node, Right_Opnd (N));
8470
8471          --  Indicate that both the original entity and its renaming are
8472          --  referenced at this point.
8473
8474          Generate_Reference (Entity (N), N);
8475          Generate_Reference (Op, N);
8476
8477          if Is_Binary then
8478             Set_Left_Opnd  (Op_Node, Left_Opnd  (N));
8479          end if;
8480
8481          Rewrite (N, Op_Node);
8482
8483          --  If the context type is private, add the appropriate conversions
8484          --  so that the operator is applied to the full view. This is done
8485          --  in the routines that resolve intrinsic operators,
8486
8487          if Is_Intrinsic_Subprogram (Op)
8488            and then Is_Private_Type (Typ)
8489          then
8490             case Nkind (N) is
8491                when N_Op_Add   | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
8492                     N_Op_Expon | N_Op_Mod      | N_Op_Rem      =>
8493                   Resolve_Intrinsic_Operator (N, Typ);
8494
8495                when N_Op_Plus | N_Op_Minus    | N_Op_Abs      =>
8496                   Resolve_Intrinsic_Unary_Operator (N, Typ);
8497
8498                when others =>
8499                   Resolve (N, Typ);
8500             end case;
8501          end if;
8502
8503       elsif Ekind (Op) = E_Function
8504         and then Is_Intrinsic_Subprogram (Op)
8505       then
8506          --  Operator renames a user-defined operator of the same name. Use
8507          --  the original operator in the node, which is the one that Gigi
8508          --  knows about.
8509
8510          Set_Entity (N, Op);
8511          Set_Is_Overloaded (N, False);
8512       end if;
8513    end Rewrite_Renamed_Operator;
8514
8515    -----------------------
8516    -- Set_Slice_Subtype --
8517    -----------------------
8518
8519    --  Build an implicit subtype declaration to represent the type delivered
8520    --  by the slice. This is an abbreviated version of an array subtype. We
8521    --  define an index subtype for the slice, using either the subtype name
8522    --  or the discrete range of the slice. To be consistent with index usage
8523    --  elsewhere, we create a list header to hold the single index. This list
8524    --  is not otherwise attached to the syntax tree.
8525
8526    procedure Set_Slice_Subtype (N : Node_Id) is
8527       Loc           : constant Source_Ptr := Sloc (N);
8528       Index_List    : constant List_Id    := New_List;
8529       Index         : Node_Id;
8530       Index_Subtype : Entity_Id;
8531       Index_Type    : Entity_Id;
8532       Slice_Subtype : Entity_Id;
8533       Drange        : constant Node_Id := Discrete_Range (N);
8534
8535    begin
8536       if Is_Entity_Name (Drange) then
8537          Index_Subtype := Entity (Drange);
8538
8539       else
8540          --  We force the evaluation of a range. This is definitely needed in
8541          --  the renamed case, and seems safer to do unconditionally. Note in
8542          --  any case that since we will create and insert an Itype referring
8543          --  to this range, we must make sure any side effect removal actions
8544          --  are inserted before the Itype definition.
8545
8546          if Nkind (Drange) = N_Range then
8547             Force_Evaluation (Low_Bound (Drange));
8548             Force_Evaluation (High_Bound (Drange));
8549          end if;
8550
8551          Index_Type := Base_Type (Etype (Drange));
8552
8553          Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
8554
8555          Set_Scalar_Range (Index_Subtype, Drange);
8556          Set_Etype        (Index_Subtype, Index_Type);
8557          Set_Size_Info    (Index_Subtype, Index_Type);
8558          Set_RM_Size      (Index_Subtype, RM_Size (Index_Type));
8559       end if;
8560
8561       Slice_Subtype := Create_Itype (E_Array_Subtype, N);
8562
8563       Index := New_Occurrence_Of (Index_Subtype, Loc);
8564       Set_Etype (Index, Index_Subtype);
8565       Append (Index, Index_List);
8566
8567       Set_First_Index    (Slice_Subtype, Index);
8568       Set_Etype          (Slice_Subtype, Base_Type (Etype (N)));
8569       Set_Is_Constrained (Slice_Subtype, True);
8570
8571       Check_Compile_Time_Size (Slice_Subtype);
8572
8573       --  The Etype of the existing Slice node is reset to this slice subtype.
8574       --  Its bounds are obtained from its first index.
8575
8576       Set_Etype (N, Slice_Subtype);
8577
8578       --  In the packed case, this must be immediately frozen
8579
8580       --  Couldn't we always freeze here??? and if we did, then the above
8581       --  call to Check_Compile_Time_Size could be eliminated, which would
8582       --  be nice, because then that routine could be made private to Freeze.
8583
8584       --  Why the test for In_Spec_Expression here ???
8585
8586       if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
8587          Freeze_Itype (Slice_Subtype, N);
8588       end if;
8589
8590    end Set_Slice_Subtype;
8591
8592    --------------------------------
8593    -- Set_String_Literal_Subtype --
8594    --------------------------------
8595
8596    procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
8597       Loc        : constant Source_Ptr := Sloc (N);
8598       Low_Bound  : constant Node_Id :=
8599                         Type_Low_Bound (Etype (First_Index (Typ)));
8600       Subtype_Id : Entity_Id;
8601
8602    begin
8603       if Nkind (N) /= N_String_Literal then
8604          return;
8605       end if;
8606
8607       Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
8608       Set_String_Literal_Length (Subtype_Id, UI_From_Int
8609                                                (String_Length (Strval (N))));
8610       Set_Etype          (Subtype_Id, Base_Type (Typ));
8611       Set_Is_Constrained (Subtype_Id);
8612       Set_Etype          (N, Subtype_Id);
8613
8614       if Is_OK_Static_Expression (Low_Bound) then
8615
8616       --  The low bound is set from the low bound of the corresponding
8617       --  index type. Note that we do not store the high bound in the
8618       --  string literal subtype, but it can be deduced if necessary
8619       --  from the length and the low bound.
8620
8621          Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound);
8622
8623       else
8624          Set_String_Literal_Low_Bound
8625            (Subtype_Id, Make_Integer_Literal (Loc, 1));
8626          Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive);
8627
8628          --  Build bona fide subtype for the string, and wrap it in an
8629          --  unchecked conversion, because the backend expects the
8630          --  String_Literal_Subtype to have a static lower bound.
8631
8632          declare
8633             Index_List    : constant List_Id    := New_List;
8634             Index_Type    : constant Entity_Id := Etype (First_Index (Typ));
8635             High_Bound    : constant Node_Id :=
8636                                Make_Op_Add (Loc,
8637                                   Left_Opnd => New_Copy_Tree (Low_Bound),
8638                                   Right_Opnd =>
8639                                     Make_Integer_Literal (Loc,
8640                                       String_Length (Strval (N)) - 1));
8641             Array_Subtype : Entity_Id;
8642             Index_Subtype : Entity_Id;
8643             Drange        : Node_Id;
8644             Index         : Node_Id;
8645
8646          begin
8647             Index_Subtype :=
8648               Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
8649             Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound);
8650             Set_Scalar_Range (Index_Subtype, Drange);
8651             Set_Parent (Drange, N);
8652             Analyze_And_Resolve (Drange, Index_Type);
8653
8654             --  In the context, the Index_Type may already have a constraint,
8655             --  so use common base type on string subtype. The base type may
8656             --  be used when generating attributes of the string, for example
8657             --  in the context of a slice assignment.
8658
8659             Set_Etype        (Index_Subtype, Base_Type (Index_Type));
8660             Set_Size_Info    (Index_Subtype, Index_Type);
8661             Set_RM_Size      (Index_Subtype, RM_Size (Index_Type));
8662
8663             Array_Subtype := Create_Itype (E_Array_Subtype, N);
8664
8665             Index := New_Occurrence_Of (Index_Subtype, Loc);
8666             Set_Etype (Index, Index_Subtype);
8667             Append (Index, Index_List);
8668
8669             Set_First_Index    (Array_Subtype, Index);
8670             Set_Etype          (Array_Subtype, Base_Type (Typ));
8671             Set_Is_Constrained (Array_Subtype, True);
8672
8673             Rewrite (N,
8674               Make_Unchecked_Type_Conversion (Loc,
8675                 Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc),
8676                 Expression => Relocate_Node (N)));
8677             Set_Etype (N, Array_Subtype);
8678          end;
8679       end if;
8680    end Set_String_Literal_Subtype;
8681
8682    ------------------------------
8683    -- Simplify_Type_Conversion --
8684    ------------------------------
8685
8686    procedure Simplify_Type_Conversion (N : Node_Id) is
8687    begin
8688       if Nkind (N) = N_Type_Conversion then
8689          declare
8690             Operand    : constant Node_Id   := Expression (N);
8691             Target_Typ : constant Entity_Id := Etype (N);
8692             Opnd_Typ   : constant Entity_Id := Etype (Operand);
8693
8694          begin
8695             if Is_Floating_Point_Type (Opnd_Typ)
8696               and then
8697                 (Is_Integer_Type (Target_Typ)
8698                    or else (Is_Fixed_Point_Type (Target_Typ)
8699                               and then Conversion_OK (N)))
8700               and then Nkind (Operand) = N_Attribute_Reference
8701               and then Attribute_Name (Operand) = Name_Truncation
8702
8703             --  Special processing required if the conversion is the expression
8704             --  of a Truncation attribute reference. In this case we replace:
8705
8706             --     ityp (ftyp'Truncation (x))
8707
8708             --  by
8709
8710             --     ityp (x)
8711
8712             --  with the Float_Truncate flag set, which is more efficient
8713
8714             then
8715                Rewrite (Operand,
8716                  Relocate_Node (First (Expressions (Operand))));
8717                Set_Float_Truncate (N, True);
8718             end if;
8719          end;
8720       end if;
8721    end Simplify_Type_Conversion;
8722
8723    -----------------------------
8724    -- Unique_Fixed_Point_Type --
8725    -----------------------------
8726
8727    function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
8728       T1   : Entity_Id := Empty;
8729       T2   : Entity_Id;
8730       Item : Node_Id;
8731       Scop : Entity_Id;
8732
8733       procedure Fixed_Point_Error;
8734       --  If true ambiguity, give details
8735
8736       -----------------------
8737       -- Fixed_Point_Error --
8738       -----------------------
8739
8740       procedure Fixed_Point_Error is
8741       begin
8742          Error_Msg_N ("ambiguous universal_fixed_expression", N);
8743          Error_Msg_NE ("\\possible interpretation as}", N, T1);
8744          Error_Msg_NE ("\\possible interpretation as}", N, T2);
8745       end Fixed_Point_Error;
8746
8747    --  Start of processing for Unique_Fixed_Point_Type
8748
8749    begin
8750       --  The operations on Duration are visible, so Duration is always a
8751       --  possible interpretation.
8752
8753       T1 := Standard_Duration;
8754
8755       --  Look for fixed-point types in enclosing scopes
8756
8757       Scop := Current_Scope;
8758       while Scop /= Standard_Standard loop
8759          T2 := First_Entity (Scop);
8760          while Present (T2) loop
8761             if Is_Fixed_Point_Type (T2)
8762               and then Current_Entity (T2) = T2
8763               and then Scope (Base_Type (T2)) = Scop
8764             then
8765                if Present (T1) then
8766                   Fixed_Point_Error;
8767                   return Any_Type;
8768                else
8769                   T1 := T2;
8770                end if;
8771             end if;
8772
8773             Next_Entity (T2);
8774          end loop;
8775
8776          Scop := Scope (Scop);
8777       end loop;
8778
8779       --  Look for visible fixed type declarations in the context
8780
8781       Item := First (Context_Items (Cunit (Current_Sem_Unit)));
8782       while Present (Item) loop
8783          if Nkind (Item) = N_With_Clause then
8784             Scop := Entity (Name (Item));
8785             T2 := First_Entity (Scop);
8786             while Present (T2) loop
8787                if Is_Fixed_Point_Type (T2)
8788                  and then Scope (Base_Type (T2)) = Scop
8789                  and then (Is_Potentially_Use_Visible (T2)
8790                              or else In_Use (T2))
8791                then
8792                   if Present (T1) then
8793                      Fixed_Point_Error;
8794                      return Any_Type;
8795                   else
8796                      T1 := T2;
8797                   end if;
8798                end if;
8799
8800                Next_Entity (T2);
8801             end loop;
8802          end if;
8803
8804          Next (Item);
8805       end loop;
8806
8807       if Nkind (N) = N_Real_Literal then
8808          Error_Msg_NE ("?real literal interpreted as }!", N, T1);
8809       else
8810          Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1);
8811       end if;
8812
8813       return T1;
8814    end Unique_Fixed_Point_Type;
8815
8816    ----------------------
8817    -- Valid_Conversion --
8818    ----------------------
8819
8820    function Valid_Conversion
8821      (N       : Node_Id;
8822       Target  : Entity_Id;
8823       Operand : Node_Id) return Boolean
8824    is
8825       Target_Type : constant Entity_Id := Base_Type (Target);
8826       Opnd_Type   : Entity_Id := Etype (Operand);
8827
8828       function Conversion_Check
8829         (Valid : Boolean;
8830          Msg   : String) return Boolean;
8831       --  Little routine to post Msg if Valid is False, returns Valid value
8832
8833       function Valid_Tagged_Conversion
8834         (Target_Type : Entity_Id;
8835          Opnd_Type   : Entity_Id) return Boolean;
8836       --  Specifically test for validity of tagged conversions
8837
8838       function Valid_Array_Conversion return Boolean;
8839       --  Check index and component conformance, and accessibility levels
8840       --  if the component types are anonymous access types (Ada 2005)
8841
8842       ----------------------
8843       -- Conversion_Check --
8844       ----------------------
8845
8846       function Conversion_Check
8847         (Valid : Boolean;
8848          Msg   : String) return Boolean
8849       is
8850       begin
8851          if not Valid then
8852             Error_Msg_N (Msg, Operand);
8853          end if;
8854
8855          return Valid;
8856       end Conversion_Check;
8857
8858       ----------------------------
8859       -- Valid_Array_Conversion --
8860       ----------------------------
8861
8862       function Valid_Array_Conversion return Boolean
8863       is
8864          Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type);
8865          Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type);
8866
8867          Opnd_Index      : Node_Id;
8868          Opnd_Index_Type : Entity_Id;
8869
8870          Target_Comp_Type : constant Entity_Id :=
8871                               Component_Type (Target_Type);
8872          Target_Comp_Base : constant Entity_Id :=
8873                               Base_Type (Target_Comp_Type);
8874
8875          Target_Index      : Node_Id;
8876          Target_Index_Type : Entity_Id;
8877
8878       begin
8879          --  Error if wrong number of dimensions
8880
8881          if
8882            Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type)
8883          then
8884             Error_Msg_N
8885               ("incompatible number of dimensions for conversion", Operand);
8886             return False;
8887
8888          --  Number of dimensions matches
8889
8890          else
8891             --  Loop through indexes of the two arrays
8892
8893             Target_Index := First_Index (Target_Type);
8894             Opnd_Index   := First_Index (Opnd_Type);
8895             while Present (Target_Index) and then Present (Opnd_Index) loop
8896                Target_Index_Type := Etype (Target_Index);
8897                Opnd_Index_Type   := Etype (Opnd_Index);
8898
8899                --  Error if index types are incompatible
8900
8901                if not (Is_Integer_Type (Target_Index_Type)
8902                        and then Is_Integer_Type (Opnd_Index_Type))
8903                  and then (Root_Type (Target_Index_Type)
8904                            /= Root_Type (Opnd_Index_Type))
8905                then
8906                   Error_Msg_N
8907                     ("incompatible index types for array conversion",
8908                      Operand);
8909                   return False;
8910                end if;
8911
8912                Next_Index (Target_Index);
8913                Next_Index (Opnd_Index);
8914             end loop;
8915
8916             --  If component types have same base type, all set
8917
8918             if Target_Comp_Base  = Opnd_Comp_Base then
8919                null;
8920
8921                --  Here if base types of components are not the same. The only
8922                --  time this is allowed is if we have anonymous access types.
8923
8924                --  The conversion of arrays of anonymous access types can lead
8925                --  to dangling pointers. AI-392 formalizes the accessibility
8926                --  checks that must be applied to such conversions to prevent
8927                --  out-of-scope references.
8928
8929             elsif
8930               (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type
8931                  or else
8932                Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type)
8933               and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base)
8934               and then
8935                 Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
8936             then
8937                if Type_Access_Level (Target_Type) <
8938                    Type_Access_Level (Opnd_Type)
8939                then
8940                   if In_Instance_Body then
8941                      Error_Msg_N ("?source array type " &
8942                        "has deeper accessibility level than target", Operand);
8943                      Error_Msg_N ("\?Program_Error will be raised at run time",
8944                          Operand);
8945                      Rewrite (N,
8946                        Make_Raise_Program_Error (Sloc (N),
8947                          Reason => PE_Accessibility_Check_Failed));
8948                      Set_Etype (N, Target_Type);
8949                      return False;
8950
8951                   --  Conversion not allowed because of accessibility levels
8952
8953                   else
8954                      Error_Msg_N ("source array type " &
8955                        "has deeper accessibility level than target", Operand);
8956                      return False;
8957                   end if;
8958                else
8959                   null;
8960                end if;
8961
8962             --  All other cases where component base types do not match
8963
8964             else
8965                Error_Msg_N
8966                  ("incompatible component types for array conversion",
8967                   Operand);
8968                return False;
8969             end if;
8970
8971             --  Check that component subtypes statically match. For numeric
8972             --  types this means that both must be either constrained or
8973             --  unconstrained. For enumeration types the bounds must match.
8974             --  All of this is checked in Subtypes_Statically_Match.
8975
8976             if not Subtypes_Statically_Match
8977                             (Target_Comp_Type, Opnd_Comp_Type)
8978             then
8979                Error_Msg_N
8980                  ("component subtypes must statically match", Operand);
8981                return False;
8982             end if;
8983          end if;
8984
8985          return True;
8986       end Valid_Array_Conversion;
8987
8988       -----------------------------
8989       -- Valid_Tagged_Conversion --
8990       -----------------------------
8991
8992       function Valid_Tagged_Conversion
8993         (Target_Type : Entity_Id;
8994          Opnd_Type   : Entity_Id) return Boolean
8995       is
8996       begin
8997          --  Upward conversions are allowed (RM 4.6(22))
8998
8999          if Covers (Target_Type, Opnd_Type)
9000            or else Is_Ancestor (Target_Type, Opnd_Type)
9001          then
9002             return True;
9003
9004          --  Downward conversion are allowed if the operand is class-wide
9005          --  (RM 4.6(23)).
9006
9007          elsif Is_Class_Wide_Type (Opnd_Type)
9008            and then Covers (Opnd_Type, Target_Type)
9009          then
9010             return True;
9011
9012          elsif Covers (Opnd_Type, Target_Type)
9013            or else Is_Ancestor (Opnd_Type, Target_Type)
9014          then
9015             return
9016               Conversion_Check (False,
9017                 "downward conversion of tagged objects not allowed");
9018
9019          --  Ada 2005 (AI-251): The conversion to/from interface types is
9020          --  always valid
9021
9022          elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then
9023             return True;
9024
9025          --  If the operand is a class-wide type obtained through a limited_
9026          --  with clause, and the context includes the non-limited view, use
9027          --  it to determine whether the conversion is legal.
9028
9029          elsif Is_Class_Wide_Type (Opnd_Type)
9030            and then From_With_Type (Opnd_Type)
9031            and then Present (Non_Limited_View (Etype (Opnd_Type)))
9032            and then Is_Interface (Non_Limited_View (Etype (Opnd_Type)))
9033          then
9034             return True;
9035
9036          elsif Is_Access_Type (Opnd_Type)
9037            and then Is_Interface (Directly_Designated_Type (Opnd_Type))
9038          then
9039             return True;
9040
9041          else
9042             Error_Msg_NE
9043               ("invalid tagged conversion, not compatible with}",
9044                N, First_Subtype (Opnd_Type));
9045             return False;
9046          end if;
9047       end Valid_Tagged_Conversion;
9048
9049    --  Start of processing for Valid_Conversion
9050
9051    begin
9052       Check_Parameterless_Call (Operand);
9053
9054       if Is_Overloaded (Operand) then
9055          declare
9056             I   : Interp_Index;
9057             I1  : Interp_Index;
9058             It  : Interp;
9059             It1 : Interp;
9060             N1  : Entity_Id;
9061
9062          begin
9063             --  Remove procedure calls, which syntactically cannot appear
9064             --  in this context, but which cannot be removed by type checking,
9065             --  because the context does not impose a type.
9066
9067             --  When compiling for VMS, spurious ambiguities can be produced
9068             --  when arithmetic operations have a literal operand and return
9069             --  System.Address or a descendant of it. These ambiguities are
9070             --  otherwise resolved by the context, but for conversions there
9071             --  is no context type and the removal of the spurious operations
9072             --  must be done explicitly here.
9073
9074             --  The node may be labelled overloaded, but still contain only
9075             --  one interpretation because others were discarded in previous
9076             --  filters. If this is the case, retain the single interpretation
9077             --  if legal.
9078
9079             Get_First_Interp (Operand, I, It);
9080             Opnd_Type := It.Typ;
9081             Get_Next_Interp (I, It);
9082
9083             if Present (It.Typ)
9084               and then Opnd_Type /= Standard_Void_Type
9085             then
9086                --  More than one candidate interpretation is available
9087
9088                Get_First_Interp (Operand, I, It);
9089                while Present (It.Typ) loop
9090                   if It.Typ = Standard_Void_Type then
9091                      Remove_Interp (I);
9092                   end if;
9093
9094                   if Present (System_Aux_Id)
9095                     and then Is_Descendent_Of_Address (It.Typ)
9096                   then
9097                      Remove_Interp (I);
9098                   end if;
9099
9100                   Get_Next_Interp (I, It);
9101                end loop;
9102             end if;
9103
9104             Get_First_Interp (Operand, I, It);
9105             I1  := I;
9106             It1 := It;
9107
9108             if No (It.Typ) then
9109                Error_Msg_N ("illegal operand in conversion", Operand);
9110                return False;
9111             end if;
9112
9113             Get_Next_Interp (I, It);
9114
9115             if Present (It.Typ) then
9116                N1  := It1.Nam;
9117                It1 :=  Disambiguate (Operand, I1, I, Any_Type);
9118
9119                if It1 = No_Interp then
9120                   Error_Msg_N ("ambiguous operand in conversion", Operand);
9121
9122                   Error_Msg_Sloc := Sloc (It.Nam);
9123                   Error_Msg_N ("\\possible interpretation#!", Operand);
9124
9125                   Error_Msg_Sloc := Sloc (N1);
9126                   Error_Msg_N ("\\possible interpretation#!", Operand);
9127
9128                   return False;
9129                end if;
9130             end if;
9131
9132             Set_Etype (Operand, It1.Typ);
9133             Opnd_Type := It1.Typ;
9134          end;
9135       end if;
9136
9137       --  Numeric types
9138
9139       if Is_Numeric_Type (Target_Type)  then
9140
9141          --  A universal fixed expression can be converted to any numeric type
9142
9143          if Opnd_Type = Universal_Fixed then
9144             return True;
9145
9146          --  Also no need to check when in an instance or inlined body, because
9147          --  the legality has been established when the template was analyzed.
9148          --  Furthermore, numeric conversions may occur where only a private
9149          --  view of the operand type is visible at the instantiation point.
9150          --  This results in a spurious error if we check that the operand type
9151          --  is a numeric type.
9152
9153          --  Note: in a previous version of this unit, the following tests were
9154          --  applied only for generated code (Comes_From_Source set to False),
9155          --  but in fact the test is required for source code as well, since
9156          --  this situation can arise in source code.
9157
9158          elsif In_Instance or else In_Inlined_Body then
9159                return True;
9160
9161          --  Otherwise we need the conversion check
9162
9163          else
9164             return Conversion_Check
9165                     (Is_Numeric_Type (Opnd_Type),
9166                      "illegal operand for numeric conversion");
9167          end if;
9168
9169       --  Array types
9170
9171       elsif Is_Array_Type (Target_Type) then
9172          if not Is_Array_Type (Opnd_Type)
9173            or else Opnd_Type = Any_Composite
9174            or else Opnd_Type = Any_String
9175          then
9176             Error_Msg_N
9177               ("illegal operand for array conversion", Operand);
9178             return False;
9179          else
9180             return Valid_Array_Conversion;
9181          end if;
9182
9183       --  Ada 2005 (AI-251): Anonymous access types where target references an
9184       --  interface type.
9185
9186       elsif (Ekind (Target_Type) = E_General_Access_Type
9187               or else
9188              Ekind (Target_Type) = E_Anonymous_Access_Type)
9189         and then Is_Interface (Directly_Designated_Type (Target_Type))
9190       then
9191          --  Check the static accessibility rule of 4.6(17). Note that the
9192          --  check is not enforced when within an instance body, since the RM
9193          --  requires such cases to be caught at run time.
9194
9195          if Ekind (Target_Type) /= E_Anonymous_Access_Type then
9196             if Type_Access_Level (Opnd_Type) >
9197                Type_Access_Level (Target_Type)
9198             then
9199                --  In an instance, this is a run-time check, but one we know
9200                --  will fail, so generate an appropriate warning. The raise
9201                --  will be generated by Expand_N_Type_Conversion.
9202
9203                if In_Instance_Body then
9204                   Error_Msg_N
9205                     ("?cannot convert local pointer to non-local access type",
9206                      Operand);
9207                   Error_Msg_N
9208                     ("\?Program_Error will be raised at run time", Operand);
9209                else
9210                   Error_Msg_N
9211                     ("cannot convert local pointer to non-local access type",
9212                      Operand);
9213                   return False;
9214                end if;
9215
9216             --  Special accessibility checks are needed in the case of access
9217             --  discriminants declared for a limited type.
9218
9219             elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
9220               and then not Is_Local_Anonymous_Access (Opnd_Type)
9221             then
9222                --  When the operand is a selected access discriminant the check
9223                --  needs to be made against the level of the object denoted by
9224                --  the prefix of the selected name. (Object_Access_Level
9225                --  handles checking the prefix of the operand for this case.)
9226
9227                if Nkind (Operand) = N_Selected_Component
9228                  and then Object_Access_Level (Operand) >
9229                           Type_Access_Level (Target_Type)
9230                then
9231                   --  In an instance, this is a run-time check, but one we
9232                   --  know will fail, so generate an appropriate warning.
9233                   --  The raise will be generated by Expand_N_Type_Conversion.
9234
9235                   if In_Instance_Body then
9236                      Error_Msg_N
9237                        ("?cannot convert access discriminant to non-local" &
9238                         " access type", Operand);
9239                      Error_Msg_N
9240                        ("\?Program_Error will be raised at run time", Operand);
9241                   else
9242                      Error_Msg_N
9243                        ("cannot convert access discriminant to non-local" &
9244                         " access type", Operand);
9245                      return False;
9246                   end if;
9247                end if;
9248
9249                --  The case of a reference to an access discriminant from
9250                --  within a limited type declaration (which will appear as
9251                --  a discriminal) is always illegal because the level of the
9252                --  discriminant is considered to be deeper than any (nameable)
9253                --  access type.
9254
9255                if Is_Entity_Name (Operand)
9256                  and then not Is_Local_Anonymous_Access (Opnd_Type)
9257                  and then (Ekind (Entity (Operand)) = E_In_Parameter
9258                             or else Ekind (Entity (Operand)) = E_Constant)
9259                  and then Present (Discriminal_Link (Entity (Operand)))
9260                then
9261                   Error_Msg_N
9262                     ("discriminant has deeper accessibility level than target",
9263                      Operand);
9264                   return False;
9265                end if;
9266             end if;
9267          end if;
9268
9269          return True;
9270
9271       --  General and anonymous access types
9272
9273       elsif (Ekind (Target_Type) = E_General_Access_Type
9274         or else Ekind (Target_Type) = E_Anonymous_Access_Type)
9275           and then
9276             Conversion_Check
9277               (Is_Access_Type (Opnd_Type)
9278                  and then Ekind (Opnd_Type) /=
9279                    E_Access_Subprogram_Type
9280                  and then Ekind (Opnd_Type) /=
9281                    E_Access_Protected_Subprogram_Type,
9282                "must be an access-to-object type")
9283       then
9284          if Is_Access_Constant (Opnd_Type)
9285            and then not Is_Access_Constant (Target_Type)
9286          then
9287             Error_Msg_N
9288               ("access-to-constant operand type not allowed", Operand);
9289             return False;
9290          end if;
9291
9292          --  Check the static accessibility rule of 4.6(17). Note that the
9293          --  check is not enforced when within an instance body, since the RM
9294          --  requires such cases to be caught at run time.
9295
9296          if Ekind (Target_Type) /= E_Anonymous_Access_Type
9297            or else Is_Local_Anonymous_Access (Target_Type)
9298          then
9299             if Type_Access_Level (Opnd_Type)
9300               > Type_Access_Level (Target_Type)
9301             then
9302                --  In an instance, this is a run-time check, but one we
9303                --  know will fail, so generate an appropriate warning.
9304                --  The raise will be generated by Expand_N_Type_Conversion.
9305
9306                if In_Instance_Body then
9307                   Error_Msg_N
9308                     ("?cannot convert local pointer to non-local access type",
9309                      Operand);
9310                   Error_Msg_N
9311                     ("\?Program_Error will be raised at run time", Operand);
9312
9313                else
9314                   --  Avoid generation of spurious error message
9315
9316                   if not Error_Posted (N) then
9317                      Error_Msg_N
9318                       ("cannot convert local pointer to non-local access type",
9319                        Operand);
9320                   end if;
9321
9322                   return False;
9323                end if;
9324
9325             --  Special accessibility checks are needed in the case of access
9326             --  discriminants declared for a limited type.
9327
9328             elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
9329               and then not Is_Local_Anonymous_Access (Opnd_Type)
9330             then
9331
9332                --  When the operand is a selected access discriminant the check
9333                --  needs to be made against the level of the object denoted by
9334                --  the prefix of the selected name. (Object_Access_Level
9335                --  handles checking the prefix of the operand for this case.)
9336
9337                if Nkind (Operand) = N_Selected_Component
9338                  and then Object_Access_Level (Operand) >
9339                           Type_Access_Level (Target_Type)
9340                then
9341                   --  In an instance, this is a run-time check, but one we
9342                   --  know will fail, so generate an appropriate warning.
9343                   --  The raise will be generated by Expand_N_Type_Conversion.
9344
9345                   if In_Instance_Body then
9346                      Error_Msg_N
9347                        ("?cannot convert access discriminant to non-local" &
9348                         " access type", Operand);
9349                      Error_Msg_N
9350                        ("\?Program_Error will be raised at run time",
9351                         Operand);
9352
9353                   else
9354                      Error_Msg_N
9355                        ("cannot convert access discriminant to non-local" &
9356                         " access type", Operand);
9357                      return False;
9358                   end if;
9359                end if;
9360
9361                --  The case of a reference to an access discriminant from
9362                --  within a limited type declaration (which will appear as
9363                --  a discriminal) is always illegal because the level of the
9364                --  discriminant is considered to be deeper than any (nameable)
9365                --  access type.
9366
9367                if Is_Entity_Name (Operand)
9368                  and then (Ekind (Entity (Operand)) = E_In_Parameter
9369                             or else Ekind (Entity (Operand)) = E_Constant)
9370                  and then Present (Discriminal_Link (Entity (Operand)))
9371                then
9372                   Error_Msg_N
9373                     ("discriminant has deeper accessibility level than target",
9374                      Operand);
9375                   return False;
9376                end if;
9377             end if;
9378          end if;
9379
9380          declare
9381             function Full_Designated_Type (T : Entity_Id) return Entity_Id;
9382             --  Helper function to handle limited views
9383
9384             --------------------------
9385             -- Full_Designated_Type --
9386             --------------------------
9387
9388             function Full_Designated_Type (T : Entity_Id) return Entity_Id is
9389                Desig : constant Entity_Id := Designated_Type (T);
9390             begin
9391                if From_With_Type (Desig)
9392                  and then Is_Incomplete_Type (Desig)
9393                  and then Present (Non_Limited_View (Desig))
9394                then
9395                   return Non_Limited_View (Desig);
9396                else
9397                   return Desig;
9398                end if;
9399             end Full_Designated_Type;
9400
9401             Target : constant Entity_Id := Full_Designated_Type (Target_Type);
9402             Opnd   : constant Entity_Id := Full_Designated_Type (Opnd_Type);
9403
9404             Same_Base : constant Boolean :=
9405                           Base_Type (Target) = Base_Type (Opnd);
9406
9407          begin
9408             if Is_Tagged_Type (Target) then
9409                return Valid_Tagged_Conversion (Target, Opnd);
9410
9411             else
9412                if not Same_Base then
9413                   Error_Msg_NE
9414                     ("target designated type not compatible with }",
9415                      N, Base_Type (Opnd));
9416                   return False;
9417
9418                --  Ada 2005 AI-384: legality rule is symmetric in both
9419                --  designated types. The conversion is legal (with possible
9420                --  constraint check) if either designated type is
9421                --  unconstrained.
9422
9423                elsif Subtypes_Statically_Match (Target, Opnd)
9424                  or else
9425                    (Has_Discriminants (Target)
9426                      and then
9427                       (not Is_Constrained (Opnd)
9428                         or else not Is_Constrained (Target)))
9429                then
9430                   return True;
9431
9432                else
9433                   Error_Msg_NE
9434                     ("target designated subtype not compatible with }",
9435                      N, Opnd);
9436                   return False;
9437                end if;
9438             end if;
9439          end;
9440
9441       --  Access to subprogram types. If the operand is an access parameter,
9442       --  the type has a deeper accessibility that any master, and cannot
9443       --  be assigned.
9444
9445       elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
9446                or else
9447              Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
9448         and then No (Corresponding_Remote_Type (Opnd_Type))
9449       then
9450          if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type
9451            and then Is_Entity_Name (Operand)
9452            and then Ekind (Entity (Operand)) = E_In_Parameter
9453          then
9454             Error_Msg_N
9455               ("illegal attempt to store anonymous access to subprogram",
9456                Operand);
9457             Error_Msg_N
9458               ("\value has deeper accessibility than any master " &
9459                "(RM 3.10.2 (13))",
9460                Operand);
9461
9462             Error_Msg_NE
9463              ("\use named access type for& instead of access parameter",
9464                Operand, Entity (Operand));
9465          end if;
9466
9467          --  Check that the designated types are subtype conformant
9468
9469          Check_Subtype_Conformant (New_Id  => Designated_Type (Target_Type),
9470                                    Old_Id  => Designated_Type (Opnd_Type),
9471                                    Err_Loc => N);
9472
9473          --  Check the static accessibility rule of 4.6(20)
9474
9475          if Type_Access_Level (Opnd_Type) >
9476             Type_Access_Level (Target_Type)
9477          then
9478             Error_Msg_N
9479               ("operand type has deeper accessibility level than target",
9480                Operand);
9481
9482          --  Check that if the operand type is declared in a generic body,
9483          --  then the target type must be declared within that same body
9484          --  (enforces last sentence of 4.6(20)).
9485
9486          elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
9487             declare
9488                O_Gen : constant Node_Id :=
9489                          Enclosing_Generic_Body (Opnd_Type);
9490
9491                T_Gen : Node_Id;
9492
9493             begin
9494                T_Gen := Enclosing_Generic_Body (Target_Type);
9495                while Present (T_Gen) and then T_Gen /= O_Gen loop
9496                   T_Gen := Enclosing_Generic_Body (T_Gen);
9497                end loop;
9498
9499                if T_Gen /= O_Gen then
9500                   Error_Msg_N
9501                     ("target type must be declared in same generic body"
9502                      & " as operand type", N);
9503                end if;
9504             end;
9505          end if;
9506
9507          return True;
9508
9509       --  Remote subprogram access types
9510
9511       elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
9512         and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
9513       then
9514          --  It is valid to convert from one RAS type to another provided
9515          --  that their specification statically match.
9516
9517          Check_Subtype_Conformant
9518            (New_Id  =>
9519               Designated_Type (Corresponding_Remote_Type (Target_Type)),
9520             Old_Id  =>
9521               Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
9522             Err_Loc =>
9523               N);
9524          return True;
9525
9526       --  If both are tagged types, check legality of view conversions
9527
9528       elsif Is_Tagged_Type (Target_Type)
9529         and then Is_Tagged_Type (Opnd_Type)
9530       then
9531          return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
9532
9533       --  Types derived from the same root type are convertible
9534
9535       elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
9536          return True;
9537
9538       --  In an instance or an inlined body, there may be inconsistent
9539       --  views of the same type, or of types derived from a common root.
9540
9541       elsif (In_Instance or In_Inlined_Body)
9542         and then
9543            Root_Type (Underlying_Type (Target_Type)) =
9544            Root_Type (Underlying_Type (Opnd_Type))
9545       then
9546          return True;
9547
9548       --  Special check for common access type error case
9549
9550       elsif Ekind (Target_Type) = E_Access_Type
9551          and then Is_Access_Type (Opnd_Type)
9552       then
9553          Error_Msg_N ("target type must be general access type!", N);
9554          Error_Msg_NE ("add ALL to }!", N, Target_Type);
9555
9556          return False;
9557
9558       else
9559          Error_Msg_NE ("invalid conversion, not compatible with }",
9560            N, Opnd_Type);
9561
9562          return False;
9563       end if;
9564    end Valid_Conversion;
9565
9566 end Sem_Res;