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