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