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.
3983
3984          if (Is_Class_Wide_Type (Etype (Expression (E)))
3985               or else Is_Class_Wide_Type (Etype (E)))
3986            and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
3987          then
3988             Wrong_Type (Expression (E), Etype (E));
3989          end if;
3990
3991          --  A special accessibility check is needed for allocators that
3992          --  constrain access discriminants. The level of the type of the
3993          --  expression used to constrain an access discriminant cannot be
3994          --  deeper than the type of the allocator (in contrast to access
3995          --  parameters, where the level of the actual can be arbitrary).
3996
3997          --  We can't use Valid_Conversion to perform this check because
3998          --  in general the type of the allocator is unrelated to the type
3999          --  of the access discriminant.
4000
4001          if Ekind (Typ) /= E_Anonymous_Access_Type
4002            or else Is_Local_Anonymous_Access (Typ)
4003          then
4004             Subtyp := Entity (Subtype_Mark (E));
4005
4006             Aggr := Original_Node (Expression (E));
4007
4008             if Has_Discriminants (Subtyp)
4009               and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate)
4010             then
4011                Discrim := First_Discriminant (Base_Type (Subtyp));
4012
4013                --  Get the first component expression of the aggregate
4014
4015                if Present (Expressions (Aggr)) then
4016                   Disc_Exp := First (Expressions (Aggr));
4017
4018                elsif Present (Component_Associations (Aggr)) then
4019                   Assoc := First (Component_Associations (Aggr));
4020
4021                   if Present (Assoc) then
4022                      Disc_Exp := Expression (Assoc);
4023                   else
4024                      Disc_Exp := Empty;
4025                   end if;
4026
4027                else
4028                   Disc_Exp := Empty;
4029                end if;
4030
4031                while Present (Discrim) and then Present (Disc_Exp) loop
4032                   if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
4033                      Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ);
4034                   end if;
4035
4036                   Next_Discriminant (Discrim);
4037
4038                   if Present (Discrim) then
4039                      if Present (Assoc) then
4040                         Next (Assoc);
4041                         Disc_Exp := Expression (Assoc);
4042
4043                      elsif Present (Next (Disc_Exp)) then
4044                         Next (Disc_Exp);
4045
4046                      else
4047                         Assoc := First (Component_Associations (Aggr));
4048
4049                         if Present (Assoc) then
4050                            Disc_Exp := Expression (Assoc);
4051                         else
4052                            Disc_Exp := Empty;
4053                         end if;
4054                      end if;
4055                   end if;
4056                end loop;
4057             end if;
4058          end if;
4059
4060       --  For a subtype mark or subtype indication, freeze the subtype
4061
4062       else
4063          Freeze_Expression (E);
4064
4065          if Is_Access_Constant (Typ) and then not No_Initialization (N) then
4066             Error_Msg_N
4067               ("initialization required for access-to-constant allocator", N);
4068          end if;
4069
4070          --  A special accessibility check is needed for allocators that
4071          --  constrain access discriminants. The level of the type of the
4072          --  expression used to constrain an access discriminant cannot be
4073          --  deeper than the type of the allocator (in contrast to access
4074          --  parameters, where the level of the actual can be arbitrary).
4075          --  We can't use Valid_Conversion to perform this check because
4076          --  in general the type of the allocator is unrelated to the type
4077          --  of the access discriminant.
4078
4079          if Nkind (Original_Node (E)) = N_Subtype_Indication
4080            and then (Ekind (Typ) /= E_Anonymous_Access_Type
4081                       or else Is_Local_Anonymous_Access (Typ))
4082          then
4083             Subtyp := Entity (Subtype_Mark (Original_Node (E)));
4084
4085             if Has_Discriminants (Subtyp) then
4086                Discrim := First_Discriminant (Base_Type (Subtyp));
4087                Constr := First (Constraints (Constraint (Original_Node (E))));
4088                while Present (Discrim) and then Present (Constr) loop
4089                   if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
4090                      if Nkind (Constr) = N_Discriminant_Association then
4091                         Disc_Exp := Original_Node (Expression (Constr));
4092                      else
4093                         Disc_Exp := Original_Node (Constr);
4094                      end if;
4095
4096                      Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ);
4097                   end if;
4098
4099                   Next_Discriminant (Discrim);
4100                   Next (Constr);
4101                end loop;
4102             end if;
4103          end if;
4104       end if;
4105
4106       --  Ada 2005 (AI-344): A class-wide allocator requires an accessibility
4107       --  check that the level of the type of the created object is not deeper
4108       --  than the level of the allocator's access type, since extensions can
4109       --  now occur at deeper levels than their ancestor types. This is a
4110       --  static accessibility level check; a run-time check is also needed in
4111       --  the case of an initialized allocator with a class-wide argument (see
4112       --  Expand_Allocator_Expression).
4113
4114       if Ada_Version >= Ada_05
4115         and then Is_Class_Wide_Type (Designated_Type (Typ))
4116       then
4117          declare
4118             Exp_Typ : Entity_Id;
4119
4120          begin
4121             if Nkind (E) = N_Qualified_Expression then
4122                Exp_Typ := Etype (E);
4123             elsif Nkind (E) = N_Subtype_Indication then
4124                Exp_Typ := Entity (Subtype_Mark (Original_Node (E)));
4125             else
4126                Exp_Typ := Entity (E);
4127             end if;
4128
4129             if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then
4130                if In_Instance_Body then
4131                   Error_Msg_N ("?type in allocator has deeper level than" &
4132                                " designated class-wide type", E);
4133                   Error_Msg_N ("\?Program_Error will be raised at run time",
4134                                E);
4135                   Rewrite (N,
4136                     Make_Raise_Program_Error (Sloc (N),
4137                       Reason => PE_Accessibility_Check_Failed));
4138                   Set_Etype (N, Typ);
4139
4140                --  Do not apply Ada 2005 accessibility checks on a class-wide
4141                --  allocator if the type given in the allocator is a formal
4142                --  type. A run-time check will be performed in the instance.
4143
4144                elsif not Is_Generic_Type (Exp_Typ) then
4145                   Error_Msg_N ("type in allocator has deeper level than" &
4146                                " designated class-wide type", E);
4147                end if;
4148             end if;
4149          end;
4150       end if;
4151
4152       --  Check for allocation from an empty storage pool
4153
4154       if No_Pool_Assigned (Typ) then
4155          declare
4156             Loc : constant Source_Ptr := Sloc (N);
4157          begin
4158             Error_Msg_N ("?allocation from empty storage pool!", N);
4159             Error_Msg_N ("\?Storage_Error will be raised at run time!", N);
4160             Insert_Action (N,
4161               Make_Raise_Storage_Error (Loc,
4162                 Reason => SE_Empty_Storage_Pool));
4163          end;
4164
4165       --  If the context is an unchecked conversion, as may happen within
4166       --  an inlined subprogram, the allocator is being resolved with its
4167       --  own anonymous type. In that case, if the target type has a specific
4168       --  storage pool, it must be inherited explicitly by the allocator type.
4169
4170       elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
4171         and then No (Associated_Storage_Pool (Typ))
4172       then
4173          Set_Associated_Storage_Pool
4174            (Typ, Associated_Storage_Pool (Etype (Parent (N))));
4175       end if;
4176
4177       --  An erroneous allocator may be rewritten as a raise Program_Error
4178       --  statement.
4179
4180       if Nkind (N) = N_Allocator then
4181
4182          --  An anonymous access discriminant is the definition of a
4183          --  coextension.
4184
4185          if Ekind (Typ) = E_Anonymous_Access_Type
4186            and then Nkind (Associated_Node_For_Itype (Typ)) =
4187                       N_Discriminant_Specification
4188          then
4189             --  Avoid marking an allocator as a dynamic coextension if it is
4190             --  within a static construct.
4191
4192             if not Is_Static_Coextension (N) then
4193                Set_Is_Dynamic_Coextension (N);
4194             end if;
4195
4196          --  Cleanup for potential static coextensions
4197
4198          else
4199             Set_Is_Dynamic_Coextension (N, False);
4200             Set_Is_Static_Coextension  (N, False);
4201          end if;
4202
4203          --  There is no need to propagate any nested coextensions if they
4204          --  are marked as static since they will be rewritten on the spot.
4205
4206          if not Is_Static_Coextension (N) then
4207             Propagate_Coextensions (N);
4208          end if;
4209       end if;
4210    end Resolve_Allocator;
4211
4212    ---------------------------
4213    -- Resolve_Arithmetic_Op --
4214    ---------------------------
4215
4216    --  Used for resolving all arithmetic operators except exponentiation
4217
4218    procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
4219       L   : constant Node_Id := Left_Opnd (N);
4220       R   : constant Node_Id := Right_Opnd (N);
4221       TL  : constant Entity_Id := Base_Type (Etype (L));
4222       TR  : constant Entity_Id := Base_Type (Etype (R));
4223       T   : Entity_Id;
4224       Rop : Node_Id;
4225
4226       B_Typ : constant Entity_Id := Base_Type (Typ);
4227       --  We do the resolution using the base type, because intermediate values
4228       --  in expressions always are of the base type, not a subtype of it.
4229
4230       function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean;
4231       --  Returns True if N is in a context that expects "any real type"
4232
4233       function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
4234       --  Return True iff given type is Integer or universal real/integer
4235
4236       procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
4237       --  Choose type of integer literal in fixed-point operation to conform
4238       --  to available fixed-point type. T is the type of the other operand,
4239       --  which is needed to determine the expected type of N.
4240
4241       procedure Set_Operand_Type (N : Node_Id);
4242       --  Set operand type to T if universal
4243
4244       -------------------------------
4245       -- Expected_Type_Is_Any_Real --
4246       -------------------------------
4247
4248       function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is
4249       begin
4250          --  N is the expression after "delta" in a fixed_point_definition;
4251          --  see RM-3.5.9(6):
4252
4253          return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition,
4254                                       N_Decimal_Fixed_Point_Definition,
4255
4256          --  N is one of the bounds in a real_range_specification;
4257          --  see RM-3.5.7(5):
4258
4259                                       N_Real_Range_Specification,
4260
4261          --  N is the expression of a delta_constraint;
4262          --  see RM-J.3(3):
4263
4264                                       N_Delta_Constraint);
4265       end Expected_Type_Is_Any_Real;
4266
4267       -----------------------------
4268       -- Is_Integer_Or_Universal --
4269       -----------------------------
4270
4271       function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
4272          T     : Entity_Id;
4273          Index : Interp_Index;
4274          It    : Interp;
4275
4276       begin
4277          if not Is_Overloaded (N) then
4278             T := Etype (N);
4279             return Base_Type (T) = Base_Type (Standard_Integer)
4280               or else T = Universal_Integer
4281               or else T = Universal_Real;
4282          else
4283             Get_First_Interp (N, Index, It);
4284             while Present (It.Typ) loop
4285                if Base_Type (It.Typ) = Base_Type (Standard_Integer)
4286                  or else It.Typ = Universal_Integer
4287                  or else It.Typ = Universal_Real
4288                then
4289                   return True;
4290                end if;
4291
4292                Get_Next_Interp (Index, It);
4293             end loop;
4294          end if;
4295
4296          return False;
4297       end Is_Integer_Or_Universal;
4298
4299       ----------------------------
4300       -- Set_Mixed_Mode_Operand --
4301       ----------------------------
4302
4303       procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
4304          Index : Interp_Index;
4305          It    : Interp;
4306
4307       begin
4308          if Universal_Interpretation (N) = Universal_Integer then
4309
4310             --  A universal integer literal is resolved as standard integer
4311             --  except in the case of a fixed-point result, where we leave it
4312             --  as universal (to be handled by Exp_Fixd later on)
4313
4314             if Is_Fixed_Point_Type (T) then
4315                Resolve (N, Universal_Integer);
4316             else
4317                Resolve (N, Standard_Integer);
4318             end if;
4319
4320          elsif Universal_Interpretation (N) = Universal_Real
4321            and then (T = Base_Type (Standard_Integer)
4322                       or else T = Universal_Integer
4323                       or else T = Universal_Real)
4324          then
4325             --  A universal real can appear in a fixed-type context. We resolve
4326             --  the literal with that context, even though this might raise an
4327             --  exception prematurely (the other operand may be zero).
4328
4329             Resolve (N, B_Typ);
4330
4331          elsif Etype (N) = Base_Type (Standard_Integer)
4332            and then T = Universal_Real
4333            and then Is_Overloaded (N)
4334          then
4335             --  Integer arg in mixed-mode operation. Resolve with universal
4336             --  type, in case preference rule must be applied.
4337
4338             Resolve (N, Universal_Integer);
4339
4340          elsif Etype (N) = T
4341            and then B_Typ /= Universal_Fixed
4342          then
4343             --  Not a mixed-mode operation, resolve with context
4344
4345             Resolve (N, B_Typ);
4346
4347          elsif Etype (N) = Any_Fixed then
4348
4349             --  N may itself be a mixed-mode operation, so use context type
4350
4351             Resolve (N, B_Typ);
4352
4353          elsif Is_Fixed_Point_Type (T)
4354            and then B_Typ = Universal_Fixed
4355            and then Is_Overloaded (N)
4356          then
4357             --  Must be (fixed * fixed) operation, operand must have one
4358             --  compatible interpretation.
4359
4360             Resolve (N, Any_Fixed);
4361
4362          elsif Is_Fixed_Point_Type (B_Typ)
4363            and then (T = Universal_Real
4364                       or else Is_Fixed_Point_Type (T))
4365            and then Is_Overloaded (N)
4366          then
4367             --  C * F(X) in a fixed context, where C is a real literal or a
4368             --  fixed-point expression. F must have either a fixed type
4369             --  interpretation or an integer interpretation, but not both.
4370
4371             Get_First_Interp (N, Index, It);
4372             while Present (It.Typ) loop
4373                if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
4374
4375                   if Analyzed (N) then
4376                      Error_Msg_N ("ambiguous operand in fixed operation", N);
4377                   else
4378                      Resolve (N, Standard_Integer);
4379                   end if;
4380
4381                elsif Is_Fixed_Point_Type (It.Typ) then
4382
4383                   if Analyzed (N) then
4384                      Error_Msg_N ("ambiguous operand in fixed operation", N);
4385                   else
4386                      Resolve (N, It.Typ);
4387                   end if;
4388                end if;
4389
4390                Get_Next_Interp (Index, It);
4391             end loop;
4392
4393             --  Reanalyze the literal with the fixed type of the context. If
4394             --  context is Universal_Fixed, we are within a conversion, leave
4395             --  the literal as a universal real because there is no usable
4396             --  fixed type, and the target of the conversion plays no role in
4397             --  the resolution.
4398
4399             declare
4400                Op2 : Node_Id;
4401                T2  : Entity_Id;
4402
4403             begin
4404                if N = L then
4405                   Op2 := R;
4406                else
4407                   Op2 := L;
4408                end if;
4409
4410                if B_Typ = Universal_Fixed
4411                   and then Nkind (Op2) = N_Real_Literal
4412                then
4413                   T2 := Universal_Real;
4414                else
4415                   T2 := B_Typ;
4416                end if;
4417
4418                Set_Analyzed (Op2, False);
4419                Resolve (Op2, T2);
4420             end;
4421
4422          else
4423             Resolve (N);
4424          end if;
4425       end Set_Mixed_Mode_Operand;
4426
4427       ----------------------
4428       -- Set_Operand_Type --
4429       ----------------------
4430
4431       procedure Set_Operand_Type (N : Node_Id) is
4432       begin
4433          if Etype (N) = Universal_Integer
4434            or else Etype (N) = Universal_Real
4435          then
4436             Set_Etype (N, T);
4437          end if;
4438       end Set_Operand_Type;
4439
4440    --  Start of processing for Resolve_Arithmetic_Op
4441
4442    begin
4443       if Comes_From_Source (N)
4444         and then Ekind (Entity (N)) = E_Function
4445         and then Is_Imported (Entity (N))
4446         and then Is_Intrinsic_Subprogram (Entity (N))
4447       then
4448          Resolve_Intrinsic_Operator (N, Typ);
4449          return;
4450
4451       --  Special-case for mixed-mode universal expressions or fixed point
4452       --  type operation: each argument is resolved separately. The same
4453       --  treatment is required if one of the operands of a fixed point
4454       --  operation is universal real, since in this case we don't do a
4455       --  conversion to a specific fixed-point type (instead the expander
4456       --  takes care of the case).
4457
4458       elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
4459         and then Present (Universal_Interpretation (L))
4460         and then Present (Universal_Interpretation (R))
4461       then
4462          Resolve (L, Universal_Interpretation (L));
4463          Resolve (R, Universal_Interpretation (R));
4464          Set_Etype (N, B_Typ);
4465
4466       elsif (B_Typ = Universal_Real
4467               or else Etype (N) = Universal_Fixed
4468               or else (Etype (N) = Any_Fixed
4469                         and then Is_Fixed_Point_Type (B_Typ))
4470               or else (Is_Fixed_Point_Type (B_Typ)
4471                         and then (Is_Integer_Or_Universal (L)
4472                                    or else
4473                                   Is_Integer_Or_Universal (R))))
4474         and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
4475       then
4476          if TL = Universal_Integer or else TR = Universal_Integer then
4477             Check_For_Visible_Operator (N, B_Typ);
4478          end if;
4479
4480          --  If context is a fixed type and one operand is integer, the
4481          --  other is resolved with the type of the context.
4482
4483          if Is_Fixed_Point_Type (B_Typ)
4484            and then (Base_Type (TL) = Base_Type (Standard_Integer)
4485                       or else TL = Universal_Integer)
4486          then
4487             Resolve (R, B_Typ);
4488             Resolve (L, TL);
4489
4490          elsif Is_Fixed_Point_Type (B_Typ)
4491            and then (Base_Type (TR) = Base_Type (Standard_Integer)
4492                       or else TR = Universal_Integer)
4493          then
4494             Resolve (L, B_Typ);
4495             Resolve (R, TR);
4496
4497          else
4498             Set_Mixed_Mode_Operand (L, TR);
4499             Set_Mixed_Mode_Operand (R, TL);
4500          end if;
4501
4502          --  Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed
4503          --  multiplying operators from being used when the expected type is
4504          --  also universal_fixed. Note that B_Typ will be Universal_Fixed in
4505          --  some cases where the expected type is actually Any_Real;
4506          --  Expected_Type_Is_Any_Real takes care of that case.
4507
4508          if Etype (N) = Universal_Fixed
4509            or else Etype (N) = Any_Fixed
4510          then
4511             if B_Typ = Universal_Fixed
4512               and then not Expected_Type_Is_Any_Real (N)
4513               and then not Nkind_In (Parent (N), N_Type_Conversion,
4514                                                  N_Unchecked_Type_Conversion)
4515             then
4516                Error_Msg_N ("type cannot be determined from context!", N);
4517                Error_Msg_N ("\explicit conversion to result type required", N);
4518
4519                Set_Etype (L, Any_Type);
4520                Set_Etype (R, Any_Type);
4521
4522             else
4523                if Ada_Version = Ada_83
4524                  and then Etype (N) = Universal_Fixed
4525                  and then not
4526                    Nkind_In (Parent (N), N_Type_Conversion,
4527                                          N_Unchecked_Type_Conversion)
4528                then
4529                   Error_Msg_N
4530                     ("(Ada 83) fixed-point operation "
4531                      & "needs explicit conversion", N);
4532                end if;
4533
4534                --  The expected type is "any real type" in contexts like
4535                --    type T is delta <universal_fixed-expression> ...
4536                --  in which case we need to set the type to Universal_Real
4537                --  so that static expression evaluation will work properly.
4538
4539                if Expected_Type_Is_Any_Real (N) then
4540                   Set_Etype (N, Universal_Real);
4541                else
4542                   Set_Etype (N, B_Typ);
4543                end if;
4544             end if;
4545
4546          elsif Is_Fixed_Point_Type (B_Typ)
4547            and then (Is_Integer_Or_Universal (L)
4548                        or else Nkind (L) = N_Real_Literal
4549                        or else Nkind (R) = N_Real_Literal
4550                        or else Is_Integer_Or_Universal (R))
4551          then
4552             Set_Etype (N, B_Typ);
4553
4554          elsif Etype (N) = Any_Fixed then
4555
4556             --  If no previous errors, this is only possible if one operand
4557             --  is overloaded and the context is universal. Resolve as such.
4558
4559             Set_Etype (N, B_Typ);
4560          end if;
4561
4562       else
4563          if (TL = Universal_Integer or else TL = Universal_Real)
4564               and then
4565             (TR = Universal_Integer or else TR = Universal_Real)
4566          then
4567             Check_For_Visible_Operator (N, B_Typ);
4568          end if;
4569
4570          --  If the context is Universal_Fixed and the operands are also
4571          --  universal fixed, this is an error, unless there is only one
4572          --  applicable fixed_point type (usually duration).
4573
4574          if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then
4575             T := Unique_Fixed_Point_Type (N);
4576
4577             if T  = Any_Type then
4578                Set_Etype (N, T);
4579                return;
4580             else
4581                Resolve (L, T);
4582                Resolve (R, T);
4583             end if;
4584
4585          else
4586             Resolve (L, B_Typ);
4587             Resolve (R, B_Typ);
4588          end if;
4589
4590          --  If one of the arguments was resolved to a non-universal type.
4591          --  label the result of the operation itself with the same type.
4592          --  Do the same for the universal argument, if any.
4593
4594          T := Intersect_Types (L, R);
4595          Set_Etype (N, Base_Type (T));
4596          Set_Operand_Type (L);
4597          Set_Operand_Type (R);
4598       end if;
4599
4600       Generate_Operator_Reference (N, Typ);
4601       Eval_Arithmetic_Op (N);
4602
4603       --  Set overflow and division checking bit. Much cleverer code needed
4604       --  here eventually and perhaps the Resolve routines should be separated
4605       --  for the various arithmetic operations, since they will need
4606       --  different processing. ???
4607
4608       if Nkind (N) in N_Op then
4609          if not Overflow_Checks_Suppressed (Etype (N)) then
4610             Enable_Overflow_Check (N);
4611          end if;
4612
4613          --  Give warning if explicit division by zero
4614
4615          if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod)
4616            and then not Division_Checks_Suppressed (Etype (N))
4617          then
4618             Rop := Right_Opnd (N);
4619
4620             if Compile_Time_Known_Value (Rop)
4621               and then ((Is_Integer_Type (Etype (Rop))
4622                            and then Expr_Value (Rop) = Uint_0)
4623                           or else
4624                         (Is_Real_Type (Etype (Rop))
4625                            and then Expr_Value_R (Rop) = Ureal_0))
4626             then
4627                --  Specialize the warning message according to the operation
4628
4629                case Nkind (N) is
4630                   when N_Op_Divide =>
4631                      Apply_Compile_Time_Constraint_Error
4632                        (N, "division by zero?", CE_Divide_By_Zero,
4633                         Loc => Sloc (Right_Opnd (N)));
4634
4635                   when N_Op_Rem =>
4636                      Apply_Compile_Time_Constraint_Error
4637                        (N, "rem with zero divisor?", CE_Divide_By_Zero,
4638                         Loc => Sloc (Right_Opnd (N)));
4639
4640                   when N_Op_Mod =>
4641                      Apply_Compile_Time_Constraint_Error
4642                        (N, "mod with zero divisor?", CE_Divide_By_Zero,
4643                         Loc => Sloc (Right_Opnd (N)));
4644
4645                   --  Division by zero can only happen with division, rem,
4646                   --  and mod operations.
4647
4648                   when others =>
4649                      raise Program_Error;
4650                end case;
4651
4652             --  Otherwise just set the flag to check at run time
4653
4654             else
4655                Activate_Division_Check (N);
4656             end if;
4657          end if;
4658
4659          --  If Restriction No_Implicit_Conditionals is active, then it is
4660          --  violated if either operand can be negative for mod, or for rem
4661          --  if both operands can be negative.
4662
4663          if Restrictions.Set (No_Implicit_Conditionals)
4664            and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
4665          then
4666             declare
4667                Lo : Uint;
4668                Hi : Uint;
4669                OK : Boolean;
4670
4671                LNeg : Boolean;
4672                RNeg : Boolean;
4673                --  Set if corresponding operand might be negative
4674
4675             begin
4676                Determine_Range (Left_Opnd (N), OK, Lo, Hi);
4677                LNeg := (not OK) or else Lo < 0;
4678
4679                Determine_Range (Right_Opnd (N), OK, Lo, Hi);
4680                RNeg := (not OK) or else Lo < 0;
4681
4682                if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg))
4683                     or else
4684                   (Nkind (N) = N_Op_Mod and then (LNeg or RNeg))
4685                then
4686                   Check_Restriction (No_Implicit_Conditionals, N);
4687                end if;
4688             end;
4689          end if;
4690       end if;
4691
4692       Check_Unset_Reference (L);
4693       Check_Unset_Reference (R);
4694    end Resolve_Arithmetic_Op;
4695
4696    ------------------
4697    -- Resolve_Call --
4698    ------------------
4699
4700    procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
4701       Loc     : constant Source_Ptr := Sloc (N);
4702       Subp    : constant Node_Id    := Name (N);
4703       Nam     : Entity_Id;
4704       I       : Interp_Index;
4705       It      : Interp;
4706       Norm_OK : Boolean;
4707       Scop    : Entity_Id;
4708       Rtype   : Entity_Id;
4709
4710    begin
4711       --  The context imposes a unique interpretation with type Typ on a
4712       --  procedure or function call. Find the entity of the subprogram that
4713       --  yields the expected type, and propagate the corresponding formal
4714       --  constraints on the actuals. The caller has established that an
4715       --  interpretation exists, and emitted an error if not unique.
4716
4717       --  First deal with the case of a call to an access-to-subprogram,
4718       --  dereference made explicit in Analyze_Call.
4719
4720       if Ekind (Etype (Subp)) = E_Subprogram_Type then
4721          if not Is_Overloaded (Subp) then
4722             Nam := Etype (Subp);
4723
4724          else
4725             --  Find the interpretation whose type (a subprogram type) has a
4726             --  return type that is compatible with the context. Analysis of
4727             --  the node has established that one exists.
4728
4729             Nam := Empty;
4730
4731             Get_First_Interp (Subp,  I, It);
4732             while Present (It.Typ) loop
4733                if Covers (Typ, Etype (It.Typ)) then
4734                   Nam := It.Typ;
4735                   exit;
4736                end if;
4737
4738                Get_Next_Interp (I, It);
4739             end loop;
4740
4741             if No (Nam) then
4742                raise Program_Error;
4743             end if;
4744          end if;
4745
4746          --  If the prefix is not an entity, then resolve it
4747
4748          if not Is_Entity_Name (Subp) then
4749             Resolve (Subp, Nam);
4750          end if;
4751
4752          --  For an indirect call, we always invalidate checks, since we do not
4753          --  know whether the subprogram is local or global. Yes we could do
4754          --  better here, e.g. by knowing that there are no local subprograms,
4755          --  but it does not seem worth the effort. Similarly, we kill all
4756          --  knowledge of current constant values.
4757
4758          Kill_Current_Values;
4759
4760       --  If this is a procedure call which is really an entry call, do
4761       --  the conversion of the procedure call to an entry call. Protected
4762       --  operations use the same circuitry because the name in the call
4763       --  can be an arbitrary expression with special resolution rules.
4764
4765       elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
4766         or else (Is_Entity_Name (Subp)
4767                   and then Ekind (Entity (Subp)) = E_Entry)
4768       then
4769          Resolve_Entry_Call (N, Typ);
4770          Check_Elab_Call (N);
4771
4772          --  Kill checks and constant values, as above for indirect case
4773          --  Who knows what happens when another task is activated?
4774
4775          Kill_Current_Values;
4776          return;
4777
4778       --  Normal subprogram call with name established in Resolve
4779
4780       elsif not (Is_Type (Entity (Subp))) then
4781          Nam := Entity (Subp);
4782          Set_Entity_With_Style_Check (Subp, Nam);
4783
4784       --  Otherwise we must have the case of an overloaded call
4785
4786       else
4787          pragma Assert (Is_Overloaded (Subp));
4788
4789          --  Initialize Nam to prevent warning (we know it will be assigned
4790          --  in the loop below, but the compiler does not know that).
4791
4792          Nam := Empty;
4793
4794          Get_First_Interp (Subp,  I, It);
4795          while Present (It.Typ) loop
4796             if Covers (Typ, It.Typ) then
4797                Nam := It.Nam;
4798                Set_Entity_With_Style_Check (Subp, Nam);
4799                exit;
4800             end if;
4801
4802             Get_Next_Interp (I, It);
4803          end loop;
4804       end if;
4805
4806       if Is_Access_Subprogram_Type (Base_Type (Etype (Nam)))
4807          and then not Is_Access_Subprogram_Type (Base_Type (Typ))
4808          and then Nkind (Subp) /= N_Explicit_Dereference
4809          and then Present (Parameter_Associations (N))
4810       then
4811          --  The prefix is a parameterless function call that returns an access
4812          --  to subprogram. If parameters are present in the current call, add
4813          --  add an explicit dereference. We use the base type here because
4814          --  within an instance these may be subtypes.
4815
4816          --  The dereference is added either in Analyze_Call or here. Should
4817          --  be consolidated ???
4818
4819          Set_Is_Overloaded (Subp, False);
4820          Set_Etype (Subp, Etype (Nam));
4821          Insert_Explicit_Dereference (Subp);
4822          Nam := Designated_Type (Etype (Nam));
4823          Resolve (Subp, Nam);
4824       end if;
4825
4826       --  Check that a call to Current_Task does not occur in an entry body
4827
4828       if Is_RTE (Nam, RE_Current_Task) then
4829          declare
4830             P : Node_Id;
4831
4832          begin
4833             P := N;
4834             loop
4835                P := Parent (P);
4836
4837                --  Exclude calls that occur within the default of a formal
4838                --  parameter of the entry, since those are evaluated outside
4839                --  of the body.
4840
4841                exit when No (P) or else Nkind (P) = N_Parameter_Specification;
4842
4843                if Nkind (P) = N_Entry_Body
4844                  or else (Nkind (P) = N_Subprogram_Body
4845                            and then Is_Entry_Barrier_Function (P))
4846                then
4847                   Rtype := Etype (N);
4848                   Error_Msg_NE
4849                     ("?& should not be used in entry body (RM C.7(17))",
4850                      N, Nam);
4851                   Error_Msg_NE
4852                     ("\Program_Error will be raised at run time?", N, Nam);
4853                   Rewrite (N,
4854                     Make_Raise_Program_Error (Loc,
4855                       Reason => PE_Current_Task_In_Entry_Body));
4856                   Set_Etype (N, Rtype);
4857                   return;
4858                end if;
4859             end loop;
4860          end;
4861       end if;
4862
4863       --  Check that a procedure call does not occur in the context of the
4864       --  entry call statement of a conditional or timed entry call. Note that
4865       --  the case of a call to a subprogram renaming of an entry will also be
4866       --  rejected. The test for N not being an N_Entry_Call_Statement is
4867       --  defensive, covering the possibility that the processing of entry
4868       --  calls might reach this point due to later modifications of the code
4869       --  above.
4870
4871       if Nkind (Parent (N)) = N_Entry_Call_Alternative
4872         and then Nkind (N) /= N_Entry_Call_Statement
4873         and then Entry_Call_Statement (Parent (N)) = N
4874       then
4875          if Ada_Version < Ada_05 then
4876             Error_Msg_N ("entry call required in select statement", N);
4877
4878          --  Ada 2005 (AI-345): If a procedure_call_statement is used
4879          --  for a procedure_or_entry_call, the procedure_name or
4880          --  procedure_prefix of the procedure_call_statement shall denote
4881          --  an entry renamed by a procedure, or (a view of) a primitive
4882          --  subprogram of a limited interface whose first parameter is
4883          --  a controlling parameter.
4884
4885          elsif Nkind (N) = N_Procedure_Call_Statement
4886            and then not Is_Renamed_Entry (Nam)
4887            and then not Is_Controlling_Limited_Procedure (Nam)
4888          then
4889             Error_Msg_N
4890              ("entry call or dispatching primitive of interface required", N);
4891          end if;
4892       end if;
4893
4894       --  Check that this is not a call to a protected procedure or entry from
4895       --  within a protected function.
4896
4897       if Ekind (Current_Scope) = E_Function
4898         and then Ekind (Scope (Current_Scope)) = E_Protected_Type
4899         and then Ekind (Nam) /= E_Function
4900         and then Scope (Nam) = Scope (Current_Scope)
4901       then
4902          Error_Msg_N ("within protected function, protected " &
4903            "object is constant", N);
4904          Error_Msg_N ("\cannot call operation that may modify it", N);
4905       end if;
4906
4907       --  Freeze the subprogram name if not in a spec-expression. Note that we
4908       --  freeze procedure calls as well as function calls. Procedure calls are
4909       --  not frozen according to the rules (RM 13.14(14)) because it is
4910       --  impossible to have a procedure call to a non-frozen procedure in pure
4911       --  Ada, but in the code that we generate in the expander, this rule
4912       --  needs extending because we can generate procedure calls that need
4913       --  freezing.
4914
4915       if Is_Entity_Name (Subp) and then not In_Spec_Expression then
4916          Freeze_Expression (Subp);
4917       end if;
4918
4919       --  For a predefined operator, the type of the result is the type imposed
4920       --  by context, except for a predefined operation on universal fixed.
4921       --  Otherwise The type of the call is the type returned by the subprogram
4922       --  being called.
4923
4924       if Is_Predefined_Op (Nam) then
4925          if Etype (N) /= Universal_Fixed then
4926             Set_Etype (N, Typ);
4927          end if;
4928
4929       --  If the subprogram returns an array type, and the context requires the
4930       --  component type of that array type, the node is really an indexing of
4931       --  the parameterless call. Resolve as such. A pathological case occurs
4932       --  when the type of the component is an access to the array type. In
4933       --  this case the call is truly ambiguous.
4934
4935       elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam))
4936         and then
4937           ((Is_Array_Type (Etype (Nam))
4938                    and then Covers (Typ, Component_Type (Etype (Nam))))
4939              or else (Is_Access_Type (Etype (Nam))
4940                         and then Is_Array_Type (Designated_Type (Etype (Nam)))
4941                         and then
4942                           Covers (Typ,
4943                             Component_Type (Designated_Type (Etype (Nam))))))
4944       then
4945          declare
4946             Index_Node : Node_Id;
4947             New_Subp   : Node_Id;
4948             Ret_Type   : constant Entity_Id := Etype (Nam);
4949
4950          begin
4951             if Is_Access_Type (Ret_Type)
4952               and then Ret_Type = Component_Type (Designated_Type (Ret_Type))
4953             then
4954                Error_Msg_N
4955                  ("cannot disambiguate function call and indexing", N);
4956             else
4957                New_Subp := Relocate_Node (Subp);
4958                Set_Entity (Subp, Nam);
4959
4960                if Component_Type (Ret_Type) /= Any_Type then
4961                   if Needs_No_Actuals (Nam) then
4962
4963                      --  Indexed call to a parameterless function
4964
4965                      Index_Node :=
4966                        Make_Indexed_Component (Loc,
4967                          Prefix =>
4968                            Make_Function_Call (Loc,
4969                              Name => New_Subp),
4970                          Expressions => Parameter_Associations (N));
4971                   else
4972                      --  An Ada 2005 prefixed call to a primitive operation
4973                      --  whose first parameter is the prefix. This prefix was
4974                      --  prepended to the parameter list, which is actually a
4975                      --  list of indices. Remove the prefix in order to build
4976                      --  the proper indexed component.
4977
4978                      Index_Node :=
4979                         Make_Indexed_Component (Loc,
4980                           Prefix =>
4981                             Make_Function_Call (Loc,
4982                                Name => New_Subp,
4983                                Parameter_Associations =>
4984                                  New_List
4985                                    (Remove_Head (Parameter_Associations (N)))),
4986                            Expressions => Parameter_Associations (N));
4987                   end if;
4988
4989                   --  Since we are correcting a node classification error made
4990                   --  by the parser, we call Replace rather than Rewrite.
4991
4992                   Replace (N, Index_Node);
4993                   Set_Etype (Prefix (N), Ret_Type);
4994                   Set_Etype (N, Typ);
4995                   Resolve_Indexed_Component (N, Typ);
4996                   Check_Elab_Call (Prefix (N));
4997                end if;
4998             end if;
4999
5000             return;
5001          end;
5002
5003       else
5004          Set_Etype (N, Etype (Nam));
5005       end if;
5006
5007       --  In the case where the call is to an overloaded subprogram, Analyze
5008       --  calls Normalize_Actuals once per overloaded subprogram. Therefore in
5009       --  such a case Normalize_Actuals needs to be called once more to order
5010       --  the actuals correctly. Otherwise the call will have the ordering
5011       --  given by the last overloaded subprogram whether this is the correct
5012       --  one being called or not.
5013
5014       if Is_Overloaded (Subp) then
5015          Normalize_Actuals (N, Nam, False, Norm_OK);
5016          pragma Assert (Norm_OK);
5017       end if;
5018
5019       --  In any case, call is fully resolved now. Reset Overload flag, to
5020       --  prevent subsequent overload resolution if node is analyzed again
5021
5022       Set_Is_Overloaded (Subp, False);
5023       Set_Is_Overloaded (N, False);
5024
5025       --  If we are calling the current subprogram from immediately within its
5026       --  body, then that is the case where we can sometimes detect cases of
5027       --  infinite recursion statically. Do not try this in case restriction
5028       --  No_Recursion is in effect anyway, and do it only for source calls.
5029
5030       if Comes_From_Source (N) then
5031          Scop := Current_Scope;
5032
5033          --  Issue warning for possible infinite recursion in the absence
5034          --  of the No_Recursion restriction.
5035
5036          if Nam = Scop
5037            and then not Restriction_Active (No_Recursion)
5038            and then Check_Infinite_Recursion (N)
5039          then
5040             --  Here we detected and flagged an infinite recursion, so we do
5041             --  not need to test the case below for further warnings. Also if
5042             --  we now have a raise SE node, we are all done.
5043
5044             if Nkind (N) = N_Raise_Storage_Error then
5045                return;
5046             end if;
5047
5048          --  If call is to immediately containing subprogram, then check for
5049          --  the case of a possible run-time detectable infinite recursion.
5050
5051          else
5052             Scope_Loop : while Scop /= Standard_Standard loop
5053                if Nam = Scop then
5054
5055                   --  Although in general case, recursion is not statically
5056                   --  checkable, the case of calling an immediately containing
5057                   --  subprogram is easy to catch.
5058
5059                   Check_Restriction (No_Recursion, N);
5060
5061                   --  If the recursive call is to a parameterless subprogram,
5062                   --  then even if we can't statically detect infinite
5063                   --  recursion, this is pretty suspicious, and we output a
5064                   --  warning. Furthermore, we will try later to detect some
5065                   --  cases here at run time by expanding checking code (see
5066                   --  Detect_Infinite_Recursion in package Exp_Ch6).
5067
5068                   --  If the recursive call is within a handler, do not emit a
5069                   --  warning, because this is a common idiom: loop until input
5070                   --  is correct, catch illegal input in handler and restart.
5071
5072                   if No (First_Formal (Nam))
5073                     and then Etype (Nam) = Standard_Void_Type
5074                     and then not Error_Posted (N)
5075                     and then Nkind (Parent (N)) /= N_Exception_Handler
5076                   then
5077                      --  For the case of a procedure call. We give the message
5078                      --  only if the call is the first statement in a sequence
5079                      --  of statements, or if all previous statements are
5080                      --  simple assignments. This is simply a heuristic to
5081                      --  decrease false positives, without losing too many good
5082                      --  warnings. The idea is that these previous statements
5083                      --  may affect global variables the procedure depends on.
5084
5085                      if Nkind (N) = N_Procedure_Call_Statement
5086                        and then Is_List_Member (N)
5087                      then
5088                         declare
5089                            P : Node_Id;
5090                         begin
5091                            P := Prev (N);
5092                            while Present (P) loop
5093                               if Nkind (P) /= N_Assignment_Statement then
5094                                  exit Scope_Loop;
5095                               end if;
5096
5097                               Prev (P);
5098                            end loop;
5099                         end;
5100                      end if;
5101
5102                      --  Do not give warning if we are in a conditional context
5103
5104                      declare
5105                         K : constant Node_Kind := Nkind (Parent (N));
5106                      begin
5107                         if (K = N_Loop_Statement
5108                             and then Present (Iteration_Scheme (Parent (N))))
5109                           or else K = N_If_Statement
5110                           or else K = N_Elsif_Part
5111                           or else K = N_Case_Statement_Alternative
5112                         then
5113                            exit Scope_Loop;
5114                         end if;
5115                      end;
5116
5117                      --  Here warning is to be issued
5118
5119                      Set_Has_Recursive_Call (Nam);
5120                      Error_Msg_N
5121                        ("?possible infinite recursion!", N);
5122                      Error_Msg_N
5123                        ("\?Storage_Error may be raised at run time!", N);
5124                   end if;
5125
5126                   exit Scope_Loop;
5127                end if;
5128
5129                Scop := Scope (Scop);
5130             end loop Scope_Loop;
5131          end if;
5132       end if;
5133
5134       --  If subprogram name is a predefined operator, it was given in
5135       --  functional notation. Replace call node with operator node, so
5136       --  that actuals can be resolved appropriately.
5137
5138       if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
5139          Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
5140          return;
5141
5142       elsif Present (Alias (Nam))
5143         and then Is_Predefined_Op (Alias (Nam))
5144       then
5145          Resolve_Actuals (N, Nam);
5146          Make_Call_Into_Operator (N, Typ, Alias (Nam));
5147          return;
5148       end if;
5149
5150       --  Create a transient scope if the resulting type requires it
5151
5152       --  There are several notable exceptions:
5153
5154       --  a) In init procs, the transient scope overhead is not needed, and is
5155       --  even incorrect when the call is a nested initialization call for a
5156       --  component whose expansion may generate adjust calls. However, if the
5157       --  call is some other procedure call within an initialization procedure
5158       --  (for example a call to Create_Task in the init_proc of the task
5159       --  run-time record) a transient scope must be created around this call.
5160
5161       --  b) Enumeration literal pseudo-calls need no transient scope
5162
5163       --  c) Intrinsic subprograms (Unchecked_Conversion and source info
5164       --  functions) do not use the secondary stack even though the return
5165       --  type may be unconstrained.
5166
5167       --  d) Calls to a build-in-place function, since such functions may
5168       --  allocate their result directly in a target object, and cases where
5169       --  the result does get allocated in the secondary stack are checked for
5170       --  within the specialized Exp_Ch6 procedures for expanding those
5171       --  build-in-place calls.
5172
5173       --  e) If the subprogram is marked Inline_Always, then even if it returns
5174       --  an unconstrained type the call does not require use of the secondary
5175       --  stack. However, inlining will only take place if the body to inline
5176       --  is already present. It may not be available if e.g. the subprogram is
5177       --  declared in a child instance.
5178
5179       --  If this is an initialization call for a type whose construction
5180       --  uses the secondary stack, and it is not a nested call to initialize
5181       --  a component, we do need to create a transient scope for it. We
5182       --  check for this by traversing the type in Check_Initialization_Call.
5183
5184       if Is_Inlined (Nam)
5185         and then Has_Pragma_Inline_Always (Nam)
5186         and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
5187         and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
5188       then
5189          null;
5190
5191       elsif Ekind (Nam) = E_Enumeration_Literal
5192         or else Is_Build_In_Place_Function (Nam)
5193         or else Is_Intrinsic_Subprogram (Nam)
5194       then
5195          null;
5196
5197       elsif Expander_Active
5198         and then Is_Type (Etype (Nam))
5199         and then Requires_Transient_Scope (Etype (Nam))
5200         and then
5201           (not Within_Init_Proc
5202             or else
5203               (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function))
5204       then
5205          Establish_Transient_Scope (N, Sec_Stack => True);
5206
5207          --  If the call appears within the bounds of a loop, it will
5208          --  be rewritten and reanalyzed, nothing left to do here.
5209
5210          if Nkind (N) /= N_Function_Call then
5211             return;
5212          end if;
5213
5214       elsif Is_Init_Proc (Nam)
5215         and then not Within_Init_Proc
5216       then
5217          Check_Initialization_Call (N, Nam);
5218       end if;
5219
5220       --  A protected function cannot be called within the definition of the
5221       --  enclosing protected type.
5222
5223       if Is_Protected_Type (Scope (Nam))
5224         and then In_Open_Scopes (Scope (Nam))
5225         and then not Has_Completion (Scope (Nam))
5226       then
5227          Error_Msg_NE
5228            ("& cannot be called before end of protected definition", N, Nam);
5229       end if;
5230
5231       --  Propagate interpretation to actuals, and add default expressions
5232       --  where needed.
5233
5234       if Present (First_Formal (Nam)) then
5235          Resolve_Actuals (N, Nam);
5236
5237       --  Overloaded literals are rewritten as function calls, for purpose of
5238       --  resolution. After resolution, we can replace the call with the
5239       --  literal itself.
5240
5241       elsif Ekind (Nam) = E_Enumeration_Literal then
5242          Copy_Node (Subp, N);
5243          Resolve_Entity_Name (N, Typ);
5244
5245          --  Avoid validation, since it is a static function call
5246
5247          Generate_Reference (Nam, Subp);
5248          return;
5249       end if;
5250
5251       --  If the subprogram is not global, then kill all saved values and
5252       --  checks. This is a bit conservative, since in many cases we could do
5253       --  better, but it is not worth the effort. Similarly, we kill constant
5254       --  values. However we do not need to do this for internal entities
5255       --  (unless they are inherited user-defined subprograms), since they
5256       --  are not in the business of molesting local values.
5257
5258       --  If the flag Suppress_Value_Tracking_On_Calls is set, then we also
5259       --  kill all checks and values for calls to global subprograms. This
5260       --  takes care of the case where an access to a local subprogram is
5261       --  taken, and could be passed directly or indirectly and then called
5262       --  from almost any context.
5263
5264       --  Note: we do not do this step till after resolving the actuals. That
5265       --  way we still take advantage of the current value information while
5266       --  scanning the actuals.
5267
5268       --  We suppress killing values if we are processing the nodes associated
5269       --  with N_Freeze_Entity nodes. Otherwise the declaration of a tagged
5270       --  type kills all the values as part of analyzing the code that
5271       --  initializes the dispatch tables.
5272
5273       if Inside_Freezing_Actions = 0
5274         and then (not Is_Library_Level_Entity (Nam)
5275                    or else Suppress_Value_Tracking_On_Call
5276                              (Nearest_Dynamic_Scope (Current_Scope)))
5277         and then (Comes_From_Source (Nam)
5278                    or else (Present (Alias (Nam))
5279                              and then Comes_From_Source (Alias (Nam))))
5280       then
5281          Kill_Current_Values;
5282       end if;
5283
5284       --  If we are warning about unread OUT parameters, this is the place to
5285       --  set Last_Assignment for OUT and IN OUT parameters. We have to do this
5286       --  after the above call to Kill_Current_Values (since that call clears
5287       --  the Last_Assignment field of all local variables).
5288
5289       if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters)
5290         and then Comes_From_Source (N)
5291         and then In_Extended_Main_Source_Unit (N)
5292       then
5293          declare
5294             F : Entity_Id;
5295             A : Node_Id;
5296
5297          begin
5298             F := First_Formal (Nam);
5299             A := First_Actual (N);
5300             while Present (F) and then Present (A) loop
5301                if (Ekind (F) = E_Out_Parameter
5302                      or else
5303                    Ekind (F) = E_In_Out_Parameter)
5304                  and then Warn_On_Modified_As_Out_Parameter (F)
5305                  and then Is_Entity_Name (A)
5306                  and then Present (Entity (A))
5307                  and then Comes_From_Source (N)
5308                  and then Safe_To_Capture_Value (N, Entity (A))
5309                then
5310                   Set_Last_Assignment (Entity (A), A);
5311                end if;
5312
5313                Next_Formal (F);
5314                Next_Actual (A);
5315             end loop;
5316          end;
5317       end if;
5318
5319       --  If the subprogram is a primitive operation, check whether or not
5320       --  it is a correct dispatching call.
5321
5322       if Is_Overloadable (Nam)
5323         and then Is_Dispatching_Operation (Nam)
5324       then
5325          Check_Dispatching_Call (N);
5326
5327       elsif Ekind (Nam) /= E_Subprogram_Type
5328         and then Is_Abstract_Subprogram (Nam)
5329         and then not In_Instance
5330       then
5331          Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
5332       end if;
5333
5334       --  If this is a dispatching call, generate the appropriate reference,
5335       --  for better source navigation in GPS.
5336
5337       if Is_Overloadable (Nam)
5338         and then Present (Controlling_Argument (N))
5339       then
5340          Generate_Reference (Nam, Subp, 'R');
5341
5342       --  Normal case, not a dispatching call
5343
5344       else
5345          Generate_Reference (Nam, Subp);
5346       end if;
5347
5348       if Is_Intrinsic_Subprogram (Nam) then
5349          Check_Intrinsic_Call (N);
5350       end if;
5351
5352       --  Check for violation of restriction No_Specific_Termination_Handlers
5353       --  and warn on a potentially blocking call to Abort_Task.
5354
5355       if Is_RTE (Nam, RE_Set_Specific_Handler)
5356            or else
5357          Is_RTE (Nam, RE_Specific_Handler)
5358       then
5359          Check_Restriction (No_Specific_Termination_Handlers, N);
5360
5361       elsif Is_RTE (Nam, RE_Abort_Task) then
5362          Check_Potentially_Blocking_Operation (N);
5363       end if;
5364
5365       --  Issue an error for a call to an eliminated subprogram
5366
5367       Check_For_Eliminated_Subprogram (Subp, Nam);
5368
5369       --  All done, evaluate call and deal with elaboration issues
5370
5371       Eval_Call (N);
5372       Check_Elab_Call (N);
5373    end Resolve_Call;
5374
5375    -------------------------------
5376    -- Resolve_Character_Literal --
5377    -------------------------------
5378
5379    procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
5380       B_Typ : constant Entity_Id := Base_Type (Typ);
5381       C     : Entity_Id;
5382
5383    begin
5384       --  Verify that the character does belong to the type of the context
5385
5386       Set_Etype (N, B_Typ);
5387       Eval_Character_Literal (N);
5388
5389       --  Wide_Wide_Character literals must always be defined, since the set
5390       --  of wide wide character literals is complete, i.e. if a character
5391       --  literal is accepted by the parser, then it is OK for wide wide
5392       --  character (out of range character literals are rejected).
5393
5394       if Root_Type (B_Typ) = Standard_Wide_Wide_Character then
5395          return;
5396
5397       --  Always accept character literal for type Any_Character, which
5398       --  occurs in error situations and in comparisons of literals, both
5399       --  of which should accept all literals.
5400
5401       elsif B_Typ = Any_Character then
5402          return;
5403
5404       --  For Standard.Character or a type derived from it, check that
5405       --  the literal is in range
5406
5407       elsif Root_Type (B_Typ) = Standard_Character then
5408          if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
5409             return;
5410          end if;
5411
5412       --  For Standard.Wide_Character or a type derived from it, check
5413       --  that the literal is in range
5414
5415       elsif Root_Type (B_Typ) = Standard_Wide_Character then
5416          if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
5417             return;
5418          end if;
5419
5420       --  For Standard.Wide_Wide_Character or a type derived from it, we
5421       --  know the literal is in range, since the parser checked!
5422
5423       elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
5424          return;
5425
5426       --  If the entity is already set, this has already been resolved in a
5427       --  generic context, or comes from expansion. Nothing else to do.
5428
5429       elsif Present (Entity (N)) then
5430          return;
5431
5432       --  Otherwise we have a user defined character type, and we can use the
5433       --  standard visibility mechanisms to locate the referenced entity.
5434
5435       else
5436          C := Current_Entity (N);
5437          while Present (C) loop
5438             if Etype (C) = B_Typ then
5439                Set_Entity_With_Style_Check (N, C);
5440                Generate_Reference (C, N);
5441                return;
5442             end if;
5443
5444             C := Homonym (C);
5445          end loop;
5446       end if;
5447
5448       --  If we fall through, then the literal does not match any of the
5449       --  entries of the enumeration type. This isn't just a constraint
5450       --  error situation, it is an illegality (see RM 4.2).
5451
5452       Error_Msg_NE
5453         ("character not defined for }", N, First_Subtype (B_Typ));
5454    end Resolve_Character_Literal;
5455
5456    ---------------------------
5457    -- Resolve_Comparison_Op --
5458    ---------------------------
5459
5460    --  Context requires a boolean type, and plays no role in resolution.
5461    --  Processing identical to that for equality operators. The result
5462    --  type is the base type, which matters when pathological subtypes of
5463    --  booleans with limited ranges are used.
5464
5465    procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
5466       L : constant Node_Id := Left_Opnd (N);
5467       R : constant Node_Id := Right_Opnd (N);
5468       T : Entity_Id;
5469
5470    begin
5471       Check_No_Direct_Boolean_Operators (N);
5472
5473       --  If this is an intrinsic operation which is not predefined, use the
5474       --  types of its declared arguments to resolve the possibly overloaded
5475       --  operands. Otherwise the operands are unambiguous and specify the
5476       --  expected type.
5477
5478       if Scope (Entity (N)) /= Standard_Standard then
5479          T := Etype (First_Entity (Entity (N)));
5480
5481       else
5482          T := Find_Unique_Type (L, R);
5483
5484          if T = Any_Fixed then
5485             T := Unique_Fixed_Point_Type (L);
5486          end if;
5487       end if;
5488
5489       Set_Etype (N, Base_Type (Typ));
5490       Generate_Reference (T, N, ' ');
5491
5492       if T /= Any_Type then
5493          if T = Any_String    or else
5494             T = Any_Composite or else
5495             T = Any_Character
5496          then
5497             if T = Any_Character then
5498                Ambiguous_Character (L);
5499             else
5500                Error_Msg_N ("ambiguous operands for comparison", N);
5501             end if;
5502
5503             Set_Etype (N, Any_Type);
5504             return;
5505
5506          else
5507             Resolve (L, T);
5508             Resolve (R, T);
5509             Check_Unset_Reference (L);
5510             Check_Unset_Reference (R);
5511             Generate_Operator_Reference (N, T);
5512             Check_Low_Bound_Tested (N);
5513             Eval_Relational_Op (N);
5514          end if;
5515       end if;
5516    end Resolve_Comparison_Op;
5517
5518    ------------------------------------
5519    -- Resolve_Conditional_Expression --
5520    ------------------------------------
5521
5522    procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
5523       Condition : constant Node_Id := First (Expressions (N));
5524       Then_Expr : constant Node_Id := Next (Condition);
5525       Else_Expr : constant Node_Id := Next (Then_Expr);
5526    begin
5527       Resolve (Condition, Standard_Boolean);
5528       Resolve (Then_Expr, Typ);
5529       Resolve (Else_Expr, Typ);
5530       Set_Etype (N, Typ);
5531       Eval_Conditional_Expression (N);
5532    end Resolve_Conditional_Expression;
5533
5534    -----------------------------------------
5535    -- Resolve_Discrete_Subtype_Indication --
5536    -----------------------------------------
5537
5538    procedure Resolve_Discrete_Subtype_Indication
5539      (N   : Node_Id;
5540       Typ : Entity_Id)
5541    is
5542       R : Node_Id;
5543       S : Entity_Id;
5544
5545    begin
5546       Analyze (Subtype_Mark (N));
5547       S := Entity (Subtype_Mark (N));
5548
5549       if Nkind (Constraint (N)) /= N_Range_Constraint then
5550          Error_Msg_N ("expect range constraint for discrete type", N);
5551          Set_Etype (N, Any_Type);
5552
5553       else
5554          R := Range_Expression (Constraint (N));
5555
5556          if R = Error then
5557             return;
5558          end if;
5559
5560          Analyze (R);
5561
5562          if Base_Type (S) /= Base_Type (Typ) then
5563             Error_Msg_NE
5564               ("expect subtype of }", N, First_Subtype (Typ));
5565
5566             --  Rewrite the constraint as a range of Typ
5567             --  to allow compilation to proceed further.
5568
5569             Set_Etype (N, Typ);
5570             Rewrite (Low_Bound (R),
5571               Make_Attribute_Reference (Sloc (Low_Bound (R)),
5572                 Prefix =>         New_Occurrence_Of (Typ, Sloc (R)),
5573                 Attribute_Name => Name_First));
5574             Rewrite (High_Bound (R),
5575               Make_Attribute_Reference (Sloc (High_Bound (R)),
5576                 Prefix =>         New_Occurrence_Of (Typ, Sloc (R)),
5577                 Attribute_Name => Name_First));
5578
5579          else
5580             Resolve (R, Typ);
5581             Set_Etype (N, Etype (R));
5582
5583             --  Additionally, we must check that the bounds are compatible
5584             --  with the given subtype, which might be different from the
5585             --  type of the context.
5586
5587             Apply_Range_Check (R, S);
5588
5589             --  ??? If the above check statically detects a Constraint_Error
5590             --  it replaces the offending bound(s) of the range R with a
5591             --  Constraint_Error node. When the itype which uses these bounds
5592             --  is frozen the resulting call to Duplicate_Subexpr generates
5593             --  a new temporary for the bounds.
5594
5595             --  Unfortunately there are other itypes that are also made depend
5596             --  on these bounds, so when Duplicate_Subexpr is called they get
5597             --  a forward reference to the newly created temporaries and Gigi
5598             --  aborts on such forward references. This is probably sign of a
5599             --  more fundamental problem somewhere else in either the order of
5600             --  itype freezing or the way certain itypes are constructed.
5601
5602             --  To get around this problem we call Remove_Side_Effects right
5603             --  away if either bounds of R are a Constraint_Error.
5604
5605             declare
5606                L : constant Node_Id := Low_Bound (R);
5607                H : constant Node_Id := High_Bound (R);
5608
5609             begin
5610                if Nkind (L) = N_Raise_Constraint_Error then
5611                   Remove_Side_Effects (L);
5612                end if;
5613
5614                if Nkind (H) = N_Raise_Constraint_Error then
5615                   Remove_Side_Effects (H);
5616                end if;
5617             end;
5618
5619             Check_Unset_Reference (Low_Bound  (R));
5620             Check_Unset_Reference (High_Bound (R));
5621          end if;
5622       end if;
5623    end Resolve_Discrete_Subtype_Indication;
5624
5625    -------------------------
5626    -- Resolve_Entity_Name --
5627    -------------------------
5628
5629    --  Used to resolve identifiers and expanded names
5630
5631    procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
5632       E : constant Entity_Id := Entity (N);
5633
5634    begin
5635       --  If garbage from errors, set to Any_Type and return
5636
5637       if No (E) and then Total_Errors_Detected /= 0 then
5638          Set_Etype (N, Any_Type);
5639          return;
5640       end if;
5641
5642       --  Replace named numbers by corresponding literals. Note that this is
5643       --  the one case where Resolve_Entity_Name must reset the Etype, since
5644       --  it is currently marked as universal.
5645
5646       if Ekind (E) = E_Named_Integer then
5647          Set_Etype (N, Typ);
5648          Eval_Named_Integer (N);
5649
5650       elsif Ekind (E) = E_Named_Real then
5651          Set_Etype (N, Typ);
5652          Eval_Named_Real (N);
5653
5654       --  Allow use of subtype only if it is a concurrent type where we are
5655       --  currently inside the body. This will eventually be expanded into a
5656       --  call to Self (for tasks) or _object (for protected objects). Any
5657       --  other use of a subtype is invalid.
5658
5659       elsif Is_Type (E) then
5660          if Is_Concurrent_Type (E)
5661            and then In_Open_Scopes (E)
5662          then
5663             null;
5664          else
5665             Error_Msg_N
5666                ("invalid use of subtype mark in expression or call", N);
5667          end if;
5668
5669       --  Check discriminant use if entity is discriminant in current scope,
5670       --  i.e. discriminant of record or concurrent type currently being
5671       --  analyzed. Uses in corresponding body are unrestricted.
5672
5673       elsif Ekind (E) = E_Discriminant
5674         and then Scope (E) = Current_Scope
5675         and then not Has_Completion (Current_Scope)
5676       then
5677          Check_Discriminant_Use (N);
5678
5679       --  A parameterless generic function cannot appear in a context that
5680       --  requires resolution.
5681
5682       elsif Ekind (E) = E_Generic_Function then
5683          Error_Msg_N ("illegal use of generic function", N);
5684
5685       elsif Ekind (E) = E_Out_Parameter
5686         and then Ada_Version = Ada_83
5687         and then (Nkind (Parent (N)) in N_Op
5688                     or else (Nkind (Parent (N)) = N_Assignment_Statement
5689                               and then N = Expression (Parent (N)))
5690                     or else Nkind (Parent (N)) = N_Explicit_Dereference)
5691       then
5692          Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
5693
5694       --  In all other cases, just do the possible static evaluation
5695
5696       else
5697          --  A deferred constant that appears in an expression must have a
5698          --  completion, unless it has been removed by in-place expansion of
5699          --  an aggregate.
5700
5701          if Ekind (E) = E_Constant
5702            and then Comes_From_Source (E)
5703            and then No (Constant_Value (E))
5704            and then Is_Frozen (Etype (E))
5705            and then not In_Spec_Expression
5706            and then not Is_Imported (E)
5707          then
5708
5709             if No_Initialization (Parent (E))
5710               or else (Present (Full_View (E))
5711                         and then No_Initialization (Parent (Full_View (E))))
5712             then
5713                null;
5714             else
5715                Error_Msg_N (
5716                  "deferred constant is frozen before completion", N);
5717             end if;
5718          end if;
5719
5720          Eval_Entity_Name (N);
5721       end if;
5722    end Resolve_Entity_Name;
5723
5724    -------------------
5725    -- Resolve_Entry --
5726    -------------------
5727
5728    procedure Resolve_Entry (Entry_Name : Node_Id) is
5729       Loc    : constant Source_Ptr := Sloc (Entry_Name);
5730       Nam    : Entity_Id;
5731       New_N  : Node_Id;
5732       S      : Entity_Id;
5733       Tsk    : Entity_Id;
5734       E_Name : Node_Id;
5735       Index  : Node_Id;
5736
5737       function Actual_Index_Type (E : Entity_Id) return Entity_Id;
5738       --  If the bounds of the entry family being called depend on task
5739       --  discriminants, build a new index subtype where a discriminant is
5740       --  replaced with the value of the discriminant of the target task.
5741       --  The target task is the prefix of the entry name in the call.
5742
5743       -----------------------
5744       -- Actual_Index_Type --
5745       -----------------------
5746
5747       function Actual_Index_Type (E : Entity_Id) return Entity_Id is
5748          Typ   : constant Entity_Id := Entry_Index_Type (E);
5749          Tsk   : constant Entity_Id := Scope (E);
5750          Lo    : constant Node_Id   := Type_Low_Bound  (Typ);
5751          Hi    : constant Node_Id   := Type_High_Bound (Typ);
5752          New_T : Entity_Id;
5753
5754          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
5755          --  If the bound is given by a discriminant, replace with a reference
5756          --  to the discriminant of the same name in the target task. If the
5757          --  entry name is the target of a requeue statement and the entry is
5758          --  in the current protected object, the bound to be used is the
5759          --  discriminal of the object (see apply_range_checks for details of
5760          --  the transformation).
5761
5762          -----------------------------
5763          -- Actual_Discriminant_Ref --
5764          -----------------------------
5765
5766          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
5767             Typ : constant Entity_Id := Etype (Bound);
5768             Ref : Node_Id;
5769
5770          begin
5771             Remove_Side_Effects (Bound);
5772
5773             if not Is_Entity_Name (Bound)
5774               or else Ekind (Entity (Bound)) /= E_Discriminant
5775             then
5776                return Bound;
5777
5778             elsif Is_Protected_Type (Tsk)
5779               and then In_Open_Scopes (Tsk)
5780               and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
5781             then
5782                return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
5783
5784             else
5785                Ref :=
5786                  Make_Selected_Component (Loc,
5787                    Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
5788                    Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
5789                Analyze (Ref);
5790                Resolve (Ref, Typ);
5791                return Ref;
5792             end if;
5793          end Actual_Discriminant_Ref;
5794
5795       --  Start of processing for Actual_Index_Type
5796
5797       begin
5798          if not Has_Discriminants (Tsk)
5799            or else (not Is_Entity_Name (Lo)
5800                      and then
5801                     not Is_Entity_Name (Hi))
5802          then
5803             return Entry_Index_Type (E);
5804
5805          else
5806             New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
5807             Set_Etype        (New_T, Base_Type (Typ));
5808             Set_Size_Info    (New_T, Typ);
5809             Set_RM_Size      (New_T, RM_Size (Typ));
5810             Set_Scalar_Range (New_T,
5811               Make_Range (Sloc (Entry_Name),
5812                 Low_Bound  => Actual_Discriminant_Ref (Lo),
5813                 High_Bound => Actual_Discriminant_Ref (Hi)));
5814
5815             return New_T;
5816          end if;
5817       end Actual_Index_Type;
5818
5819    --  Start of processing of Resolve_Entry
5820
5821    begin
5822       --  Find name of entry being called, and resolve prefix of name
5823       --  with its own type. The prefix can be overloaded, and the name
5824       --  and signature of the entry must be taken into account.
5825
5826       if Nkind (Entry_Name) = N_Indexed_Component then
5827
5828          --  Case of dealing with entry family within the current tasks
5829
5830          E_Name := Prefix (Entry_Name);
5831
5832       else
5833          E_Name := Entry_Name;
5834       end if;
5835
5836       if Is_Entity_Name (E_Name) then
5837
5838          --  Entry call to an entry (or entry family) in the current task. This
5839          --  is legal even though the task will deadlock. Rewrite as call to
5840          --  current task.
5841
5842          --  This can also be a call to an entry in an enclosing task. If this
5843          --  is a single task, we have to retrieve its name, because the scope
5844          --  of the entry is the task type, not the object. If the enclosing
5845          --  task is a task type, the identity of the task is given by its own
5846          --  self variable.
5847
5848          --  Finally this can be a requeue on an entry of the same task or
5849          --  protected object.
5850
5851          S := Scope (Entity (E_Name));
5852
5853          for J in reverse 0 .. Scope_Stack.Last loop
5854             if Is_Task_Type (Scope_Stack.Table (J).Entity)
5855               and then not Comes_From_Source (S)
5856             then
5857                --  S is an enclosing task or protected object. The concurrent
5858                --  declaration has been converted into a type declaration, and
5859                --  the object itself has an object declaration that follows
5860                --  the type in the same declarative part.
5861
5862                Tsk := Next_Entity (S);
5863                while Etype (Tsk) /= S loop
5864                   Next_Entity (Tsk);
5865                end loop;
5866
5867                S := Tsk;
5868                exit;
5869
5870             elsif S = Scope_Stack.Table (J).Entity then
5871
5872                --  Call to current task. Will be transformed into call to Self
5873
5874                exit;
5875
5876             end if;
5877          end loop;
5878
5879          New_N :=
5880            Make_Selected_Component (Loc,
5881              Prefix => New_Occurrence_Of (S, Loc),
5882              Selector_Name =>
5883                New_Occurrence_Of (Entity (E_Name), Loc));
5884          Rewrite (E_Name, New_N);
5885          Analyze (E_Name);
5886
5887       elsif Nkind (Entry_Name) = N_Selected_Component
5888         and then Is_Overloaded (Prefix (Entry_Name))
5889       then
5890          --  Use the entry name (which must be unique at this point) to find
5891          --  the prefix that returns the corresponding task type or protected
5892          --  type.
5893
5894          declare
5895             Pref : constant Node_Id := Prefix (Entry_Name);
5896             Ent  : constant Entity_Id :=  Entity (Selector_Name (Entry_Name));
5897             I    : Interp_Index;
5898             It   : Interp;
5899
5900          begin
5901             Get_First_Interp (Pref, I, It);
5902             while Present (It.Typ) loop
5903                if Scope (Ent) = It.Typ then
5904                   Set_Etype (Pref, It.Typ);
5905                   exit;
5906                end if;
5907
5908                Get_Next_Interp (I, It);
5909             end loop;
5910          end;
5911       end if;
5912
5913       if Nkind (Entry_Name) = N_Selected_Component then
5914          Resolve (Prefix (Entry_Name));
5915
5916       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
5917          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
5918          Resolve (Prefix (Prefix (Entry_Name)));
5919          Index :=  First (Expressions (Entry_Name));
5920          Resolve (Index, Entry_Index_Type (Nam));
5921
5922          --  Up to this point the expression could have been the actual in a
5923          --  simple entry call, and be given by a named association.
5924
5925          if Nkind (Index) = N_Parameter_Association then
5926             Error_Msg_N ("expect expression for entry index", Index);
5927          else
5928             Apply_Range_Check (Index, Actual_Index_Type (Nam));
5929          end if;
5930       end if;
5931    end Resolve_Entry;
5932
5933    ------------------------
5934    -- Resolve_Entry_Call --
5935    ------------------------
5936
5937    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
5938       Entry_Name  : constant Node_Id    := Name (N);
5939       Loc         : constant Source_Ptr := Sloc (Entry_Name);
5940       Actuals     : List_Id;
5941       First_Named : Node_Id;
5942       Nam         : Entity_Id;
5943       Norm_OK     : Boolean;
5944       Obj         : Node_Id;
5945       Was_Over    : Boolean;
5946
5947    begin
5948       --  We kill all checks here, because it does not seem worth the effort to
5949       --  do anything better, an entry call is a big operation.
5950
5951       Kill_All_Checks;
5952
5953       --  Processing of the name is similar for entry calls and protected
5954       --  operation calls. Once the entity is determined, we can complete
5955       --  the resolution of the actuals.
5956
5957       --  The selector may be overloaded, in the case of a protected object
5958       --  with overloaded functions. The type of the context is used for
5959       --  resolution.
5960
5961       if Nkind (Entry_Name) = N_Selected_Component
5962         and then Is_Overloaded (Selector_Name (Entry_Name))
5963         and then Typ /= Standard_Void_Type
5964       then
5965          declare
5966             I  : Interp_Index;
5967             It : Interp;
5968
5969          begin
5970             Get_First_Interp (Selector_Name (Entry_Name), I, It);
5971             while Present (It.Typ) loop
5972                if Covers (Typ, It.Typ) then
5973                   Set_Entity (Selector_Name (Entry_Name), It.Nam);
5974                   Set_Etype  (Entry_Name, It.Typ);
5975
5976                   Generate_Reference (It.Typ, N, ' ');
5977                end if;
5978
5979                Get_Next_Interp (I, It);
5980             end loop;
5981          end;
5982       end if;
5983
5984       Resolve_Entry (Entry_Name);
5985
5986       if Nkind (Entry_Name) = N_Selected_Component then
5987
5988          --  Simple entry call
5989
5990          Nam := Entity (Selector_Name (Entry_Name));
5991          Obj := Prefix (Entry_Name);
5992          Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
5993
5994       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
5995
5996          --  Call to member of entry family
5997
5998          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
5999          Obj := Prefix (Prefix (Entry_Name));
6000          Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
6001       end if;
6002
6003       --  We cannot in general check the maximum depth of protected entry
6004       --  calls at compile time. But we can tell that any protected entry
6005       --  call at all violates a specified nesting depth of zero.
6006
6007       if Is_Protected_Type (Scope (Nam)) then
6008          Check_Restriction (Max_Entry_Queue_Length, N);
6009       end if;
6010
6011       --  Use context type to disambiguate a protected function that can be
6012       --  called without actuals and that returns an array type, and where
6013       --  the argument list may be an indexing of the returned value.
6014
6015       if Ekind (Nam) = E_Function
6016         and then Needs_No_Actuals (Nam)
6017         and then Present (Parameter_Associations (N))
6018         and then
6019           ((Is_Array_Type (Etype (Nam))
6020              and then Covers (Typ, Component_Type (Etype (Nam))))
6021
6022             or else (Is_Access_Type (Etype (Nam))
6023                       and then Is_Array_Type (Designated_Type (Etype (Nam)))
6024                       and then Covers (Typ,
6025                         Component_Type (Designated_Type (Etype (Nam))))))
6026       then
6027          declare
6028             Index_Node : Node_Id;
6029
6030          begin
6031             Index_Node :=
6032               Make_Indexed_Component (Loc,
6033                 Prefix =>
6034                   Make_Function_Call (Loc,
6035                     Name => Relocate_Node (Entry_Name)),
6036                 Expressions => Parameter_Associations (N));
6037
6038             --  Since we are correcting a node classification error made by
6039             --  the parser, we call Replace rather than Rewrite.
6040
6041             Replace (N, Index_Node);
6042             Set_Etype (Prefix (N), Etype (Nam));
6043             Set_Etype (N, Typ);
6044             Resolve_Indexed_Component (N, Typ);
6045             return;
6046          end;
6047       end if;
6048
6049       --  The operation name may have been overloaded. Order the actuals
6050       --  according to the formals of the resolved entity, and set the
6051       --  return type to that of the operation.
6052
6053       if Was_Over then
6054          Normalize_Actuals (N, Nam, False, Norm_OK);
6055          pragma Assert (Norm_OK);
6056          Set_Etype (N, Etype (Nam));
6057       end if;
6058
6059       Resolve_Actuals (N, Nam);
6060       Generate_Reference (Nam, Entry_Name);
6061
6062       if Ekind (Nam) = E_Entry
6063         or else Ekind (Nam) = E_Entry_Family
6064       then
6065          Check_Potentially_Blocking_Operation (N);
6066       end if;
6067
6068       --  Verify that a procedure call cannot masquerade as an entry
6069       --  call where an entry call is expected.
6070
6071       if Ekind (Nam) = E_Procedure then
6072          if Nkind (Parent (N)) = N_Entry_Call_Alternative
6073            and then N = Entry_Call_Statement (Parent (N))
6074          then
6075             Error_Msg_N ("entry call required in select statement", N);
6076
6077          elsif Nkind (Parent (N)) = N_Triggering_Alternative
6078            and then N = Triggering_Statement (Parent (N))
6079          then
6080             Error_Msg_N ("triggering statement cannot be procedure call", N);
6081
6082          elsif Ekind (Scope (Nam)) = E_Task_Type
6083            and then not In_Open_Scopes (Scope (Nam))
6084          then
6085             Error_Msg_N ("task has no entry with this name", Entry_Name);
6086          end if;
6087       end if;
6088
6089       --  After resolution, entry calls and protected procedure calls are
6090       --  changed into entry calls, for expansion. The structure of the node
6091       --  does not change, so it can safely be done in place. Protected
6092       --  function calls must keep their structure because they are
6093       --  subexpressions.
6094
6095       if Ekind (Nam) /= E_Function then
6096
6097          --  A protected operation that is not a function may modify the
6098          --  corresponding object, and cannot apply to a constant. If this
6099          --  is an internal call, the prefix is the type itself.
6100
6101          if Is_Protected_Type (Scope (Nam))
6102            and then not Is_Variable (Obj)
6103            and then (not Is_Entity_Name (Obj)
6104                        or else not Is_Type (Entity (Obj)))
6105          then
6106             Error_Msg_N
6107               ("prefix of protected procedure or entry call must be variable",
6108                Entry_Name);
6109          end if;
6110
6111          Actuals := Parameter_Associations (N);
6112          First_Named := First_Named_Actual (N);
6113
6114          Rewrite (N,
6115            Make_Entry_Call_Statement (Loc,
6116              Name                   => Entry_Name,
6117              Parameter_Associations => Actuals));
6118
6119          Set_First_Named_Actual (N, First_Named);
6120          Set_Analyzed (N, True);
6121
6122       --  Protected functions can return on the secondary stack, in which
6123       --  case we must trigger the transient scope mechanism.
6124
6125       elsif Expander_Active
6126         and then Requires_Transient_Scope (Etype (Nam))
6127       then
6128          Establish_Transient_Scope (N, Sec_Stack => True);
6129       end if;
6130    end Resolve_Entry_Call;
6131
6132    -------------------------
6133    -- Resolve_Equality_Op --
6134    -------------------------
6135
6136    --  Both arguments must have the same type, and the boolean context does
6137    --  not participate in the resolution. The first pass verifies that the
6138    --  interpretation is not ambiguous, and the type of the left argument is
6139    --  correctly set, or is Any_Type in case of ambiguity. If both arguments
6140    --  are strings or aggregates, allocators, or Null, they are ambiguous even
6141    --  though they carry a single (universal) type. Diagnose this case here.
6142
6143    procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
6144       L : constant Node_Id   := Left_Opnd (N);
6145       R : constant Node_Id   := Right_Opnd (N);
6146       T : Entity_Id := Find_Unique_Type (L, R);
6147
6148       function Find_Unique_Access_Type return Entity_Id;
6149       --  In the case of allocators, make a last-ditch attempt to find a single
6150       --  access type with the right designated type. This is semantically
6151       --  dubious, and of no interest to any real code, but c48008a makes it
6152       --  all worthwhile.
6153
6154       -----------------------------
6155       -- Find_Unique_Access_Type --
6156       -----------------------------
6157
6158       function Find_Unique_Access_Type return Entity_Id is
6159          Acc : Entity_Id;
6160          E   : Entity_Id;
6161          S   : Entity_Id;
6162
6163       begin
6164          if Ekind (Etype (R)) =  E_Allocator_Type then
6165             Acc := Designated_Type (Etype (R));
6166          elsif Ekind (Etype (L)) =  E_Allocator_Type then
6167             Acc := Designated_Type (Etype (L));
6168          else
6169             return Empty;
6170          end if;
6171
6172          S := Current_Scope;
6173          while S /= Standard_Standard loop
6174             E := First_Entity (S);
6175             while Present (E) loop
6176                if Is_Type (E)
6177                  and then Is_Access_Type (E)
6178                  and then Ekind (E) /= E_Allocator_Type
6179                  and then Designated_Type (E) = Base_Type (Acc)
6180                then
6181                   return E;
6182                end if;
6183
6184                Next_Entity (E);
6185             end loop;
6186
6187             S := Scope (S);
6188          end loop;
6189
6190          return Empty;
6191       end Find_Unique_Access_Type;
6192
6193    --  Start of processing for Resolve_Equality_Op
6194
6195    begin
6196       Check_No_Direct_Boolean_Operators (N);
6197
6198       Set_Etype (N, Base_Type (Typ));
6199       Generate_Reference (T, N, ' ');
6200
6201       if T = Any_Fixed then
6202          T := Unique_Fixed_Point_Type (L);
6203       end if;
6204
6205       if T /= Any_Type then
6206          if T = Any_String
6207            or else T = Any_Composite
6208            or else T = Any_Character
6209          then
6210             if T = Any_Character then
6211                Ambiguous_Character (L);
6212             else
6213                Error_Msg_N ("ambiguous operands for equality", N);
6214             end if;
6215
6216             Set_Etype (N, Any_Type);
6217             return;
6218
6219          elsif T = Any_Access
6220            or else Ekind (T) = E_Allocator_Type
6221            or else Ekind (T) = E_Access_Attribute_Type
6222          then
6223             T := Find_Unique_Access_Type;
6224
6225             if No (T) then
6226                Error_Msg_N ("ambiguous operands for equality", N);
6227                Set_Etype (N, Any_Type);
6228                return;
6229             end if;
6230          end if;
6231
6232          Resolve (L, T);
6233          Resolve (R, T);
6234
6235          --  If the unique type is a class-wide type then it will be expanded
6236          --  into a dispatching call to the predefined primitive. Therefore we
6237          --  check here for potential violation of such restriction.
6238
6239          if Is_Class_Wide_Type (T) then
6240             Check_Restriction (No_Dispatching_Calls, N);
6241          end if;
6242
6243          if Warn_On_Redundant_Constructs
6244            and then Comes_From_Source (N)
6245            and then Is_Entity_Name (R)
6246            and then Entity (R) = Standard_True
6247            and then Comes_From_Source (R)
6248          then
6249             Error_Msg_N ("?comparison with True is redundant!", R);
6250          end if;
6251
6252          Check_Unset_Reference (L);
6253          Check_Unset_Reference (R);
6254          Generate_Operator_Reference (N, T);
6255          Check_Low_Bound_Tested (N);
6256
6257          --  If this is an inequality, it may be the implicit inequality
6258          --  created for a user-defined operation, in which case the corres-
6259          --  ponding equality operation is not intrinsic, and the operation
6260          --  cannot be constant-folded. Else fold.
6261
6262          if Nkind (N) = N_Op_Eq
6263            or else Comes_From_Source (Entity (N))
6264            or else Ekind (Entity (N)) = E_Operator
6265            or else Is_Intrinsic_Subprogram
6266              (Corresponding_Equality (Entity (N)))
6267          then
6268             Eval_Relational_Op (N);
6269
6270          elsif Nkind (N) = N_Op_Ne
6271            and then Is_Abstract_Subprogram (Entity (N))
6272          then
6273             Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
6274          end if;
6275
6276          --  Ada 2005: If one operand is an anonymous access type, convert the
6277          --  other operand to it, to ensure that the underlying types match in
6278          --  the back-end. Same for access_to_subprogram, and the conversion
6279          --  verifies that the types are subtype conformant.
6280
6281          --  We apply the same conversion in the case one of the operands is a
6282          --  private subtype of the type of the other.
6283
6284          --  Why the Expander_Active test here ???
6285
6286          if Expander_Active
6287            and then
6288              (Ekind (T) =  E_Anonymous_Access_Type
6289                or else Ekind (T) = E_Anonymous_Access_Subprogram_Type
6290                or else Is_Private_Type (T))
6291          then
6292             if Etype (L) /= T then
6293                Rewrite (L,
6294                  Make_Unchecked_Type_Conversion (Sloc (L),
6295                    Subtype_Mark => New_Occurrence_Of (T, Sloc (L)),
6296                    Expression   => Relocate_Node (L)));
6297                Analyze_And_Resolve (L, T);
6298             end if;
6299
6300             if (Etype (R)) /= T then
6301                Rewrite (R,
6302                   Make_Unchecked_Type_Conversion (Sloc (R),
6303                     Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)),
6304                     Expression   => Relocate_Node (R)));
6305                Analyze_And_Resolve (R, T);
6306             end if;
6307          end if;
6308       end if;
6309    end Resolve_Equality_Op;
6310
6311    ----------------------------------
6312    -- Resolve_Explicit_Dereference --
6313    ----------------------------------
6314
6315    procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
6316       Loc   : constant Source_Ptr := Sloc (N);
6317       New_N : Node_Id;
6318       P     : constant Node_Id := Prefix (N);
6319       I     : Interp_Index;
6320       It    : Interp;
6321
6322    begin
6323       Check_Fully_Declared_Prefix (Typ, P);
6324
6325       if Is_Overloaded (P) then
6326
6327          --  Use the context type to select the prefix that has the correct
6328          --  designated type.
6329
6330          Get_First_Interp (P, I, It);
6331          while Present (It.Typ) loop
6332             exit when Is_Access_Type (It.Typ)
6333               and then Covers (Typ, Designated_Type (It.Typ));
6334             Get_Next_Interp (I, It);
6335          end loop;
6336
6337          if Present (It.Typ) then
6338             Resolve (P, It.Typ);
6339          else
6340             --  If no interpretation covers the designated type of the prefix,
6341             --  this is the pathological case where not all implementations of
6342             --  the prefix allow the interpretation of the node as a call. Now
6343             --  that the expected type is known, Remove other interpretations
6344             --  from prefix, rewrite it as a call, and resolve again, so that
6345             --  the proper call node is generated.
6346
6347             Get_First_Interp (P, I, It);
6348             while Present (It.Typ) loop
6349                if Ekind (It.Typ) /= E_Access_Subprogram_Type then
6350                   Remove_Interp (I);
6351                end if;
6352
6353                Get_Next_Interp (I, It);
6354             end loop;
6355
6356             New_N :=
6357               Make_Function_Call (Loc,
6358                 Name =>
6359                   Make_Explicit_Dereference (Loc,
6360                     Prefix => P),
6361                 Parameter_Associations => New_List);
6362
6363             Save_Interps (N, New_N);
6364             Rewrite (N, New_N);
6365             Analyze_And_Resolve (N, Typ);
6366             return;
6367          end if;
6368
6369          Set_Etype (N, Designated_Type (It.Typ));
6370
6371       else
6372          Resolve (P);
6373       end if;
6374
6375       if Is_Access_Type (Etype (P)) then
6376          Apply_Access_Check (N);
6377       end if;
6378
6379       --  If the designated type is a packed unconstrained array type, and the
6380       --  explicit dereference is not in the context of an attribute reference,
6381       --  then we must compute and set the actual subtype, since it is needed
6382       --  by Gigi. The reason we exclude the attribute case is that this is
6383       --  handled fine by Gigi, and in fact we use such attributes to build the
6384       --  actual subtype. We also exclude generated code (which builds actual
6385       --  subtypes directly if they are needed).
6386
6387       if Is_Array_Type (Etype (N))
6388         and then Is_Packed (Etype (N))
6389         and then not Is_Constrained (Etype (N))
6390         and then Nkind (Parent (N)) /= N_Attribute_Reference
6391         and then Comes_From_Source (N)
6392       then
6393          Set_Etype (N, Get_Actual_Subtype (N));
6394       end if;
6395
6396       --  Note: there is no Eval processing required for an explicit deference,
6397       --  because the type is known to be an allocators, and allocator
6398       --  expressions can never be static.
6399
6400    end Resolve_Explicit_Dereference;
6401
6402    -------------------------------
6403    -- Resolve_Indexed_Component --
6404    -------------------------------
6405
6406    procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
6407       Name       : constant Node_Id := Prefix  (N);
6408       Expr       : Node_Id;
6409       Array_Type : Entity_Id := Empty; -- to prevent junk warning
6410       Index      : Node_Id;
6411
6412    begin
6413       if Is_Overloaded (Name) then
6414
6415          --  Use the context type to select the prefix that yields the correct
6416          --  component type.
6417
6418          declare
6419             I     : Interp_Index;
6420             It    : Interp;
6421             I1    : Interp_Index := 0;
6422             P     : constant Node_Id := Prefix (N);
6423             Found : Boolean := False;
6424
6425          begin
6426             Get_First_Interp (P, I, It);
6427             while Present (It.Typ) loop
6428                if (Is_Array_Type (It.Typ)
6429                      and then Covers (Typ, Component_Type (It.Typ)))
6430                  or else (Is_Access_Type (It.Typ)
6431                             and then Is_Array_Type (Designated_Type (It.Typ))
6432                             and then Covers
6433                               (Typ, Component_Type (Designated_Type (It.Typ))))
6434                then
6435                   if Found then
6436                      It := Disambiguate (P, I1, I, Any_Type);
6437
6438                      if It = No_Interp then
6439                         Error_Msg_N ("ambiguous prefix for indexing",  N);
6440                         Set_Etype (N, Typ);
6441                         return;
6442
6443                      else
6444                         Found := True;
6445                         Array_Type := It.Typ;
6446                         I1 := I;
6447                      end if;
6448
6449                   else
6450                      Found := True;
6451                      Array_Type := It.Typ;
6452                      I1 := I;
6453                   end if;
6454                end if;
6455
6456                Get_Next_Interp (I, It);
6457             end loop;
6458          end;
6459
6460       else
6461          Array_Type := Etype (Name);
6462       end if;
6463
6464       Resolve (Name, Array_Type);
6465       Array_Type := Get_Actual_Subtype_If_Available (Name);
6466
6467       --  If prefix is access type, dereference to get real array type.
6468       --  Note: we do not apply an access check because the expander always
6469       --  introduces an explicit dereference, and the check will happen there.
6470
6471       if Is_Access_Type (Array_Type) then
6472          Array_Type := Designated_Type (Array_Type);
6473       end if;
6474
6475       --  If name was overloaded, set component type correctly now
6476       --  If a misplaced call to an entry family (which has no index types)
6477       --  return. Error will be diagnosed from calling context.
6478
6479       if Is_Array_Type (Array_Type) then
6480          Set_Etype (N, Component_Type (Array_Type));
6481       else
6482          return;
6483       end if;
6484
6485       Index := First_Index (Array_Type);
6486       Expr  := First (Expressions (N));
6487
6488       --  The prefix may have resolved to a string literal, in which case its
6489       --  etype has a special representation. This is only possible currently
6490       --  if the prefix is a static concatenation, written in functional
6491       --  notation.
6492
6493       if Ekind (Array_Type) = E_String_Literal_Subtype then
6494          Resolve (Expr, Standard_Positive);
6495
6496       else
6497          while Present (Index) and Present (Expr) loop
6498             Resolve (Expr, Etype (Index));
6499             Check_Unset_Reference (Expr);
6500
6501             if Is_Scalar_Type (Etype (Expr)) then
6502                Apply_Scalar_Range_Check (Expr, Etype (Index));
6503             else
6504                Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
6505             end if;
6506
6507             Next_Index (Index);
6508             Next (Expr);
6509          end loop;
6510       end if;
6511
6512       --  Do not generate the warning on suspicious index if we are analyzing
6513       --  package Ada.Tags; otherwise we will report the warning with the
6514       --  Prims_Ptr field of the dispatch table.
6515
6516       if Scope (Etype (Prefix (N))) = Standard_Standard
6517         or else not
6518           Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))),
6519                   Ada_Tags)
6520       then
6521          Warn_On_Suspicious_Index (Name, First (Expressions (N)));
6522          Eval_Indexed_Component (N);
6523       end if;
6524    end Resolve_Indexed_Component;
6525
6526    -----------------------------
6527    -- Resolve_Integer_Literal --
6528    -----------------------------
6529
6530    procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
6531    begin
6532       Set_Etype (N, Typ);
6533       Eval_Integer_Literal (N);
6534    end Resolve_Integer_Literal;
6535
6536    --------------------------------
6537    -- Resolve_Intrinsic_Operator --
6538    --------------------------------
6539
6540    procedure Resolve_Intrinsic_Operator  (N : Node_Id; Typ : Entity_Id) is
6541       Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
6542       Op   : Entity_Id;
6543       Arg1 : Node_Id;
6544       Arg2 : Node_Id;
6545
6546    begin
6547       Op := Entity (N);
6548       while Scope (Op) /= Standard_Standard loop
6549          Op := Homonym (Op);
6550          pragma Assert (Present (Op));
6551       end loop;
6552
6553       Set_Entity (N, Op);
6554       Set_Is_Overloaded (N, False);
6555
6556       --  If the operand type is private, rewrite with suitable conversions on
6557       --  the operands and the result, to expose the proper underlying numeric
6558       --  type.
6559
6560       if Is_Private_Type (Typ) then
6561          Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd  (N));
6562
6563          if Nkind (N) = N_Op_Expon then
6564             Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
6565          else
6566             Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
6567          end if;
6568
6569          Save_Interps (Left_Opnd (N),  Expression (Arg1));
6570          Save_Interps (Right_Opnd (N), Expression (Arg2));
6571
6572          Set_Left_Opnd  (N, Arg1);
6573          Set_Right_Opnd (N, Arg2);
6574
6575          Set_Etype (N, Btyp);
6576          Rewrite (N, Unchecked_Convert_To (Typ, N));
6577          Resolve (N, Typ);
6578
6579       elsif Typ /= Etype (Left_Opnd (N))
6580         or else Typ /= Etype (Right_Opnd (N))
6581       then
6582          --  Add explicit conversion where needed, and save interpretations in
6583          --  case operands are overloaded.
6584
6585          Arg1 := Convert_To (Typ, Left_Opnd  (N));
6586          Arg2 := Convert_To (Typ, Right_Opnd (N));
6587
6588          if Nkind (Arg1) = N_Type_Conversion then
6589             Save_Interps (Left_Opnd (N), Expression (Arg1));
6590          else
6591             Save_Interps (Left_Opnd (N), Arg1);
6592          end if;
6593
6594          if Nkind (Arg2) = N_Type_Conversion then
6595             Save_Interps (Right_Opnd (N), Expression (Arg2));
6596          else
6597             Save_Interps (Right_Opnd (N), Arg2);
6598          end if;
6599
6600          Rewrite (Left_Opnd  (N), Arg1);
6601          Rewrite (Right_Opnd (N), Arg2);
6602          Analyze (Arg1);
6603          Analyze (Arg2);
6604          Resolve_Arithmetic_Op (N, Typ);
6605
6606       else
6607          Resolve_Arithmetic_Op (N, Typ);
6608       end if;
6609    end Resolve_Intrinsic_Operator;
6610
6611    --------------------------------------
6612    -- Resolve_Intrinsic_Unary_Operator --
6613    --------------------------------------
6614
6615    procedure Resolve_Intrinsic_Unary_Operator
6616      (N   : Node_Id;
6617       Typ : Entity_Id)
6618    is
6619       Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
6620       Op   : Entity_Id;
6621       Arg2 : Node_Id;
6622
6623    begin
6624       Op := Entity (N);
6625       while Scope (Op) /= Standard_Standard loop
6626          Op := Homonym (Op);
6627          pragma Assert (Present (Op));
6628       end loop;
6629
6630       Set_Entity (N, Op);
6631
6632       if Is_Private_Type (Typ) then
6633          Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
6634          Save_Interps (Right_Opnd (N), Expression (Arg2));
6635
6636          Set_Right_Opnd (N, Arg2);
6637
6638          Set_Etype (N, Btyp);
6639          Rewrite (N, Unchecked_Convert_To (Typ, N));
6640          Resolve (N, Typ);
6641
6642       else
6643          Resolve_Unary_Op (N, Typ);
6644       end if;
6645    end Resolve_Intrinsic_Unary_Operator;
6646
6647    ------------------------
6648    -- Resolve_Logical_Op --
6649    ------------------------
6650
6651    procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
6652       B_Typ : Entity_Id;
6653
6654    begin
6655       Check_No_Direct_Boolean_Operators (N);
6656
6657       --  Predefined operations on scalar types yield the base type. On the
6658       --  other hand, logical operations on arrays yield the type of the
6659       --  arguments (and the context).
6660
6661       if Is_Array_Type (Typ) then
6662          B_Typ := Typ;
6663       else
6664          B_Typ := Base_Type (Typ);
6665       end if;
6666
6667       --  The following test is required because the operands of the operation
6668       --  may be literals, in which case the resulting type appears to be
6669       --  compatible with a signed integer type, when in fact it is compatible
6670       --  only with modular types. If the context itself is universal, the
6671       --  operation is illegal.
6672
6673       if not Valid_Boolean_Arg (Typ) then
6674          Error_Msg_N ("invalid context for logical operation", N);
6675          Set_Etype (N, Any_Type);
6676          return;
6677
6678       elsif Typ = Any_Modular then
6679          Error_Msg_N
6680            ("no modular type available in this context", N);
6681          Set_Etype (N, Any_Type);
6682          return;
6683       elsif Is_Modular_Integer_Type (Typ)
6684         and then Etype (Left_Opnd (N)) = Universal_Integer
6685         and then Etype (Right_Opnd (N)) = Universal_Integer
6686       then
6687          Check_For_Visible_Operator (N, B_Typ);
6688       end if;
6689
6690       Resolve (Left_Opnd (N), B_Typ);
6691       Resolve (Right_Opnd (N), B_Typ);
6692
6693       Check_Unset_Reference (Left_Opnd  (N));
6694       Check_Unset_Reference (Right_Opnd (N));
6695
6696       Set_Etype (N, B_Typ);
6697       Generate_Operator_Reference (N, B_Typ);
6698       Eval_Logical_Op (N);
6699    end Resolve_Logical_Op;
6700
6701    ---------------------------
6702    -- Resolve_Membership_Op --
6703    ---------------------------
6704
6705    --  The context can only be a boolean type, and does not determine
6706    --  the arguments. Arguments should be unambiguous, but the preference
6707    --  rule for universal types applies.
6708
6709    procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
6710       pragma Warnings (Off, Typ);
6711
6712       L : constant Node_Id := Left_Opnd (N);
6713       R : constant Node_Id := Right_Opnd (N);
6714       T : Entity_Id;
6715
6716    begin
6717       if L = Error or else R = Error then
6718          return;
6719       end if;
6720
6721       if not Is_Overloaded (R)
6722         and then
6723           (Etype (R) = Universal_Integer or else
6724            Etype (R) = Universal_Real)
6725         and then Is_Overloaded (L)
6726       then
6727          T := Etype (R);
6728
6729       --  Ada 2005 (AI-251): Support the following case:
6730
6731       --      type I is interface;
6732       --      type T is tagged ...
6733
6734       --      function Test (O : I'Class) is
6735       --      begin
6736       --         return O in T'Class.
6737       --      end Test;
6738
6739       --  In this case we have nothing else to do. The membership test will be
6740       --  done at run-time.
6741
6742       elsif Ada_Version >= Ada_05
6743         and then Is_Class_Wide_Type (Etype (L))
6744         and then Is_Interface (Etype (L))
6745         and then Is_Class_Wide_Type (Etype (R))
6746         and then not Is_Interface (Etype (R))
6747       then
6748          return;
6749
6750       else
6751          T := Intersect_Types (L, R);
6752       end if;
6753
6754       Resolve (L, T);
6755       Check_Unset_Reference (L);
6756
6757       if Nkind (R) = N_Range
6758         and then not Is_Scalar_Type (T)
6759       then
6760          Error_Msg_N ("scalar type required for range", R);
6761       end if;
6762
6763       if Is_Entity_Name (R) then
6764          Freeze_Expression (R);
6765       else
6766          Resolve (R, T);
6767          Check_Unset_Reference (R);
6768       end if;
6769
6770       Eval_Membership_Op (N);
6771    end Resolve_Membership_Op;
6772
6773    ------------------
6774    -- Resolve_Null --
6775    ------------------
6776
6777    procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
6778       Loc : constant Source_Ptr := Sloc (N);
6779
6780    begin
6781       --  Handle restriction against anonymous null access values This
6782       --  restriction can be turned off using -gnatdj.
6783
6784       --  Ada 2005 (AI-231): Remove restriction
6785
6786       if Ada_Version < Ada_05
6787         and then not Debug_Flag_J
6788         and then Ekind (Typ) = E_Anonymous_Access_Type
6789         and then Comes_From_Source (N)
6790       then
6791          --  In the common case of a call which uses an explicitly null value
6792          --  for an access parameter, give specialized error message.
6793
6794          if Nkind_In (Parent (N), N_Procedure_Call_Statement,
6795                                   N_Function_Call)
6796          then
6797             Error_Msg_N
6798               ("null is not allowed as argument for an access parameter", N);
6799
6800          --  Standard message for all other cases (are there any?)
6801
6802          else
6803             Error_Msg_N
6804               ("null cannot be of an anonymous access type", N);
6805          end if;
6806       end if;
6807
6808       --  Ada 2005 (AI-231): Generate the null-excluding check in case of
6809       --  assignment to a null-excluding object
6810
6811       if Ada_Version >= Ada_05
6812         and then Can_Never_Be_Null (Typ)
6813         and then Nkind (Parent (N)) = N_Assignment_Statement
6814       then
6815          if not Inside_Init_Proc then
6816             Insert_Action
6817               (Compile_Time_Constraint_Error (N,
6818                  "(Ada 2005) null not allowed in null-excluding objects?"),
6819                Make_Raise_Constraint_Error (Loc,
6820                  Reason => CE_Access_Check_Failed));
6821          else
6822             Insert_Action (N,
6823               Make_Raise_Constraint_Error (Loc,
6824                 Reason => CE_Access_Check_Failed));
6825          end if;
6826       end if;
6827
6828       --  In a distributed context, null for a remote access to subprogram may
6829       --  need to be replaced with a special record aggregate. In this case,
6830       --  return after having done the transformation.
6831
6832       if (Ekind (Typ) = E_Record_Type
6833            or else Is_Remote_Access_To_Subprogram_Type (Typ))
6834         and then Remote_AST_Null_Value (N, Typ)
6835       then
6836          return;
6837       end if;
6838
6839       --  The null literal takes its type from the context
6840
6841       Set_Etype (N, Typ);
6842    end Resolve_Null;
6843
6844    -----------------------
6845    -- Resolve_Op_Concat --
6846    -----------------------
6847
6848    procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
6849
6850       --  We wish to avoid deep recursion, because concatenations are often
6851       --  deeply nested, as in A&B&...&Z. Therefore, we walk down the left
6852       --  operands nonrecursively until we find something that is not a simple
6853       --  concatenation (A in this case). We resolve that, and then walk back
6854       --  up the tree following Parent pointers, calling Resolve_Op_Concat_Rest
6855       --  to do the rest of the work at each level. The Parent pointers allow
6856       --  us to avoid recursion, and thus avoid running out of memory. See also
6857       --  Sem_Ch4.Analyze_Concatenation, where a similar approach is used.
6858
6859       NN  : Node_Id := N;
6860       Op1 : Node_Id;
6861
6862    begin
6863       --  The following code is equivalent to:
6864
6865       --    Resolve_Op_Concat_First (NN, Typ);
6866       --    Resolve_Op_Concat_Arg (N, ...);
6867       --    Resolve_Op_Concat_Rest (N, Typ);
6868
6869       --  where the Resolve_Op_Concat_Arg call recurses back here if the left
6870       --  operand is a concatenation.
6871
6872       --  Walk down left operands
6873
6874       loop
6875          Resolve_Op_Concat_First (NN, Typ);
6876          Op1 := Left_Opnd (NN);
6877          exit when not (Nkind (Op1) = N_Op_Concat
6878                          and then not Is_Array_Type (Component_Type (Typ))
6879                          and then Entity (Op1) = Entity (NN));
6880          NN := Op1;
6881       end loop;
6882
6883       --  Now (given the above example) NN is A&B and Op1 is A
6884
6885       --  First resolve Op1 ...
6886
6887       Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd  (NN));
6888
6889       --  ... then walk NN back up until we reach N (where we started), calling
6890       --  Resolve_Op_Concat_Rest along the way.
6891
6892       loop
6893          Resolve_Op_Concat_Rest (NN, Typ);
6894          exit when NN = N;
6895          NN := Parent (NN);
6896       end loop;
6897    end Resolve_Op_Concat;
6898
6899    ---------------------------
6900    -- Resolve_Op_Concat_Arg --
6901    ---------------------------
6902
6903    procedure Resolve_Op_Concat_Arg
6904      (N       : Node_Id;
6905       Arg     : Node_Id;
6906       Typ     : Entity_Id;
6907       Is_Comp : Boolean)
6908    is
6909       Btyp : constant Entity_Id := Base_Type (Typ);
6910
6911    begin
6912       if In_Instance then
6913          if Is_Comp
6914            or else (not Is_Overloaded (Arg)
6915                      and then Etype (Arg) /= Any_Composite
6916                      and then Covers (Component_Type (Typ), Etype (Arg)))
6917          then
6918             Resolve (Arg, Component_Type (Typ));
6919          else
6920             Resolve (Arg, Btyp);
6921          end if;
6922
6923       elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
6924          if Nkind (Arg) = N_Aggregate
6925            and then Is_Composite_Type (Component_Type (Typ))
6926          then
6927             if Is_Private_Type (Component_Type (Typ)) then
6928                Resolve (Arg, Btyp);
6929             else
6930                Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
6931                Set_Etype (Arg, Any_Type);
6932             end if;
6933
6934          else
6935             if Is_Overloaded (Arg)
6936               and then Has_Compatible_Type (Arg, Typ)
6937               and then Etype (Arg) /= Any_Type
6938             then
6939                declare
6940                   I    : Interp_Index;
6941                   It   : Interp;
6942                   Func : Entity_Id;
6943
6944                begin
6945                   Get_First_Interp (Arg, I, It);
6946                   Func := It.Nam;
6947                   Get_Next_Interp (I, It);
6948
6949                   --  Special-case the error message when the overloading is
6950                   --  caused by a function that yields an array and can be
6951                   --  called without parameters.
6952
6953                   if It.Nam = Func then
6954                      Error_Msg_Sloc := Sloc (Func);
6955                      Error_Msg_N ("ambiguous call to function#", Arg);
6956                      Error_Msg_NE
6957                        ("\\interpretation as call yields&", Arg, Typ);
6958                      Error_Msg_NE
6959                        ("\\interpretation as indexing of call yields&",
6960                          Arg, Component_Type (Typ));
6961
6962                   else
6963                      Error_Msg_N
6964                        ("ambiguous operand for concatenation!", Arg);
6965                      Get_First_Interp (Arg, I, It);
6966                      while Present (It.Nam) loop
6967                         Error_Msg_Sloc := Sloc (It.Nam);
6968
6969                         if Base_Type (It.Typ) = Base_Type (Typ)
6970                           or else Base_Type (It.Typ) =
6971                             Base_Type (Component_Type (Typ))
6972                         then
6973                            Error_Msg_N -- CODEFIX
6974                              ("\\possible interpretation#", Arg);
6975                         end if;
6976
6977                         Get_Next_Interp (I, It);
6978                      end loop;
6979                   end if;
6980                end;
6981             end if;
6982
6983             Resolve (Arg, Component_Type (Typ));
6984
6985             if Nkind (Arg) = N_String_Literal then
6986                Set_Etype (Arg, Component_Type (Typ));
6987             end if;
6988
6989             if Arg = Left_Opnd (N) then
6990                Set_Is_Component_Left_Opnd (N);
6991             else
6992                Set_Is_Component_Right_Opnd (N);
6993             end if;
6994          end if;
6995
6996       else
6997          Resolve (Arg, Btyp);
6998       end if;
6999
7000       Check_Unset_Reference (Arg);
7001    end Resolve_Op_Concat_Arg;
7002
7003    -----------------------------
7004    -- Resolve_Op_Concat_First --
7005    -----------------------------
7006
7007    procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is
7008       Btyp : constant Entity_Id := Base_Type (Typ);
7009       Op1  : constant Node_Id := Left_Opnd (N);
7010       Op2  : constant Node_Id := Right_Opnd (N);
7011
7012    begin
7013       --  The parser folds an enormous sequence of concatenations of string
7014       --  literals into "" & "...", where the Is_Folded_In_Parser flag is set
7015       --  in the right operand. If the expression resolves to a predefined "&"
7016       --  operator, all is well. Otherwise, the parser's folding is wrong, so
7017       --  we give an error. See P_Simple_Expression in Par.Ch4.
7018
7019       if Nkind (Op2) = N_String_Literal
7020         and then Is_Folded_In_Parser (Op2)
7021         and then Ekind (Entity (N)) = E_Function
7022       then
7023          pragma Assert (Nkind (Op1) = N_String_Literal  --  should be ""
7024                and then String_Length (Strval (Op1)) = 0);
7025          Error_Msg_N ("too many user-defined concatenations", N);
7026          return;
7027       end if;
7028
7029       Set_Etype (N, Btyp);
7030
7031       if Is_Limited_Composite (Btyp) then
7032          Error_Msg_N ("concatenation not available for limited array", N);
7033          Explain_Limited_Type (Btyp, N);
7034       end if;
7035    end Resolve_Op_Concat_First;
7036
7037    ----------------------------
7038    -- Resolve_Op_Concat_Rest --
7039    ----------------------------
7040
7041    procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is
7042       Op1  : constant Node_Id := Left_Opnd (N);
7043       Op2  : constant Node_Id := Right_Opnd (N);
7044
7045    begin
7046       Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd  (N));
7047
7048       Generate_Operator_Reference (N, Typ);
7049
7050       if Is_String_Type (Typ) then
7051          Eval_Concatenation (N);
7052       end if;
7053
7054       --  If this is not a static concatenation, but the result is a string
7055       --  type (and not an array of strings) ensure that static string operands
7056       --  have their subtypes properly constructed.
7057
7058       if Nkind (N) /= N_String_Literal
7059         and then Is_Character_Type (Component_Type (Typ))
7060       then
7061          Set_String_Literal_Subtype (Op1, Typ);
7062          Set_String_Literal_Subtype (Op2, Typ);
7063       end if;
7064    end Resolve_Op_Concat_Rest;
7065
7066    ----------------------
7067    -- Resolve_Op_Expon --
7068    ----------------------
7069
7070    procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
7071       B_Typ : constant Entity_Id := Base_Type (Typ);
7072
7073    begin
7074       --  Catch attempts to do fixed-point exponentiation with universal
7075       --  operands, which is a case where the illegality is not caught during
7076       --  normal operator analysis.
7077
7078       if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
7079          Error_Msg_N ("exponentiation not available for fixed point", N);
7080          return;
7081       end if;
7082
7083       if Comes_From_Source (N)
7084         and then Ekind (Entity (N)) = E_Function
7085         and then Is_Imported (Entity (N))
7086         and then Is_Intrinsic_Subprogram (Entity (N))
7087       then
7088          Resolve_Intrinsic_Operator (N, Typ);
7089          return;
7090       end if;
7091
7092       if Etype (Left_Opnd (N)) = Universal_Integer
7093         or else Etype (Left_Opnd (N)) = Universal_Real
7094       then
7095          Check_For_Visible_Operator (N, B_Typ);
7096       end if;
7097
7098       --  We do the resolution using the base type, because intermediate values
7099       --  in expressions always are of the base type, not a subtype of it.
7100
7101       Resolve (Left_Opnd (N), B_Typ);
7102       Resolve (Right_Opnd (N), Standard_Integer);
7103
7104       Check_Unset_Reference (Left_Opnd  (N));
7105       Check_Unset_Reference (Right_Opnd (N));
7106
7107       Set_Etype (N, B_Typ);
7108       Generate_Operator_Reference (N, B_Typ);
7109       Eval_Op_Expon (N);
7110
7111       --  Set overflow checking bit. Much cleverer code needed here eventually
7112       --  and perhaps the Resolve routines should be separated for the various
7113       --  arithmetic operations, since they will need different processing. ???
7114
7115       if Nkind (N) in N_Op then
7116          if not Overflow_Checks_Suppressed (Etype (N)) then
7117             Enable_Overflow_Check (N);
7118          end if;
7119       end if;
7120    end Resolve_Op_Expon;
7121
7122    --------------------
7123    -- Resolve_Op_Not --
7124    --------------------
7125
7126    procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
7127       B_Typ : Entity_Id;
7128
7129       function Parent_Is_Boolean return Boolean;
7130       --  This function determines if the parent node is a boolean operator
7131       --  or operation (comparison op, membership test, or short circuit form)
7132       --  and the not in question is the left operand of this operation.
7133       --  Note that if the not is in parens, then false is returned.
7134
7135       -----------------------
7136       -- Parent_Is_Boolean --
7137       -----------------------
7138
7139       function Parent_Is_Boolean return Boolean is
7140       begin
7141          if Paren_Count (N) /= 0 then
7142             return False;
7143
7144          else
7145             case Nkind (Parent (N)) is
7146                when N_Op_And   |
7147                     N_Op_Eq    |
7148                     N_Op_Ge    |
7149                     N_Op_Gt    |
7150                     N_Op_Le    |
7151                     N_Op_Lt    |
7152                     N_Op_Ne    |
7153                     N_Op_Or    |
7154                     N_Op_Xor   |
7155                     N_In       |
7156                     N_Not_In   |
7157                     N_And_Then |
7158                     N_Or_Else  =>
7159
7160                   return Left_Opnd (Parent (N)) = N;
7161
7162                when others =>
7163                   return False;
7164             end case;
7165          end if;
7166       end Parent_Is_Boolean;
7167
7168    --  Start of processing for Resolve_Op_Not
7169
7170    begin
7171       --  Predefined operations on scalar types yield the base type. On the
7172       --  other hand, logical operations on arrays yield the type of the
7173       --  arguments (and the context).
7174
7175       if Is_Array_Type (Typ) then
7176          B_Typ := Typ;
7177       else
7178          B_Typ := Base_Type (Typ);
7179       end if;
7180
7181       --  Straightforward case of incorrect arguments
7182
7183       if not Valid_Boolean_Arg (Typ) then
7184          Error_Msg_N ("invalid operand type for operator&", N);
7185          Set_Etype (N, Any_Type);
7186          return;
7187
7188       --  Special case of probable missing parens
7189
7190       elsif Typ = Universal_Integer or else Typ = Any_Modular then
7191          if Parent_Is_Boolean then
7192             Error_Msg_N
7193               ("operand of not must be enclosed in parentheses",
7194                Right_Opnd (N));
7195          else
7196             Error_Msg_N
7197               ("no modular type available in this context", N);
7198          end if;
7199
7200          Set_Etype (N, Any_Type);
7201          return;
7202
7203       --  OK resolution of not
7204
7205       else
7206          --  Warn if non-boolean types involved. This is a case like not a < b
7207          --  where a and b are modular, where we will get (not a) < b and most
7208          --  likely not (a < b) was intended.
7209
7210          if Warn_On_Questionable_Missing_Parens
7211            and then not Is_Boolean_Type (Typ)
7212            and then Parent_Is_Boolean
7213          then
7214             Error_Msg_N ("?not expression should be parenthesized here!", N);
7215          end if;
7216
7217          --  Warn on double negation if checking redundant constructs
7218
7219          if Warn_On_Redundant_Constructs
7220            and then Comes_From_Source (N)
7221            and then Comes_From_Source (Right_Opnd (N))
7222            and then Root_Type (Typ) = Standard_Boolean
7223            and then Nkind (Right_Opnd (N)) = N_Op_Not
7224          then
7225             Error_Msg_N ("redundant double negation?", N);
7226          end if;
7227
7228          --  Complete resolution and evaluation of NOT
7229
7230          Resolve (Right_Opnd (N), B_Typ);
7231          Check_Unset_Reference (Right_Opnd (N));
7232          Set_Etype (N, B_Typ);
7233          Generate_Operator_Reference (N, B_Typ);
7234          Eval_Op_Not (N);
7235       end if;
7236    end Resolve_Op_Not;
7237
7238    -----------------------------
7239    -- Resolve_Operator_Symbol --
7240    -----------------------------
7241
7242    --  Nothing to be done, all resolved already
7243
7244    procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
7245       pragma Warnings (Off, N);
7246       pragma Warnings (Off, Typ);
7247
7248    begin
7249       null;
7250    end Resolve_Operator_Symbol;
7251
7252    ----------------------------------
7253    -- Resolve_Qualified_Expression --
7254    ----------------------------------
7255
7256    procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
7257       pragma Warnings (Off, Typ);
7258
7259       Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
7260       Expr       : constant Node_Id   := Expression (N);
7261
7262    begin
7263       Resolve (Expr, Target_Typ);
7264
7265       --  A qualified expression requires an exact match of the type,
7266       --  class-wide matching is not allowed. However, if the qualifying
7267       --  type is specific and the expression has a class-wide type, it
7268       --  may still be okay, since it can be the result of the expansion
7269       --  of a call to a dispatching function, so we also have to check
7270       --  class-wideness of the type of the expression's original node.
7271
7272       if (Is_Class_Wide_Type (Target_Typ)
7273            or else
7274              (Is_Class_Wide_Type (Etype (Expr))
7275                and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
7276         and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
7277       then
7278          Wrong_Type (Expr, Target_Typ);
7279       end if;
7280
7281       --  If the target type is unconstrained, then we reset the type of
7282       --  the result from the type of the expression. For other cases, the
7283       --  actual subtype of the expression is the target type.
7284
7285       if Is_Composite_Type (Target_Typ)
7286         and then not Is_Constrained (Target_Typ)
7287       then
7288          Set_Etype (N, Etype (Expr));
7289       end if;
7290
7291       Eval_Qualified_Expression (N);
7292    end Resolve_Qualified_Expression;
7293
7294    -------------------
7295    -- Resolve_Range --
7296    -------------------
7297
7298    procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
7299       L : constant Node_Id := Low_Bound (N);
7300       H : constant Node_Id := High_Bound (N);
7301
7302    begin
7303       Set_Etype (N, Typ);
7304       Resolve (L, Typ);
7305       Resolve (H, Typ);
7306
7307       Check_Unset_Reference (L);
7308       Check_Unset_Reference (H);
7309
7310       --  We have to check the bounds for being within the base range as
7311       --  required for a non-static context. Normally this is automatic and
7312       --  done as part of evaluating expressions, but the N_Range node is an
7313       --  exception, since in GNAT we consider this node to be a subexpression,
7314       --  even though in Ada it is not. The circuit in Sem_Eval could check for
7315       --  this, but that would put the test on the main evaluation path for
7316       --  expressions.
7317
7318       Check_Non_Static_Context (L);
7319       Check_Non_Static_Context (H);
7320
7321       --  Check for an ambiguous range over character literals. This will
7322       --  happen with a membership test involving only literals.
7323
7324       if Typ = Any_Character then
7325          Ambiguous_Character (L);
7326          Set_Etype (N, Any_Type);
7327          return;
7328       end if;
7329
7330       --  If bounds are static, constant-fold them, so size computations
7331       --  are identical between front-end and back-end. Do not perform this
7332       --  transformation while analyzing generic units, as type information
7333       --  would then be lost when reanalyzing the constant node in the
7334       --  instance.
7335
7336       if Is_Discrete_Type (Typ) and then Expander_Active then
7337          if Is_OK_Static_Expression (L) then
7338             Fold_Uint  (L, Expr_Value (L), Is_Static_Expression (L));
7339          end if;
7340
7341          if Is_OK_Static_Expression (H) then
7342             Fold_Uint  (H, Expr_Value (H), Is_Static_Expression (H));
7343          end if;
7344       end if;
7345    end Resolve_Range;
7346
7347    --------------------------
7348    -- Resolve_Real_Literal --
7349    --------------------------
7350
7351    procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
7352       Actual_Typ : constant Entity_Id := Etype (N);
7353
7354    begin
7355       --  Special processing for fixed-point literals to make sure that the
7356       --  value is an exact multiple of small where this is required. We
7357       --  skip this for the universal real case, and also for generic types.
7358
7359       if Is_Fixed_Point_Type (Typ)
7360         and then Typ /= Universal_Fixed
7361         and then Typ /= Any_Fixed
7362         and then not Is_Generic_Type (Typ)
7363       then
7364          declare
7365             Val   : constant Ureal := Realval (N);
7366             Cintr : constant Ureal := Val / Small_Value (Typ);
7367             Cint  : constant Uint  := UR_Trunc (Cintr);
7368             Den   : constant Uint  := Norm_Den (Cintr);
7369             Stat  : Boolean;
7370
7371          begin
7372             --  Case of literal is not an exact multiple of the Small
7373
7374             if Den /= 1 then
7375
7376                --  For a source program literal for a decimal fixed-point
7377                --  type, this is statically illegal (RM 4.9(36)).
7378
7379                if Is_Decimal_Fixed_Point_Type (Typ)
7380                  and then Actual_Typ = Universal_Real
7381                  and then Comes_From_Source (N)
7382                then
7383                   Error_Msg_N ("value has extraneous low order digits", N);
7384                end if;
7385
7386                --  Generate a warning if literal from source
7387
7388                if Is_Static_Expression (N)
7389                  and then Warn_On_Bad_Fixed_Value
7390                then
7391                   Error_Msg_N
7392                     ("?static fixed-point value is not a multiple of Small!",
7393                      N);
7394                end if;
7395
7396                --  Replace literal by a value that is the exact representation
7397                --  of a value of the type, i.e. a multiple of the small value,
7398                --  by truncation, since Machine_Rounds is false for all GNAT
7399                --  fixed-point types (RM 4.9(38)).
7400
7401                Stat := Is_Static_Expression (N);
7402                Rewrite (N,
7403                  Make_Real_Literal (Sloc (N),
7404                    Realval => Small_Value (Typ) * Cint));
7405
7406                Set_Is_Static_Expression (N, Stat);
7407             end if;
7408
7409             --  In all cases, set the corresponding integer field
7410
7411             Set_Corresponding_Integer_Value (N, Cint);
7412          end;
7413       end if;
7414
7415       --  Now replace the actual type by the expected type as usual
7416
7417       Set_Etype (N, Typ);
7418       Eval_Real_Literal (N);
7419    end Resolve_Real_Literal;
7420
7421    -----------------------
7422    -- Resolve_Reference --
7423    -----------------------
7424
7425    procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
7426       P : constant Node_Id := Prefix (N);
7427
7428    begin
7429       --  Replace general access with specific type
7430
7431       if Ekind (Etype (N)) = E_Allocator_Type then
7432          Set_Etype (N, Base_Type (Typ));
7433       end if;
7434
7435       Resolve (P, Designated_Type (Etype (N)));
7436
7437       --  If we are taking the reference of a volatile entity, then treat
7438       --  it as a potential modification of this entity. This is much too
7439       --  conservative, but is necessary because remove side effects can
7440       --  result in transformations of normal assignments into reference
7441       --  sequences that otherwise fail to notice the modification.
7442
7443       if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
7444          Note_Possible_Modification (P, Sure => False);
7445       end if;
7446    end Resolve_Reference;
7447
7448    --------------------------------
7449    -- Resolve_Selected_Component --
7450    --------------------------------
7451
7452    procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
7453       Comp  : Entity_Id;
7454       Comp1 : Entity_Id        := Empty; -- prevent junk warning
7455       P     : constant Node_Id := Prefix  (N);
7456       S     : constant Node_Id := Selector_Name (N);
7457       T     : Entity_Id        := Etype (P);
7458       I     : Interp_Index;
7459       I1    : Interp_Index := 0; -- prevent junk warning
7460       It    : Interp;
7461       It1   : Interp;
7462       Found : Boolean;
7463
7464       function Init_Component return Boolean;
7465       --  Check whether this is the initialization of a component within an
7466       --  init proc (by assignment or call to another init proc). If true,
7467       --  there is no need for a discriminant check.
7468
7469       --------------------
7470       -- Init_Component --
7471       --------------------
7472
7473       function Init_Component return Boolean is
7474       begin
7475          return Inside_Init_Proc
7476            and then Nkind (Prefix (N)) = N_Identifier
7477            and then Chars (Prefix (N)) = Name_uInit
7478            and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
7479       end Init_Component;
7480
7481    --  Start of processing for Resolve_Selected_Component
7482
7483    begin
7484       if Is_Overloaded (P) then
7485
7486          --  Use the context type to select the prefix that has a selector
7487          --  of the correct name and type.
7488
7489          Found := False;
7490          Get_First_Interp (P, I, It);
7491
7492          Search : while Present (It.Typ) loop
7493             if Is_Access_Type (It.Typ) then
7494                T := Designated_Type (It.Typ);
7495             else
7496                T := It.Typ;
7497             end if;
7498
7499             if Is_Record_Type (T) then
7500
7501                --  The visible components of a class-wide type are those of
7502                --  the root type.
7503
7504                if Is_Class_Wide_Type (T) then
7505                   T := Etype (T);
7506                end if;
7507
7508                Comp := First_Entity (T);
7509                while Present (Comp) loop
7510                   if Chars (Comp) = Chars (S)
7511                     and then Covers (Etype (Comp), Typ)
7512                   then
7513                      if not Found then
7514                         Found := True;
7515                         I1  := I;
7516                         It1 := It;
7517                         Comp1 := Comp;
7518
7519                      else
7520                         It := Disambiguate (P, I1, I, Any_Type);
7521
7522                         if It = No_Interp then
7523                            Error_Msg_N
7524                              ("ambiguous prefix for selected component",  N);
7525                            Set_Etype (N, Typ);
7526                            return;
7527
7528                         else
7529                            It1 := It;
7530
7531                            --  There may be an implicit dereference. Retrieve
7532                            --  designated record type.
7533
7534                            if Is_Access_Type (It1.Typ) then
7535                               T := Designated_Type (It1.Typ);
7536                            else
7537                               T := It1.Typ;
7538                            end if;
7539
7540                            if Scope (Comp1) /= T then
7541
7542                               --  Resolution chooses the new interpretation.
7543                               --  Find the component with the right name.
7544
7545                               Comp1 := First_Entity (T);
7546                               while Present (Comp1)
7547                                 and then Chars (Comp1) /= Chars (S)
7548                               loop
7549                                  Comp1 := Next_Entity (Comp1);
7550                               end loop;
7551                            end if;
7552
7553                            exit Search;
7554                         end if;
7555                      end if;
7556                   end if;
7557
7558                   Comp := Next_Entity (Comp);
7559                end loop;
7560
7561             end if;
7562
7563             Get_Next_Interp (I, It);
7564          end loop Search;
7565
7566          Resolve (P, It1.Typ);
7567          Set_Etype (N, Typ);
7568          Set_Entity_With_Style_Check (S, Comp1);
7569
7570       else
7571          --  Resolve prefix with its type
7572
7573          Resolve (P, T);
7574       end if;
7575
7576       --  Generate cross-reference. We needed to wait until full overloading
7577       --  resolution was complete to do this, since otherwise we can't tell if
7578       --  we are an Lvalue of not.
7579
7580       if May_Be_Lvalue (N) then
7581          Generate_Reference (Entity (S), S, 'm');
7582       else
7583          Generate_Reference (Entity (S), S, 'r');
7584       end if;
7585
7586       --  If prefix is an access type, the node will be transformed into an
7587       --  explicit dereference during expansion. The type of the node is the
7588       --  designated type of that of the prefix.
7589
7590       if Is_Access_Type (Etype (P)) then
7591          T := Designated_Type (Etype (P));
7592          Check_Fully_Declared_Prefix (T, P);
7593       else
7594          T := Etype (P);
7595       end if;
7596
7597       if Has_Discriminants (T)
7598         and then (Ekind (Entity (S)) = E_Component
7599                    or else
7600                   Ekind (Entity (S)) = E_Discriminant)
7601         and then Present (Original_Record_Component (Entity (S)))
7602         and then Ekind (Original_Record_Component (Entity (S))) = E_Component
7603         and then Present (Discriminant_Checking_Func
7604                            (Original_Record_Component (Entity (S))))
7605         and then not Discriminant_Checks_Suppressed (T)
7606         and then not Init_Component
7607       then
7608          Set_Do_Discriminant_Check (N);
7609       end if;
7610
7611       if Ekind (Entity (S)) = E_Void then
7612          Error_Msg_N ("premature use of component", S);
7613       end if;
7614
7615       --  If the prefix is a record conversion, this may be a renamed
7616       --  discriminant whose bounds differ from those of the original
7617       --  one, so we must ensure that a range check is performed.
7618
7619       if Nkind (P) = N_Type_Conversion
7620         and then Ekind (Entity (S)) = E_Discriminant
7621         and then Is_Discrete_Type (Typ)
7622       then
7623          Set_Etype (N, Base_Type (Typ));
7624       end if;
7625
7626       --  Note: No Eval processing is required, because the prefix is of a
7627       --  record type, or protected type, and neither can possibly be static.
7628
7629    end Resolve_Selected_Component;
7630
7631    -------------------
7632    -- Resolve_Shift --
7633    -------------------
7634
7635    procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
7636       B_Typ : constant Entity_Id := Base_Type (Typ);
7637       L     : constant Node_Id   := Left_Opnd  (N);
7638       R     : constant Node_Id   := Right_Opnd (N);
7639
7640    begin
7641       --  We do the resolution using the base type, because intermediate values
7642       --  in expressions always are of the base type, not a subtype of it.
7643
7644       Resolve (L, B_Typ);
7645       Resolve (R, Standard_Natural);
7646
7647       Check_Unset_Reference (L);
7648       Check_Unset_Reference (R);
7649
7650       Set_Etype (N, B_Typ);
7651       Generate_Operator_Reference (N, B_Typ);
7652       Eval_Shift (N);
7653    end Resolve_Shift;
7654
7655    ---------------------------
7656    -- Resolve_Short_Circuit --
7657    ---------------------------
7658
7659    procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
7660       B_Typ : constant Entity_Id := Base_Type (Typ);
7661       L     : constant Node_Id   := Left_Opnd  (N);
7662       R     : constant Node_Id   := Right_Opnd (N);
7663
7664    begin
7665       Resolve (L, B_Typ);
7666       Resolve (R, B_Typ);
7667
7668       --  Check for issuing warning for always False assert/check, this happens
7669       --  when assertions are turned off, in which case the pragma Assert/Check
7670       --  was transformed into:
7671
7672       --     if False and then <condition> then ...
7673
7674       --  and we detect this pattern
7675
7676       if Warn_On_Assertion_Failure
7677         and then Is_Entity_Name (R)
7678         and then Entity (R) = Standard_False
7679         and then Nkind (Parent (N)) = N_If_Statement
7680         and then Nkind (N) = N_And_Then
7681         and then Is_Entity_Name (L)
7682         and then Entity (L) = Standard_False
7683       then
7684          declare
7685             Orig : constant Node_Id := Original_Node (Parent (N));
7686
7687          begin
7688             if Nkind (Orig) = N_Pragma
7689               and then Pragma_Name (Orig) = Name_Assert
7690             then
7691                --  Don't want to warn if original condition is explicit False
7692
7693                declare
7694                   Expr : constant Node_Id :=
7695                            Original_Node
7696                              (Expression
7697                                (First (Pragma_Argument_Associations (Orig))));
7698                begin
7699                   if Is_Entity_Name (Expr)
7700                     and then Entity (Expr) = Standard_False
7701                   then
7702                      null;
7703                   else
7704                      --  Issue warning. Note that we don't want to make this
7705                      --  an unconditional warning, because if the assert is
7706                      --  within deleted code we do not want the warning. But
7707                      --  we do not want the deletion of the IF/AND-THEN to
7708                      --  take this message with it. We achieve this by making
7709                      --  sure that the expanded code points to the Sloc of
7710                      --  the expression, not the original pragma.
7711
7712                      Error_Msg_N ("?assertion would fail at run-time", Orig);
7713                   end if;
7714                end;
7715
7716             --  Similar processing for Check pragma
7717
7718             elsif Nkind (Orig) = N_Pragma
7719               and then Pragma_Name (Orig) = Name_Check
7720             then
7721                --  Don't want to warn if original condition is explicit False
7722
7723                declare
7724                   Expr : constant Node_Id :=
7725                            Original_Node
7726                              (Expression
7727                                 (Next (First
7728                                   (Pragma_Argument_Associations (Orig)))));
7729                begin
7730                   if Is_Entity_Name (Expr)
7731                     and then Entity (Expr) = Standard_False
7732                   then
7733                      null;
7734                   else
7735                      Error_Msg_N ("?check would fail at run-time", Orig);
7736                   end if;
7737                end;
7738             end if;
7739          end;
7740       end if;
7741
7742       --  Continue with processing of short circuit
7743
7744       Check_Unset_Reference (L);
7745       Check_Unset_Reference (R);
7746
7747       Set_Etype (N, B_Typ);
7748       Eval_Short_Circuit (N);
7749    end Resolve_Short_Circuit;
7750
7751    -------------------
7752    -- Resolve_Slice --
7753    -------------------
7754
7755    procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
7756       Name       : constant Node_Id := Prefix (N);
7757       Drange     : constant Node_Id := Discrete_Range (N);
7758       Array_Type : Entity_Id        := Empty;
7759       Index      : Node_Id;
7760
7761    begin
7762       if Is_Overloaded (Name) then
7763
7764          --  Use the context type to select the prefix that yields the correct
7765          --  array type.
7766
7767          declare
7768             I      : Interp_Index;
7769             I1     : Interp_Index := 0;
7770             It     : Interp;
7771             P      : constant Node_Id := Prefix (N);
7772             Found  : Boolean := False;
7773
7774          begin
7775             Get_First_Interp (P, I,  It);
7776             while Present (It.Typ) loop
7777                if (Is_Array_Type (It.Typ)
7778                     and then Covers (Typ,  It.Typ))
7779                  or else (Is_Access_Type (It.Typ)
7780                            and then Is_Array_Type (Designated_Type (It.Typ))
7781                            and then Covers (Typ, Designated_Type (It.Typ)))
7782                then
7783                   if Found then
7784                      It := Disambiguate (P, I1, I, Any_Type);
7785
7786                      if It = No_Interp then
7787                         Error_Msg_N ("ambiguous prefix for slicing",  N);
7788                         Set_Etype (N, Typ);
7789                         return;
7790                      else
7791                         Found := True;
7792                         Array_Type := It.Typ;
7793                         I1 := I;
7794                      end if;
7795                   else
7796                      Found := True;
7797                      Array_Type := It.Typ;
7798                      I1 := I;
7799                   end if;
7800                end if;
7801
7802                Get_Next_Interp (I, It);
7803             end loop;
7804          end;
7805
7806       else
7807          Array_Type := Etype (Name);
7808       end if;
7809
7810       Resolve (Name, Array_Type);
7811
7812       if Is_Access_Type (Array_Type) then
7813          Apply_Access_Check (N);
7814          Array_Type := Designated_Type (Array_Type);
7815
7816          --  If the prefix is an access to an unconstrained array, we must use
7817          --  the actual subtype of the object to perform the index checks. The
7818          --  object denoted by the prefix is implicit in the node, so we build
7819          --  an explicit representation for it in order to compute the actual
7820          --  subtype.
7821
7822          if not Is_Constrained (Array_Type) then
7823             Remove_Side_Effects (Prefix (N));
7824
7825             declare
7826                Obj : constant Node_Id :=
7827                        Make_Explicit_Dereference (Sloc (N),
7828                          Prefix => New_Copy_Tree (Prefix (N)));
7829             begin
7830                Set_Etype (Obj, Array_Type);
7831                Set_Parent (Obj, Parent (N));
7832                Array_Type := Get_Actual_Subtype (Obj);
7833             end;
7834          end if;
7835
7836       elsif Is_Entity_Name (Name)
7837         or else (Nkind (Name) = N_Function_Call
7838                   and then not Is_Constrained (Etype (Name)))
7839       then
7840          Array_Type := Get_Actual_Subtype (Name);
7841
7842       --  If the name is a selected component that depends on discriminants,
7843       --  build an actual subtype for it. This can happen only when the name
7844       --  itself is overloaded; otherwise the actual subtype is created when
7845       --  the selected component is analyzed.
7846
7847       elsif Nkind (Name) = N_Selected_Component
7848         and then Full_Analysis
7849         and then Depends_On_Discriminant (First_Index (Array_Type))
7850       then
7851          declare
7852             Act_Decl : constant Node_Id :=
7853                          Build_Actual_Subtype_Of_Component (Array_Type, Name);
7854          begin
7855             Insert_Action (N, Act_Decl);
7856             Array_Type := Defining_Identifier (Act_Decl);
7857          end;
7858       end if;
7859
7860       --  If name was overloaded, set slice type correctly now
7861
7862       Set_Etype (N, Array_Type);
7863
7864       --  If the range is specified by a subtype mark, no resolution is
7865       --  necessary. Else resolve the bounds, and apply needed checks.
7866
7867       if not Is_Entity_Name (Drange) then
7868          Index := First_Index (Array_Type);
7869          Resolve (Drange, Base_Type (Etype (Index)));
7870
7871          if Nkind (Drange) = N_Range
7872
7873             --  Do not apply the range check to nodes associated with the
7874             --  frontend expansion of the dispatch table. We first check
7875             --  if Ada.Tags is already loaded to void the addition of an
7876             --  undesired dependence on such run-time unit.
7877
7878            and then
7879              (not Tagged_Type_Expansion
7880                or else not
7881                  (RTU_Loaded (Ada_Tags)
7882                    and then Nkind (Prefix (N)) = N_Selected_Component
7883                    and then Present (Entity (Selector_Name (Prefix (N))))
7884                    and then Entity (Selector_Name (Prefix (N))) =
7885                                          RTE_Record_Component (RE_Prims_Ptr)))
7886          then
7887             Apply_Range_Check (Drange, Etype (Index));
7888          end if;
7889       end if;
7890
7891       Set_Slice_Subtype (N);
7892
7893       if Nkind (Drange) = N_Range then
7894          Warn_On_Suspicious_Index (Name, Low_Bound  (Drange));
7895          Warn_On_Suspicious_Index (Name, High_Bound (Drange));
7896       end if;
7897
7898       Eval_Slice (N);
7899    end Resolve_Slice;
7900
7901    ----------------------------
7902    -- Resolve_String_Literal --
7903    ----------------------------
7904
7905    procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
7906       C_Typ      : constant Entity_Id  := Component_Type (Typ);
7907       R_Typ      : constant Entity_Id  := Root_Type (C_Typ);
7908       Loc        : constant Source_Ptr := Sloc (N);
7909       Str        : constant String_Id  := Strval (N);
7910       Strlen     : constant Nat        := String_Length (Str);
7911       Subtype_Id : Entity_Id;
7912       Need_Check : Boolean;
7913
7914    begin
7915       --  For a string appearing in a concatenation, defer creation of the
7916       --  string_literal_subtype until the end of the resolution of the
7917       --  concatenation, because the literal may be constant-folded away. This
7918       --  is a useful optimization for long concatenation expressions.
7919
7920       --  If the string is an aggregate built for a single character (which
7921       --  happens in a non-static context) or a is null string to which special
7922       --  checks may apply, we build the subtype. Wide strings must also get a
7923       --  string subtype if they come from a one character aggregate. Strings
7924       --  generated by attributes might be static, but it is often hard to
7925       --  determine whether the enclosing context is static, so we generate
7926       --  subtypes for them as well, thus losing some rarer optimizations ???
7927       --  Same for strings that come from a static conversion.
7928
7929       Need_Check :=
7930         (Strlen = 0 and then Typ /= Standard_String)
7931           or else Nkind (Parent (N)) /= N_Op_Concat
7932           or else (N /= Left_Opnd (Parent (N))
7933                     and then N /= Right_Opnd (Parent (N)))
7934           or else ((Typ = Standard_Wide_String
7935                       or else Typ = Standard_Wide_Wide_String)
7936                     and then Nkind (Original_Node (N)) /= N_String_Literal);
7937
7938       --  If the resolving type is itself a string literal subtype, we can just
7939       --  reuse it, since there is no point in creating another.
7940
7941       if Ekind (Typ) = E_String_Literal_Subtype then
7942          Subtype_Id := Typ;
7943
7944       elsif Nkind (Parent (N)) = N_Op_Concat
7945         and then not Need_Check
7946         and then not Nkind_In (Original_Node (N), N_Character_Literal,
7947                                                   N_Attribute_Reference,
7948                                                   N_Qualified_Expression,
7949                                                   N_Type_Conversion)
7950       then
7951          Subtype_Id := Typ;
7952
7953       --  Otherwise we must create a string literal subtype. Note that the
7954       --  whole idea of string literal subtypes is simply to avoid the need
7955       --  for building a full fledged array subtype for each literal.
7956
7957       else
7958          Set_String_Literal_Subtype (N, Typ);
7959          Subtype_Id := Etype (N);
7960       end if;
7961
7962       if Nkind (Parent (N)) /= N_Op_Concat
7963         or else Need_Check
7964       then
7965          Set_Etype (N, Subtype_Id);
7966          Eval_String_Literal (N);
7967       end if;
7968
7969       if Is_Limited_Composite (Typ)
7970         or else Is_Private_Composite (Typ)
7971       then
7972          Error_Msg_N ("string literal not available for private array", N);
7973          Set_Etype (N, Any_Type);
7974          return;
7975       end if;
7976
7977       --  The validity of a null string has been checked in the call to
7978       --  Eval_String_Literal.
7979
7980       if Strlen = 0 then
7981          return;
7982
7983       --  Always accept string literal with component type Any_Character, which
7984       --  occurs in error situations and in comparisons of literals, both of
7985       --  which should accept all literals.
7986
7987       elsif R_Typ = Any_Character then
7988          return;
7989
7990       --  If the type is bit-packed, then we always transform the string
7991       --  literal into a full fledged aggregate.
7992
7993       elsif Is_Bit_Packed_Array (Typ) then
7994          null;
7995
7996       --  Deal with cases of Wide_Wide_String, Wide_String, and String
7997
7998       else
7999          --  For Standard.Wide_Wide_String, or any other type whose component
8000          --  type is Standard.Wide_Wide_Character, we know that all the
8001          --  characters in the string must be acceptable, since the parser
8002          --  accepted the characters as valid character literals.
8003
8004          if R_Typ = Standard_Wide_Wide_Character then
8005             null;
8006
8007          --  For the case of Standard.String, or any other type whose component
8008          --  type is Standard.Character, we must make sure that there are no
8009          --  wide characters in the string, i.e. that it is entirely composed
8010          --  of characters in range of type Character.
8011
8012          --  If the string literal is the result of a static concatenation, the
8013          --  test has already been performed on the components, and need not be
8014          --  repeated.
8015
8016          elsif R_Typ = Standard_Character
8017            and then Nkind (Original_Node (N)) /= N_Op_Concat
8018          then
8019             for J in 1 .. Strlen loop
8020                if not In_Character_Range (Get_String_Char (Str, J)) then
8021
8022                   --  If we are out of range, post error. This is one of the
8023                   --  very few places that we place the flag in the middle of
8024                   --  a token, right under the offending wide character. Not
8025                   --  quite clear if this is right wrt wide character encoding
8026                   --  sequences, but it's only an error message!
8027
8028                   Error_Msg
8029                     ("literal out of range of type Standard.Character",
8030                      Source_Ptr (Int (Loc) + J));
8031                   return;
8032                end if;
8033             end loop;
8034
8035          --  For the case of Standard.Wide_String, or any other type whose
8036          --  component type is Standard.Wide_Character, we must make sure that
8037          --  there are no wide characters in the string, i.e. that it is
8038          --  entirely composed of characters in range of type Wide_Character.
8039
8040          --  If the string literal is the result of a static concatenation,
8041          --  the test has already been performed on the components, and need
8042          --  not be repeated.
8043
8044          elsif R_Typ = Standard_Wide_Character
8045            and then Nkind (Original_Node (N)) /= N_Op_Concat
8046          then
8047             for J in 1 .. Strlen loop
8048                if not In_Wide_Character_Range (Get_String_Char (Str, J)) then
8049
8050                   --  If we are out of range, post error. This is one of the
8051                   --  very few places that we place the flag in the middle of
8052                   --  a token, right under the offending wide character.
8053
8054                   --  This is not quite right, because characters in general
8055                   --  will take more than one character position ???
8056
8057                   Error_Msg
8058                     ("literal out of range of type Standard.Wide_Character",
8059                      Source_Ptr (Int (Loc) + J));
8060                   return;
8061                end if;
8062             end loop;
8063
8064          --  If the root type is not a standard character, then we will convert
8065          --  the string into an aggregate and will let the aggregate code do
8066          --  the checking. Standard Wide_Wide_Character is also OK here.
8067
8068          else
8069             null;
8070          end if;
8071
8072          --  See if the component type of the array corresponding to the string
8073          --  has compile time known bounds. If yes we can directly check
8074          --  whether the evaluation of the string will raise constraint error.
8075          --  Otherwise we need to transform the string literal into the
8076          --  corresponding character aggregate and let the aggregate
8077          --  code do the checking.
8078
8079          if Is_Standard_Character_Type (R_Typ) then
8080
8081             --  Check for the case of full range, where we are definitely OK
8082
8083             if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
8084                return;
8085             end if;
8086
8087             --  Here the range is not the complete base type range, so check
8088
8089             declare
8090                Comp_Typ_Lo : constant Node_Id :=
8091                                Type_Low_Bound (Component_Type (Typ));
8092                Comp_Typ_Hi : constant Node_Id :=
8093                                Type_High_Bound (Component_Type (Typ));
8094
8095                Char_Val : Uint;
8096
8097             begin
8098                if Compile_Time_Known_Value (Comp_Typ_Lo)
8099                  and then Compile_Time_Known_Value (Comp_Typ_Hi)
8100                then
8101                   for J in 1 .. Strlen loop
8102                      Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
8103
8104                      if Char_Val < Expr_Value (Comp_Typ_Lo)
8105                        or else Char_Val > Expr_Value (Comp_Typ_Hi)
8106                      then
8107                         Apply_Compile_Time_Constraint_Error
8108                           (N, "character out of range?", CE_Range_Check_Failed,
8109                            Loc => Source_Ptr (Int (Loc) + J));
8110                      end if;
8111                   end loop;
8112
8113                   return;
8114                end if;
8115             end;
8116          end if;
8117       end if;
8118
8119       --  If we got here we meed to transform the string literal into the
8120       --  equivalent qualified positional array aggregate. This is rather
8121       --  heavy artillery for this situation, but it is hard work to avoid.
8122
8123       declare
8124          Lits : constant List_Id    := New_List;
8125          P    : Source_Ptr := Loc + 1;
8126          C    : Char_Code;
8127
8128       begin
8129          --  Build the character literals, we give them source locations that
8130          --  correspond to the string positions, which is a bit tricky given
8131          --  the possible presence of wide character escape sequences.
8132
8133          for J in 1 .. Strlen loop
8134             C := Get_String_Char (Str, J);
8135             Set_Character_Literal_Name (C);
8136
8137             Append_To (Lits,
8138               Make_Character_Literal (P,
8139                 Chars              => Name_Find,
8140                 Char_Literal_Value => UI_From_CC (C)));
8141
8142             if In_Character_Range (C) then
8143                P := P + 1;
8144
8145             --  Should we have a call to Skip_Wide here ???
8146             --  ???     else
8147             --             Skip_Wide (P);
8148
8149             end if;
8150          end loop;
8151
8152          Rewrite (N,
8153            Make_Qualified_Expression (Loc,
8154              Subtype_Mark => New_Reference_To (Typ, Loc),
8155              Expression   =>
8156                Make_Aggregate (Loc, Expressions => Lits)));
8157
8158          Analyze_And_Resolve (N, Typ);
8159       end;
8160    end Resolve_String_Literal;
8161
8162    -----------------------------
8163    -- Resolve_Subprogram_Info --
8164    -----------------------------
8165
8166    procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
8167    begin
8168       Set_Etype (N, Typ);
8169    end Resolve_Subprogram_Info;
8170
8171    -----------------------------
8172    -- Resolve_Type_Conversion --
8173    -----------------------------
8174
8175    procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
8176       Conv_OK     : constant Boolean := Conversion_OK (N);
8177       Operand     : constant Node_Id := Expression (N);
8178       Operand_Typ : constant Entity_Id := Etype (Operand);
8179       Target_Typ  : constant Entity_Id := Etype (N);
8180       Rop         : Node_Id;
8181       Orig_N      : Node_Id;
8182       Orig_T      : Node_Id;
8183
8184    begin
8185       if not Conv_OK
8186         and then not Valid_Conversion (N, Target_Typ, Operand)
8187       then
8188          return;
8189       end if;
8190
8191       if Etype (Operand) = Any_Fixed then
8192
8193          --  Mixed-mode operation involving a literal. Context must be a fixed
8194          --  type which is applied to the literal subsequently.
8195
8196          if Is_Fixed_Point_Type (Typ) then
8197             Set_Etype (Operand, Universal_Real);
8198
8199          elsif Is_Numeric_Type (Typ)
8200            and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide)
8201            and then (Etype (Right_Opnd (Operand)) = Universal_Real
8202                        or else
8203                      Etype (Left_Opnd  (Operand)) = Universal_Real)
8204          then
8205             --  Return if expression is ambiguous
8206
8207             if Unique_Fixed_Point_Type (N) = Any_Type then
8208                return;
8209
8210             --  If nothing else, the available fixed type is Duration
8211
8212             else
8213                Set_Etype (Operand, Standard_Duration);
8214             end if;
8215
8216             --  Resolve the real operand with largest available precision
8217
8218             if Etype (Right_Opnd (Operand)) = Universal_Real then
8219                Rop := New_Copy_Tree (Right_Opnd (Operand));
8220             else
8221                Rop := New_Copy_Tree (Left_Opnd (Operand));
8222             end if;
8223
8224             Resolve (Rop, Universal_Real);
8225
8226             --  If the operand is a literal (it could be a non-static and
8227             --  illegal exponentiation) check whether the use of Duration
8228             --  is potentially inaccurate.
8229
8230             if Nkind (Rop) = N_Real_Literal
8231               and then Realval (Rop) /= Ureal_0
8232               and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
8233             then
8234                Error_Msg_N
8235                  ("?universal real operand can only " &
8236                   "be interpreted as Duration!",
8237                   Rop);
8238                Error_Msg_N
8239                  ("\?precision will be lost in the conversion!", Rop);
8240             end if;
8241
8242          elsif Is_Numeric_Type (Typ)
8243            and then Nkind (Operand) in N_Op
8244            and then Unique_Fixed_Point_Type (N) /= Any_Type
8245          then
8246             Set_Etype (Operand, Standard_Duration);
8247
8248          else
8249             Error_Msg_N ("invalid context for mixed mode operation", N);
8250             Set_Etype (Operand, Any_Type);
8251             return;
8252          end if;
8253       end if;
8254
8255       Resolve (Operand);
8256
8257       --  Note: we do the Eval_Type_Conversion call before applying the
8258       --  required checks for a subtype conversion. This is important, since
8259       --  both are prepared under certain circumstances to change the type
8260       --  conversion to a constraint error node, but in the case of
8261       --  Eval_Type_Conversion this may reflect an illegality in the static
8262       --  case, and we would miss the illegality (getting only a warning
8263       --  message), if we applied the type conversion checks first.
8264
8265       Eval_Type_Conversion (N);
8266
8267       --  Even when evaluation is not possible, we may be able to simplify the
8268       --  conversion or its expression. This needs to be done before applying
8269       --  checks, since otherwise the checks may use the original expression
8270       --  and defeat the simplifications. This is specifically the case for
8271       --  elimination of the floating-point Truncation attribute in
8272       --  float-to-int conversions.
8273
8274       Simplify_Type_Conversion (N);
8275
8276       --  If after evaluation we still have a type conversion, then we may need
8277       --  to apply checks required for a subtype conversion.
8278
8279       --  Skip these type conversion checks if universal fixed operands
8280       --  operands involved, since range checks are handled separately for
8281       --  these cases (in the appropriate Expand routines in unit Exp_Fixd).
8282
8283       if Nkind (N) = N_Type_Conversion
8284         and then not Is_Generic_Type (Root_Type (Target_Typ))
8285         and then Target_Typ  /= Universal_Fixed
8286         and then Operand_Typ /= Universal_Fixed
8287       then
8288          Apply_Type_Conversion_Checks (N);
8289       end if;
8290
8291       --  Issue warning for conversion of simple object to its own type. We
8292       --  have to test the original nodes, since they may have been rewritten
8293       --  by various optimizations.
8294
8295       Orig_N := Original_Node (N);
8296
8297       if Warn_On_Redundant_Constructs
8298         and then Comes_From_Source (Orig_N)
8299         and then Nkind (Orig_N) = N_Type_Conversion
8300         and then not In_Instance
8301       then
8302          Orig_N := Original_Node (Expression (Orig_N));
8303          Orig_T := Target_Typ;
8304
8305          --  If the node is part of a larger expression, the Target_Type
8306          --  may not be the original type of the node if the context is a
8307          --  condition. Recover original type to see if conversion is needed.
8308
8309          if Is_Boolean_Type (Orig_T)
8310           and then Nkind (Parent (N)) in N_Op
8311          then
8312             Orig_T := Etype (Parent (N));
8313          end if;
8314
8315          if Is_Entity_Name (Orig_N)
8316            and then
8317              (Etype (Entity (Orig_N)) = Orig_T
8318                 or else
8319                   (Ekind (Entity (Orig_N)) = E_Loop_Parameter
8320                      and then Covers (Orig_T, Etype (Entity (Orig_N)))))
8321          then
8322             Error_Msg_Node_2 := Orig_T;
8323             Error_Msg_NE -- CODEFIX
8324               ("?redundant conversion, & is of type &!", N, Entity (Orig_N));
8325          end if;
8326       end if;
8327
8328       --  Ada 2005 (AI-251): Handle class-wide interface type conversions.
8329       --  No need to perform any interface conversion if the type of the
8330       --  expression coincides with the target type.
8331
8332       if Ada_Version >= Ada_05
8333         and then Expander_Active
8334         and then Operand_Typ /= Target_Typ
8335       then
8336          declare
8337             Opnd   : Entity_Id := Operand_Typ;
8338             Target : Entity_Id := Target_Typ;
8339
8340          begin
8341             if Is_Access_Type (Opnd) then
8342                Opnd := Directly_Designated_Type (Opnd);
8343             end if;
8344
8345             if Is_Access_Type (Target_Typ) then
8346                Target := Directly_Designated_Type (Target);
8347             end if;
8348
8349             if Opnd = Target then
8350                null;
8351
8352             --  Conversion from interface type
8353
8354             elsif Is_Interface (Opnd) then
8355
8356                --  Ada 2005 (AI-217): Handle entities from limited views
8357
8358                if From_With_Type (Opnd) then
8359                   Error_Msg_Qual_Level := 99;
8360                   Error_Msg_NE ("missing WITH clause on package &", N,
8361                     Cunit_Entity (Get_Source_Unit (Base_Type (Opnd))));
8362                   Error_Msg_N
8363                     ("type conversions require visibility of the full view",
8364                      N);
8365
8366                elsif From_With_Type (Target)
8367                  and then not
8368                    (Is_Access_Type (Target_Typ)
8369                       and then Present (Non_Limited_View (Etype (Target))))
8370                then
8371                   Error_Msg_Qual_Level := 99;
8372                   Error_Msg_NE ("missing WITH clause on package &", N,
8373                     Cunit_Entity (Get_Source_Unit (Base_Type (Target))));
8374                   Error_Msg_N
8375                     ("type conversions require visibility of the full view",
8376                      N);
8377
8378                else
8379                   Expand_Interface_Conversion (N, Is_Static => False);
8380                end if;
8381
8382             --  Conversion to interface type
8383
8384             elsif Is_Interface (Target) then
8385
8386                --  Handle subtypes
8387
8388                if Ekind (Opnd) = E_Protected_Subtype
8389                  or else Ekind (Opnd) = E_Task_Subtype
8390                then
8391                   Opnd := Etype (Opnd);
8392                end if;
8393
8394                if not Interface_Present_In_Ancestor
8395                         (Typ   => Opnd,
8396                          Iface => Target)
8397                then
8398                   if Is_Class_Wide_Type (Opnd) then
8399
8400                      --  The static analysis is not enough to know if the
8401                      --  interface is implemented or not. Hence we must pass
8402                      --  the work to the expander to generate code to evaluate
8403                      --  the conversion at run-time.
8404
8405                      Expand_Interface_Conversion (N, Is_Static => False);
8406
8407                   else
8408                      Error_Msg_Name_1 := Chars (Etype (Target));
8409                      Error_Msg_Name_2 := Chars (Opnd);
8410                      Error_Msg_N
8411                        ("wrong interface conversion (% is not a progenitor " &
8412                         "of %)", N);
8413                   end if;
8414
8415                else
8416                   Expand_Interface_Conversion (N);
8417                end if;
8418             end if;
8419          end;
8420       end if;
8421    end Resolve_Type_Conversion;
8422
8423    ----------------------
8424    -- Resolve_Unary_Op --
8425    ----------------------
8426
8427    procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
8428       B_Typ : constant Entity_Id := Base_Type (Typ);
8429       R     : constant Node_Id   := Right_Opnd (N);
8430       OK    : Boolean;
8431       Lo    : Uint;
8432       Hi    : Uint;
8433
8434    begin
8435       --  Deal with intrinsic unary operators
8436
8437       if Comes_From_Source (N)
8438         and then Ekind (Entity (N)) = E_Function
8439         and then Is_Imported (Entity (N))
8440         and then Is_Intrinsic_Subprogram (Entity (N))
8441       then
8442          Resolve_Intrinsic_Unary_Operator (N, Typ);
8443          return;
8444       end if;
8445
8446       --  Deal with universal cases
8447
8448       if Etype (R) = Universal_Integer
8449            or else
8450          Etype (R) = Universal_Real
8451       then
8452          Check_For_Visible_Operator (N, B_Typ);
8453       end if;
8454
8455       Set_Etype (N, B_Typ);
8456       Resolve (R, B_Typ);
8457
8458       --  Generate warning for expressions like abs (x mod 2)
8459
8460       if Warn_On_Redundant_Constructs
8461         and then Nkind (N) = N_Op_Abs
8462       then
8463          Determine_Range (Right_Opnd (N), OK, Lo, Hi);
8464
8465          if OK and then Hi >= Lo and then Lo >= 0 then
8466             Error_Msg_N
8467              ("?abs applied to known non-negative value has no effect", N);
8468          end if;
8469       end if;
8470
8471       --  Deal with reference generation
8472
8473       Check_Unset_Reference (R);
8474       Generate_Operator_Reference (N, B_Typ);
8475       Eval_Unary_Op (N);
8476
8477       --  Set overflow checking bit. Much cleverer code needed here eventually
8478       --  and perhaps the Resolve routines should be separated for the various
8479       --  arithmetic operations, since they will need different processing ???
8480
8481       if Nkind (N) in N_Op then
8482          if not Overflow_Checks_Suppressed (Etype (N)) then
8483             Enable_Overflow_Check (N);
8484          end if;
8485       end if;
8486
8487       --  Generate warning for expressions like -5 mod 3 for integers. No need
8488       --  to worry in the floating-point case, since parens do not affect the
8489       --  result so there is no point in giving in a warning.
8490
8491       declare
8492          Norig : constant Node_Id := Original_Node (N);
8493          Rorig : Node_Id;
8494          Val   : Uint;
8495          HB    : Uint;
8496          LB    : Uint;
8497          Lval  : Uint;
8498          Opnd  : Node_Id;
8499
8500       begin
8501          if Warn_On_Questionable_Missing_Parens
8502            and then Comes_From_Source (Norig)
8503            and then Is_Integer_Type (Typ)
8504            and then Nkind (Norig) = N_Op_Minus
8505          then
8506             Rorig := Original_Node (Right_Opnd (Norig));
8507
8508             --  We are looking for cases where the right operand is not
8509             --  parenthesized, and is a binary operator, multiply, divide, or
8510             --  mod. These are the cases where the grouping can affect results.
8511
8512             if Paren_Count (Rorig) = 0
8513               and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide)
8514             then
8515                --  For mod, we always give the warning, since the value is
8516                --  affected by the parenthesization (e.g. (-5) mod 315 /=
8517                --  -(5 mod 315)). But for the other cases, the only concern is
8518                --  overflow, e.g. for the case of 8 big signed (-(2 * 64)
8519                --  overflows, but (-2) * 64 does not). So we try to give the
8520                --  message only when overflow is possible.
8521
8522                if Nkind (Rorig) /= N_Op_Mod
8523                  and then Compile_Time_Known_Value (R)
8524                then
8525                   Val := Expr_Value (R);
8526
8527                   if Compile_Time_Known_Value (Type_High_Bound (Typ)) then
8528                      HB := Expr_Value (Type_High_Bound (Typ));
8529                   else
8530                      HB := Expr_Value (Type_High_Bound (Base_Type (Typ)));
8531                   end if;
8532
8533                   if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
8534                      LB := Expr_Value (Type_Low_Bound (Typ));
8535                   else
8536                      LB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
8537                   end if;
8538
8539                   --  Note that the test below is deliberately excluding the
8540                   --  largest negative number, since that is a potentially
8541                   --  troublesome case (e.g. -2 * x, where the result is the
8542                   --  largest negative integer has an overflow with 2 * x).
8543
8544                   if Val > LB and then Val <= HB then
8545                      return;
8546                   end if;
8547                end if;
8548
8549                --  For the multiplication case, the only case we have to worry
8550                --  about is when (-a)*b is exactly the largest negative number
8551                --  so that -(a*b) can cause overflow. This can only happen if
8552                --  a is a power of 2, and more generally if any operand is a
8553                --  constant that is not a power of 2, then the parentheses
8554                --  cannot affect whether overflow occurs. We only bother to
8555                --  test the left most operand
8556
8557                --  Loop looking at left operands for one that has known value
8558
8559                Opnd := Rorig;
8560                Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop
8561                   if Compile_Time_Known_Value (Left_Opnd (Opnd)) then
8562                      Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd)));
8563
8564                      --  Operand value of 0 or 1 skips warning
8565
8566                      if Lval <= 1 then
8567                         return;
8568
8569                      --  Otherwise check power of 2, if power of 2, warn, if
8570                      --  anything else, skip warning.
8571
8572                      else
8573                         while Lval /= 2 loop
8574                            if Lval mod 2 = 1 then
8575                               return;
8576                            else
8577                               Lval := Lval / 2;
8578                            end if;
8579                         end loop;
8580
8581                         exit Opnd_Loop;
8582                      end if;
8583                   end if;
8584
8585                   --  Keep looking at left operands
8586
8587                   Opnd := Left_Opnd (Opnd);
8588                end loop Opnd_Loop;
8589
8590                --  For rem or "/" we can only have a problematic situation
8591                --  if the divisor has a value of minus one or one. Otherwise
8592                --  overflow is impossible (divisor > 1) or we have a case of
8593                --  division by zero in any case.
8594
8595                if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem)
8596                  and then Compile_Time_Known_Value (Right_Opnd (Rorig))
8597                  and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
8598                then
8599                   return;
8600                end if;
8601
8602                --  If we fall through warning should be issued
8603
8604                Error_Msg_N
8605                  ("?unary minus expression should be parenthesized here!", N);
8606             end if;
8607          end if;
8608       end;
8609    end Resolve_Unary_Op;
8610
8611    ----------------------------------
8612    -- Resolve_Unchecked_Expression --
8613    ----------------------------------
8614
8615    procedure Resolve_Unchecked_Expression
8616      (N   : Node_Id;
8617       Typ : Entity_Id)
8618    is
8619    begin
8620       Resolve (Expression (N), Typ, Suppress => All_Checks);
8621       Set_Etype (N, Typ);
8622    end Resolve_Unchecked_Expression;
8623
8624    ---------------------------------------
8625    -- Resolve_Unchecked_Type_Conversion --
8626    ---------------------------------------
8627
8628    procedure Resolve_Unchecked_Type_Conversion
8629      (N   : Node_Id;
8630       Typ : Entity_Id)
8631    is
8632       pragma Warnings (Off, Typ);
8633
8634       Operand   : constant Node_Id   := Expression (N);
8635       Opnd_Type : constant Entity_Id := Etype (Operand);
8636
8637    begin
8638       --  Resolve operand using its own type
8639
8640       Resolve (Operand, Opnd_Type);
8641       Eval_Unchecked_Conversion (N);
8642
8643    end Resolve_Unchecked_Type_Conversion;
8644
8645    ------------------------------
8646    -- Rewrite_Operator_As_Call --
8647    ------------------------------
8648
8649    procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
8650       Loc     : constant Source_Ptr := Sloc (N);
8651       Actuals : constant List_Id    := New_List;
8652       New_N   : Node_Id;
8653
8654    begin
8655       if Nkind (N) in  N_Binary_Op then
8656          Append (Left_Opnd (N), Actuals);
8657       end if;
8658
8659       Append (Right_Opnd (N), Actuals);
8660
8661       New_N :=
8662         Make_Function_Call (Sloc => Loc,
8663           Name => New_Occurrence_Of (Nam, Loc),
8664           Parameter_Associations => Actuals);
8665
8666       Preserve_Comes_From_Source (New_N, N);
8667       Preserve_Comes_From_Source (Name (New_N), N);
8668       Rewrite (N, New_N);
8669       Set_Etype (N, Etype (Nam));
8670    end Rewrite_Operator_As_Call;
8671
8672    ------------------------------
8673    -- Rewrite_Renamed_Operator --
8674    ------------------------------
8675
8676    procedure Rewrite_Renamed_Operator
8677      (N   : Node_Id;
8678       Op  : Entity_Id;
8679       Typ : Entity_Id)
8680    is
8681       Nam       : constant Name_Id := Chars (Op);
8682       Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
8683       Op_Node   : Node_Id;
8684
8685    begin
8686       --  Rewrite the operator node using the real operator, not its renaming.
8687       --  Exclude user-defined intrinsic operations of the same name, which are
8688       --  treated separately and rewritten as calls.
8689
8690       if Ekind (Op) /= E_Function
8691         or else Chars (N) /= Nam
8692       then
8693          Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
8694          Set_Chars      (Op_Node, Nam);
8695          Set_Etype      (Op_Node, Etype (N));
8696          Set_Entity     (Op_Node, Op);
8697          Set_Right_Opnd (Op_Node, Right_Opnd (N));
8698
8699          --  Indicate that both the original entity and its renaming are
8700          --  referenced at this point.
8701
8702          Generate_Reference (Entity (N), N);
8703          Generate_Reference (Op, N);
8704
8705          if Is_Binary then
8706             Set_Left_Opnd  (Op_Node, Left_Opnd  (N));
8707          end if;
8708
8709          Rewrite (N, Op_Node);
8710
8711          --  If the context type is private, add the appropriate conversions
8712          --  so that the operator is applied to the full view. This is done
8713          --  in the routines that resolve intrinsic operators,
8714
8715          if Is_Intrinsic_Subprogram (Op)
8716            and then Is_Private_Type (Typ)
8717          then
8718             case Nkind (N) is
8719                when N_Op_Add   | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
8720                     N_Op_Expon | N_Op_Mod      | N_Op_Rem      =>
8721                   Resolve_Intrinsic_Operator (N, Typ);
8722
8723                when N_Op_Plus  | N_Op_Minus    | N_Op_Abs      =>
8724                   Resolve_Intrinsic_Unary_Operator (N, Typ);
8725
8726                when others =>
8727                   Resolve (N, Typ);
8728             end case;
8729          end if;
8730
8731       elsif Ekind (Op) = E_Function
8732         and then Is_Intrinsic_Subprogram (Op)
8733       then
8734          --  Operator renames a user-defined operator of the same name. Use
8735          --  the original operator in the node, which is the one that Gigi
8736          --  knows about.
8737
8738          Set_Entity (N, Op);
8739          Set_Is_Overloaded (N, False);
8740       end if;
8741    end Rewrite_Renamed_Operator;
8742
8743    -----------------------
8744    -- Set_Slice_Subtype --
8745    -----------------------
8746
8747    --  Build an implicit subtype declaration to represent the type delivered
8748    --  by the slice. This is an abbreviated version of an array subtype. We
8749    --  define an index subtype for the slice, using either the subtype name
8750    --  or the discrete range of the slice. To be consistent with index usage
8751    --  elsewhere, we create a list header to hold the single index. This list
8752    --  is not otherwise attached to the syntax tree.
8753
8754    procedure Set_Slice_Subtype (N : Node_Id) is
8755       Loc           : constant Source_Ptr := Sloc (N);
8756       Index_List    : constant List_Id    := New_List;
8757       Index         : Node_Id;
8758       Index_Subtype : Entity_Id;
8759       Index_Type    : Entity_Id;
8760       Slice_Subtype : Entity_Id;
8761       Drange        : constant Node_Id := Discrete_Range (N);
8762
8763    begin
8764       if Is_Entity_Name (Drange) then
8765          Index_Subtype := Entity (Drange);
8766
8767       else
8768          --  We force the evaluation of a range. This is definitely needed in
8769          --  the renamed case, and seems safer to do unconditionally. Note in
8770          --  any case that since we will create and insert an Itype referring
8771          --  to this range, we must make sure any side effect removal actions
8772          --  are inserted before the Itype definition.
8773
8774          if Nkind (Drange) = N_Range then
8775             Force_Evaluation (Low_Bound (Drange));
8776             Force_Evaluation (High_Bound (Drange));
8777          end if;
8778
8779          Index_Type := Base_Type (Etype (Drange));
8780
8781          Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
8782
8783          Set_Scalar_Range (Index_Subtype, Drange);
8784          Set_Etype        (Index_Subtype, Index_Type);
8785          Set_Size_Info    (Index_Subtype, Index_Type);
8786          Set_RM_Size      (Index_Subtype, RM_Size (Index_Type));
8787       end if;
8788
8789       Slice_Subtype := Create_Itype (E_Array_Subtype, N);
8790
8791       Index := New_Occurrence_Of (Index_Subtype, Loc);
8792       Set_Etype (Index, Index_Subtype);
8793       Append (Index, Index_List);
8794
8795       Set_First_Index    (Slice_Subtype, Index);
8796       Set_Etype          (Slice_Subtype, Base_Type (Etype (N)));
8797       Set_Is_Constrained (Slice_Subtype, True);
8798
8799       Check_Compile_Time_Size (Slice_Subtype);
8800
8801       --  The Etype of the existing Slice node is reset to this slice subtype.
8802       --  Its bounds are obtained from its first index.
8803
8804       Set_Etype (N, Slice_Subtype);
8805
8806       --  In the packed case, this must be immediately frozen
8807
8808       --  Couldn't we always freeze here??? and if we did, then the above
8809       --  call to Check_Compile_Time_Size could be eliminated, which would
8810       --  be nice, because then that routine could be made private to Freeze.
8811
8812       --  Why the test for In_Spec_Expression here ???
8813
8814       if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
8815          Freeze_Itype (Slice_Subtype, N);
8816       end if;
8817
8818    end Set_Slice_Subtype;
8819
8820    --------------------------------
8821    -- Set_String_Literal_Subtype --
8822    --------------------------------
8823
8824    procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
8825       Loc        : constant Source_Ptr := Sloc (N);
8826       Low_Bound  : constant Node_Id :=
8827                      Type_Low_Bound (Etype (First_Index (Typ)));
8828       Subtype_Id : Entity_Id;
8829
8830    begin
8831       if Nkind (N) /= N_String_Literal then
8832          return;
8833       end if;
8834
8835       Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
8836       Set_String_Literal_Length (Subtype_Id, UI_From_Int
8837                                                (String_Length (Strval (N))));
8838       Set_Etype          (Subtype_Id, Base_Type (Typ));
8839       Set_Is_Constrained (Subtype_Id);
8840       Set_Etype          (N, Subtype_Id);
8841
8842       if Is_OK_Static_Expression (Low_Bound) then
8843
8844       --  The low bound is set from the low bound of the corresponding
8845       --  index type. Note that we do not store the high bound in the
8846       --  string literal subtype, but it can be deduced if necessary
8847       --  from the length and the low bound.
8848
8849          Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound);
8850
8851       else
8852          Set_String_Literal_Low_Bound
8853            (Subtype_Id, Make_Integer_Literal (Loc, 1));
8854          Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive);
8855
8856          --  Build bona fide subtype for the string, and wrap it in an
8857          --  unchecked conversion, because the backend expects the
8858          --  String_Literal_Subtype to have a static lower bound.
8859
8860          declare
8861             Index_List    : constant List_Id    := New_List;
8862             Index_Type    : constant Entity_Id := Etype (First_Index (Typ));
8863             High_Bound    : constant Node_Id :=
8864                                Make_Op_Add (Loc,
8865                                   Left_Opnd => New_Copy_Tree (Low_Bound),
8866                                   Right_Opnd =>
8867                                     Make_Integer_Literal (Loc,
8868                                       String_Length (Strval (N)) - 1));
8869             Array_Subtype : Entity_Id;
8870             Index_Subtype : Entity_Id;
8871             Drange        : Node_Id;
8872             Index         : Node_Id;
8873
8874          begin
8875             Index_Subtype :=
8876               Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
8877             Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound);
8878             Set_Scalar_Range (Index_Subtype, Drange);
8879             Set_Parent (Drange, N);
8880             Analyze_And_Resolve (Drange, Index_Type);
8881
8882             --  In the context, the Index_Type may already have a constraint,
8883             --  so use common base type on string subtype. The base type may
8884             --  be used when generating attributes of the string, for example
8885             --  in the context of a slice assignment.
8886
8887             Set_Etype        (Index_Subtype, Base_Type (Index_Type));
8888             Set_Size_Info    (Index_Subtype, Index_Type);
8889             Set_RM_Size      (Index_Subtype, RM_Size (Index_Type));
8890
8891             Array_Subtype := Create_Itype (E_Array_Subtype, N);
8892
8893             Index := New_Occurrence_Of (Index_Subtype, Loc);
8894             Set_Etype (Index, Index_Subtype);
8895             Append (Index, Index_List);
8896
8897             Set_First_Index    (Array_Subtype, Index);
8898             Set_Etype          (Array_Subtype, Base_Type (Typ));
8899             Set_Is_Constrained (Array_Subtype, True);
8900
8901             Rewrite (N,
8902               Make_Unchecked_Type_Conversion (Loc,
8903                 Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc),
8904                 Expression => Relocate_Node (N)));
8905             Set_Etype (N, Array_Subtype);
8906          end;
8907       end if;
8908    end Set_String_Literal_Subtype;
8909
8910    ------------------------------
8911    -- Simplify_Type_Conversion --
8912    ------------------------------
8913
8914    procedure Simplify_Type_Conversion (N : Node_Id) is
8915    begin
8916       if Nkind (N) = N_Type_Conversion then
8917          declare
8918             Operand    : constant Node_Id   := Expression (N);
8919             Target_Typ : constant Entity_Id := Etype (N);
8920             Opnd_Typ   : constant Entity_Id := Etype (Operand);
8921
8922          begin
8923             if Is_Floating_Point_Type (Opnd_Typ)
8924               and then
8925                 (Is_Integer_Type (Target_Typ)
8926                    or else (Is_Fixed_Point_Type (Target_Typ)
8927                               and then Conversion_OK (N)))
8928               and then Nkind (Operand) = N_Attribute_Reference
8929               and then Attribute_Name (Operand) = Name_Truncation
8930
8931             --  Special processing required if the conversion is the expression
8932             --  of a Truncation attribute reference. In this case we replace:
8933
8934             --     ityp (ftyp'Truncation (x))
8935
8936             --  by
8937
8938             --     ityp (x)
8939
8940             --  with the Float_Truncate flag set, which is more efficient
8941
8942             then
8943                Rewrite (Operand,
8944                  Relocate_Node (First (Expressions (Operand))));
8945                Set_Float_Truncate (N, True);
8946             end if;
8947          end;
8948       end if;
8949    end Simplify_Type_Conversion;
8950
8951    -----------------------------
8952    -- Unique_Fixed_Point_Type --
8953    -----------------------------
8954
8955    function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
8956       T1   : Entity_Id := Empty;
8957       T2   : Entity_Id;
8958       Item : Node_Id;
8959       Scop : Entity_Id;
8960
8961       procedure Fixed_Point_Error;
8962       --  Give error messages for true ambiguity. Messages are posted on node
8963       --  N, and entities T1, T2 are the possible interpretations.
8964
8965       -----------------------
8966       -- Fixed_Point_Error --
8967       -----------------------
8968
8969       procedure Fixed_Point_Error is
8970       begin
8971          Error_Msg_N ("ambiguous universal_fixed_expression", N);
8972          Error_Msg_NE ("\\possible interpretation as}", N, T1);
8973          Error_Msg_NE ("\\possible interpretation as}", N, T2);
8974       end Fixed_Point_Error;
8975
8976    --  Start of processing for Unique_Fixed_Point_Type
8977
8978    begin
8979       --  The operations on Duration are visible, so Duration is always a
8980       --  possible interpretation.
8981
8982       T1 := Standard_Duration;
8983
8984       --  Look for fixed-point types in enclosing scopes
8985
8986       Scop := Current_Scope;
8987       while Scop /= Standard_Standard loop
8988          T2 := First_Entity (Scop);
8989          while Present (T2) loop
8990             if Is_Fixed_Point_Type (T2)
8991               and then Current_Entity (T2) = T2
8992               and then Scope (Base_Type (T2)) = Scop
8993             then
8994                if Present (T1) then
8995                   Fixed_Point_Error;
8996                   return Any_Type;
8997                else
8998                   T1 := T2;
8999                end if;
9000             end if;
9001
9002             Next_Entity (T2);
9003          end loop;
9004
9005          Scop := Scope (Scop);
9006       end loop;
9007
9008       --  Look for visible fixed type declarations in the context
9009
9010       Item := First (Context_Items (Cunit (Current_Sem_Unit)));
9011       while Present (Item) loop
9012          if Nkind (Item) = N_With_Clause then
9013             Scop := Entity (Name (Item));
9014             T2 := First_Entity (Scop);
9015             while Present (T2) loop
9016                if Is_Fixed_Point_Type (T2)
9017                  and then Scope (Base_Type (T2)) = Scop
9018                  and then (Is_Potentially_Use_Visible (T2)
9019                              or else In_Use (T2))
9020                then
9021                   if Present (T1) then
9022                      Fixed_Point_Error;
9023                      return Any_Type;
9024                   else
9025                      T1 := T2;
9026                   end if;
9027                end if;
9028
9029                Next_Entity (T2);
9030             end loop;
9031          end if;
9032
9033          Next (Item);
9034       end loop;
9035
9036       if Nkind (N) = N_Real_Literal then
9037          Error_Msg_NE ("?real literal interpreted as }!", N, T1);
9038       else
9039          Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1);
9040       end if;
9041
9042       return T1;
9043    end Unique_Fixed_Point_Type;
9044
9045    ----------------------
9046    -- Valid_Conversion --
9047    ----------------------
9048
9049    function Valid_Conversion
9050      (N       : Node_Id;
9051       Target  : Entity_Id;
9052       Operand : Node_Id) return Boolean
9053    is
9054       Target_Type : constant Entity_Id := Base_Type (Target);
9055       Opnd_Type   : Entity_Id := Etype (Operand);
9056
9057       function Conversion_Check
9058         (Valid : Boolean;
9059          Msg   : String) return Boolean;
9060       --  Little routine to post Msg if Valid is False, returns Valid value
9061
9062       function Valid_Tagged_Conversion
9063         (Target_Type : Entity_Id;
9064          Opnd_Type   : Entity_Id) return Boolean;
9065       --  Specifically test for validity of tagged conversions
9066
9067       function Valid_Array_Conversion return Boolean;
9068       --  Check index and component conformance, and accessibility levels
9069       --  if the component types are anonymous access types (Ada 2005)
9070
9071       ----------------------
9072       -- Conversion_Check --
9073       ----------------------
9074
9075       function Conversion_Check
9076         (Valid : Boolean;
9077          Msg   : String) return Boolean
9078       is
9079       begin
9080          if not Valid then
9081             Error_Msg_N (Msg, Operand);
9082          end if;
9083
9084          return Valid;
9085       end Conversion_Check;
9086
9087       ----------------------------
9088       -- Valid_Array_Conversion --
9089       ----------------------------
9090
9091       function Valid_Array_Conversion return Boolean
9092       is
9093          Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type);
9094          Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type);
9095
9096          Opnd_Index      : Node_Id;
9097          Opnd_Index_Type : Entity_Id;
9098
9099          Target_Comp_Type : constant Entity_Id :=
9100                               Component_Type (Target_Type);
9101          Target_Comp_Base : constant Entity_Id :=
9102                               Base_Type (Target_Comp_Type);
9103
9104          Target_Index      : Node_Id;
9105          Target_Index_Type : Entity_Id;
9106
9107       begin
9108          --  Error if wrong number of dimensions
9109
9110          if
9111            Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type)
9112          then
9113             Error_Msg_N
9114               ("incompatible number of dimensions for conversion", Operand);
9115             return False;
9116
9117          --  Number of dimensions matches
9118
9119          else
9120             --  Loop through indexes of the two arrays
9121
9122             Target_Index := First_Index (Target_Type);
9123             Opnd_Index   := First_Index (Opnd_Type);
9124             while Present (Target_Index) and then Present (Opnd_Index) loop
9125                Target_Index_Type := Etype (Target_Index);
9126                Opnd_Index_Type   := Etype (Opnd_Index);
9127
9128                --  Error if index types are incompatible
9129
9130                if not (Is_Integer_Type (Target_Index_Type)
9131                        and then Is_Integer_Type (Opnd_Index_Type))
9132                  and then (Root_Type (Target_Index_Type)
9133                            /= Root_Type (Opnd_Index_Type))
9134                then
9135                   Error_Msg_N
9136                     ("incompatible index types for array conversion",
9137                      Operand);
9138                   return False;
9139                end if;
9140
9141                Next_Index (Target_Index);
9142                Next_Index (Opnd_Index);
9143             end loop;
9144
9145             --  If component types have same base type, all set
9146
9147             if Target_Comp_Base  = Opnd_Comp_Base then
9148                null;
9149
9150                --  Here if base types of components are not the same. The only
9151                --  time this is allowed is if we have anonymous access types.
9152
9153                --  The conversion of arrays of anonymous access types can lead
9154                --  to dangling pointers. AI-392 formalizes the accessibility
9155                --  checks that must be applied to such conversions to prevent
9156                --  out-of-scope references.
9157
9158             elsif
9159               (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type
9160                  or else
9161                Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type)
9162               and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base)
9163               and then
9164                 Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
9165             then
9166                if Type_Access_Level (Target_Type) <
9167                    Type_Access_Level (Opnd_Type)
9168                then
9169                   if In_Instance_Body then
9170                      Error_Msg_N ("?source array type " &
9171                        "has deeper accessibility level than target", Operand);
9172                      Error_Msg_N ("\?Program_Error will be raised at run time",
9173                          Operand);
9174                      Rewrite (N,
9175                        Make_Raise_Program_Error (Sloc (N),
9176                          Reason => PE_Accessibility_Check_Failed));
9177                      Set_Etype (N, Target_Type);
9178                      return False;
9179
9180                   --  Conversion not allowed because of accessibility levels
9181
9182                   else
9183                      Error_Msg_N ("source array type " &
9184                        "has deeper accessibility level than target", Operand);
9185                      return False;
9186                   end if;
9187                else
9188                   null;
9189                end if;
9190
9191             --  All other cases where component base types do not match
9192
9193             else
9194                Error_Msg_N
9195                  ("incompatible component types for array conversion",
9196                   Operand);
9197                return False;
9198             end if;
9199
9200             --  Check that component subtypes statically match. For numeric
9201             --  types this means that both must be either constrained or
9202             --  unconstrained. For enumeration types the bounds must match.
9203             --  All of this is checked in Subtypes_Statically_Match.
9204
9205             if not Subtypes_Statically_Match
9206                             (Target_Comp_Type, Opnd_Comp_Type)
9207             then
9208                Error_Msg_N
9209                  ("component subtypes must statically match", Operand);
9210                return False;
9211             end if;
9212          end if;
9213
9214          return True;
9215       end Valid_Array_Conversion;
9216
9217       -----------------------------
9218       -- Valid_Tagged_Conversion --
9219       -----------------------------
9220
9221       function Valid_Tagged_Conversion
9222         (Target_Type : Entity_Id;
9223          Opnd_Type   : Entity_Id) return Boolean
9224       is
9225       begin
9226          --  Upward conversions are allowed (RM 4.6(22))
9227
9228          if Covers (Target_Type, Opnd_Type)
9229            or else Is_Ancestor (Target_Type, Opnd_Type)
9230          then
9231             return True;
9232
9233          --  Downward conversion are allowed if the operand is class-wide
9234          --  (RM 4.6(23)).
9235
9236          elsif Is_Class_Wide_Type (Opnd_Type)
9237            and then Covers (Opnd_Type, Target_Type)
9238          then
9239             return True;
9240
9241          elsif Covers (Opnd_Type, Target_Type)
9242            or else Is_Ancestor (Opnd_Type, Target_Type)
9243          then
9244             return
9245               Conversion_Check (False,
9246                 "downward conversion of tagged objects not allowed");
9247
9248          --  Ada 2005 (AI-251): The conversion to/from interface types is
9249          --  always valid
9250
9251          elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then
9252             return True;
9253
9254          --  If the operand is a class-wide type obtained through a limited_
9255          --  with clause, and the context includes the non-limited view, use
9256          --  it to determine whether the conversion is legal.
9257
9258          elsif Is_Class_Wide_Type (Opnd_Type)
9259            and then From_With_Type (Opnd_Type)
9260            and then Present (Non_Limited_View (Etype (Opnd_Type)))
9261            and then Is_Interface (Non_Limited_View (Etype (Opnd_Type)))
9262          then
9263             return True;
9264
9265          elsif Is_Access_Type (Opnd_Type)
9266            and then Is_Interface (Directly_Designated_Type (Opnd_Type))
9267          then
9268             return True;
9269
9270          else
9271             Error_Msg_NE
9272               ("invalid tagged conversion, not compatible with}",
9273                N, First_Subtype (Opnd_Type));
9274             return False;
9275          end if;
9276       end Valid_Tagged_Conversion;
9277
9278    --  Start of processing for Valid_Conversion
9279
9280    begin
9281       Check_Parameterless_Call (Operand);
9282
9283       if Is_Overloaded (Operand) then
9284          declare
9285             I   : Interp_Index;
9286             I1  : Interp_Index;
9287             It  : Interp;
9288             It1 : Interp;
9289             N1  : Entity_Id;
9290
9291          begin
9292             --  Remove procedure calls, which syntactically cannot appear in
9293             --  this context, but which cannot be removed by type checking,
9294             --  because the context does not impose a type.
9295
9296             --  When compiling for VMS, spurious ambiguities can be produced
9297             --  when arithmetic operations have a literal operand and return
9298             --  System.Address or a descendant of it. These ambiguities are
9299             --  otherwise resolved by the context, but for conversions there
9300             --  is no context type and the removal of the spurious operations
9301             --  must be done explicitly here.
9302
9303             --  The node may be labelled overloaded, but still contain only
9304             --  one interpretation because others were discarded in previous
9305             --  filters. If this is the case, retain the single interpretation
9306             --  if legal.
9307
9308             Get_First_Interp (Operand, I, It);
9309             Opnd_Type := It.Typ;
9310             Get_Next_Interp (I, It);
9311
9312             if Present (It.Typ)
9313               and then Opnd_Type /= Standard_Void_Type
9314             then
9315                --  More than one candidate interpretation is available
9316
9317                Get_First_Interp (Operand, I, It);
9318                while Present (It.Typ) loop
9319                   if It.Typ = Standard_Void_Type then
9320                      Remove_Interp (I);
9321                   end if;
9322
9323                   if Present (System_Aux_Id)
9324                     and then Is_Descendent_Of_Address (It.Typ)
9325                   then
9326                      Remove_Interp (I);
9327                   end if;
9328
9329                   Get_Next_Interp (I, It);
9330                end loop;
9331             end if;
9332
9333             Get_First_Interp (Operand, I, It);
9334             I1  := I;
9335             It1 := It;
9336
9337             if No (It.Typ) then
9338                Error_Msg_N ("illegal operand in conversion", Operand);
9339                return False;
9340             end if;
9341
9342             Get_Next_Interp (I, It);
9343
9344             if Present (It.Typ) then
9345                N1  := It1.Nam;
9346                It1 :=  Disambiguate (Operand, I1, I, Any_Type);
9347
9348                if It1 = No_Interp then
9349                   Error_Msg_N ("ambiguous operand in conversion", Operand);
9350
9351                   Error_Msg_Sloc := Sloc (It.Nam);
9352                   Error_Msg_N -- CODEFIX
9353                     ("\\possible interpretation#!", Operand);
9354
9355                   Error_Msg_Sloc := Sloc (N1);
9356                   Error_Msg_N -- CODEFIX
9357                     ("\\possible interpretation#!", Operand);
9358
9359                   return False;
9360                end if;
9361             end if;
9362
9363             Set_Etype (Operand, It1.Typ);
9364             Opnd_Type := It1.Typ;
9365          end;
9366       end if;
9367
9368       --  Numeric types
9369
9370       if Is_Numeric_Type (Target_Type)  then
9371
9372          --  A universal fixed expression can be converted to any numeric type
9373
9374          if Opnd_Type = Universal_Fixed then
9375             return True;
9376
9377          --  Also no need to check when in an instance or inlined body, because
9378          --  the legality has been established when the template was analyzed.
9379          --  Furthermore, numeric conversions may occur where only a private
9380          --  view of the operand type is visible at the instantiation point.
9381          --  This results in a spurious error if we check that the operand type
9382          --  is a numeric type.
9383
9384          --  Note: in a previous version of this unit, the following tests were
9385          --  applied only for generated code (Comes_From_Source set to False),
9386          --  but in fact the test is required for source code as well, since
9387          --  this situation can arise in source code.
9388
9389          elsif In_Instance or else In_Inlined_Body then
9390                return True;
9391
9392          --  Otherwise we need the conversion check
9393
9394          else
9395             return Conversion_Check
9396                     (Is_Numeric_Type (Opnd_Type),
9397                      "illegal operand for numeric conversion");
9398          end if;
9399
9400       --  Array types
9401
9402       elsif Is_Array_Type (Target_Type) then
9403          if not Is_Array_Type (Opnd_Type)
9404            or else Opnd_Type = Any_Composite
9405            or else Opnd_Type = Any_String
9406          then
9407             Error_Msg_N
9408               ("illegal operand for array conversion", Operand);
9409             return False;
9410          else
9411             return Valid_Array_Conversion;
9412          end if;
9413
9414       --  Ada 2005 (AI-251): Anonymous access types where target references an
9415       --  interface type.
9416
9417       elsif (Ekind (Target_Type) = E_General_Access_Type
9418               or else
9419              Ekind (Target_Type) = E_Anonymous_Access_Type)
9420         and then Is_Interface (Directly_Designated_Type (Target_Type))
9421       then
9422          --  Check the static accessibility rule of 4.6(17). Note that the
9423          --  check is not enforced when within an instance body, since the
9424          --  RM requires such cases to be caught at run time.
9425
9426          if Ekind (Target_Type) /= E_Anonymous_Access_Type then
9427             if Type_Access_Level (Opnd_Type) >
9428                Type_Access_Level (Target_Type)
9429             then
9430                --  In an instance, this is a run-time check, but one we know
9431                --  will fail, so generate an appropriate warning. The raise
9432                --  will be generated by Expand_N_Type_Conversion.
9433
9434                if In_Instance_Body then
9435                   Error_Msg_N
9436                     ("?cannot convert local pointer to non-local access type",
9437                      Operand);
9438                   Error_Msg_N
9439                     ("\?Program_Error will be raised at run time", Operand);
9440                else
9441                   Error_Msg_N
9442                     ("cannot convert local pointer to non-local access type",
9443                      Operand);
9444                   return False;
9445                end if;
9446
9447             --  Special accessibility checks are needed in the case of access
9448             --  discriminants declared for a limited type.
9449
9450             elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
9451               and then not Is_Local_Anonymous_Access (Opnd_Type)
9452             then
9453                --  When the operand is a selected access discriminant the check
9454                --  needs to be made against the level of the object denoted by
9455                --  the prefix of the selected name (Object_Access_Level handles
9456                --  checking the prefix of the operand for this case).
9457
9458                if Nkind (Operand) = N_Selected_Component
9459                  and then Object_Access_Level (Operand) >
9460                           Type_Access_Level (Target_Type)
9461                then
9462                   --  In an instance, this is a run-time check, but one we know
9463                   --  will fail, so generate an appropriate warning. The raise
9464                   --  will be generated by Expand_N_Type_Conversion.
9465
9466                   if In_Instance_Body then
9467                      Error_Msg_N
9468                        ("?cannot convert access discriminant to non-local" &
9469                         " access type", Operand);
9470                      Error_Msg_N
9471                        ("\?Program_Error will be raised at run time", Operand);
9472                   else
9473                      Error_Msg_N
9474                        ("cannot convert access discriminant to non-local" &
9475                         " access type", Operand);
9476                      return False;
9477                   end if;
9478                end if;
9479
9480                --  The case of a reference to an access discriminant from
9481                --  within a limited type declaration (which will appear as
9482                --  a discriminal) is always illegal because the level of the
9483                --  discriminant is considered to be deeper than any (nameable)
9484                --  access type.
9485
9486                if Is_Entity_Name (Operand)
9487                  and then not Is_Local_Anonymous_Access (Opnd_Type)
9488                  and then (Ekind (Entity (Operand)) = E_In_Parameter
9489                             or else Ekind (Entity (Operand)) = E_Constant)
9490                  and then Present (Discriminal_Link (Entity (Operand)))
9491                then
9492                   Error_Msg_N
9493                     ("discriminant has deeper accessibility level than target",
9494                      Operand);
9495                   return False;
9496                end if;
9497             end if;
9498          end if;
9499
9500          return True;
9501
9502       --  General and anonymous access types
9503
9504       elsif (Ekind (Target_Type) = E_General_Access_Type
9505         or else Ekind (Target_Type) = E_Anonymous_Access_Type)
9506           and then
9507             Conversion_Check
9508               (Is_Access_Type (Opnd_Type)
9509                  and then Ekind (Opnd_Type) /=
9510                    E_Access_Subprogram_Type
9511                  and then Ekind (Opnd_Type) /=
9512                    E_Access_Protected_Subprogram_Type,
9513                "must be an access-to-object type")
9514       then
9515          if Is_Access_Constant (Opnd_Type)
9516            and then not Is_Access_Constant (Target_Type)
9517          then
9518             Error_Msg_N
9519               ("access-to-constant operand type not allowed", Operand);
9520             return False;
9521          end if;
9522
9523          --  Check the static accessibility rule of 4.6(17). Note that the
9524          --  check is not enforced when within an instance body, since the RM
9525          --  requires such cases to be caught at run time.
9526
9527          if Ekind (Target_Type) /= E_Anonymous_Access_Type
9528            or else Is_Local_Anonymous_Access (Target_Type)
9529          then
9530             if Type_Access_Level (Opnd_Type)
9531               > Type_Access_Level (Target_Type)
9532             then
9533                --  In an instance, this is a run-time check, but one we know
9534                --  will fail, so generate an appropriate warning. The raise
9535                --  will be generated by Expand_N_Type_Conversion.
9536
9537                if In_Instance_Body then
9538                   Error_Msg_N
9539                     ("?cannot convert local pointer to non-local access type",
9540                      Operand);
9541                   Error_Msg_N
9542                     ("\?Program_Error will be raised at run time", Operand);
9543
9544                else
9545                   --  Avoid generation of spurious error message
9546
9547                   if not Error_Posted (N) then
9548                      Error_Msg_N
9549                       ("cannot convert local pointer to non-local access type",
9550                        Operand);
9551                   end if;
9552
9553                   return False;
9554                end if;
9555
9556             --  Special accessibility checks are needed in the case of access
9557             --  discriminants declared for a limited type.
9558
9559             elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
9560               and then not Is_Local_Anonymous_Access (Opnd_Type)
9561             then
9562
9563                --  When the operand is a selected access discriminant the check
9564                --  needs to be made against the level of the object denoted by
9565                --  the prefix of the selected name (Object_Access_Level handles
9566                --  checking the prefix of the operand for this case).
9567
9568                if Nkind (Operand) = N_Selected_Component
9569                  and then Object_Access_Level (Operand) >
9570                           Type_Access_Level (Target_Type)
9571                then
9572                   --  In an instance, this is a run-time check, but one we know
9573                   --  will fail, so generate an appropriate warning. The raise
9574                   --  will be generated by Expand_N_Type_Conversion.
9575
9576                   if In_Instance_Body then
9577                      Error_Msg_N
9578                        ("?cannot convert access discriminant to non-local" &
9579                         " access type", Operand);
9580                      Error_Msg_N
9581                        ("\?Program_Error will be raised at run time",
9582                         Operand);
9583
9584                   else
9585                      Error_Msg_N
9586                        ("cannot convert access discriminant to non-local" &
9587                         " access type", Operand);
9588                      return False;
9589                   end if;
9590                end if;
9591
9592                --  The case of a reference to an access discriminant from
9593                --  within a limited type declaration (which will appear as
9594                --  a discriminal) is always illegal because the level of the
9595                --  discriminant is considered to be deeper than any (nameable)
9596                --  access type.
9597
9598                if Is_Entity_Name (Operand)
9599                  and then (Ekind (Entity (Operand)) = E_In_Parameter
9600                             or else Ekind (Entity (Operand)) = E_Constant)
9601                  and then Present (Discriminal_Link (Entity (Operand)))
9602                then
9603                   Error_Msg_N
9604                     ("discriminant has deeper accessibility level than target",
9605                      Operand);
9606                   return False;
9607                end if;
9608             end if;
9609          end if;
9610
9611          --  In the presence of limited_with clauses we have to use non-limited
9612          --  views, if available.
9613
9614          Check_Limited : declare
9615             function Full_Designated_Type (T : Entity_Id) return Entity_Id;
9616             --  Helper function to handle limited views
9617
9618             --------------------------
9619             -- Full_Designated_Type --
9620             --------------------------
9621
9622             function Full_Designated_Type (T : Entity_Id) return Entity_Id is
9623                Desig : Entity_Id := Designated_Type (T);
9624
9625             begin
9626                if Is_Incomplete_Type (Desig)
9627                  and then From_With_Type (Desig)
9628                  and then Present (Non_Limited_View (Desig))
9629                then
9630                   Desig := Non_Limited_View (Desig);
9631
9632                   --  The shadow entity's non-limited view may designate an
9633                   --  incomplete type.
9634
9635                   if Is_Incomplete_Type (Desig)
9636                     and then Present (Full_View (Desig))
9637                   then
9638                      Desig := Full_View (Desig);
9639                   end if;
9640                end if;
9641
9642                return Desig;
9643             end Full_Designated_Type;
9644
9645             --  Local Declarations
9646
9647             Target : constant Entity_Id := Full_Designated_Type (Target_Type);
9648             Opnd   : constant Entity_Id := Full_Designated_Type (Opnd_Type);
9649
9650             Same_Base : constant Boolean :=
9651                           Base_Type (Target) = Base_Type (Opnd);
9652
9653          --  Start of processing for Check_Limited
9654
9655          begin
9656             if Is_Tagged_Type (Target) then
9657                return Valid_Tagged_Conversion (Target, Opnd);
9658
9659             else
9660                if not Same_Base then
9661                   Error_Msg_NE
9662                     ("target designated type not compatible with }",
9663                      N, Base_Type (Opnd));
9664                   return False;
9665
9666                --  Ada 2005 AI-384: legality rule is symmetric in both
9667                --  designated types. The conversion is legal (with possible
9668                --  constraint check) if either designated type is
9669                --  unconstrained.
9670
9671                elsif Subtypes_Statically_Match (Target, Opnd)
9672                  or else
9673                    (Has_Discriminants (Target)
9674                      and then
9675                       (not Is_Constrained (Opnd)
9676                         or else not Is_Constrained (Target)))
9677                then
9678                   --  Special case, if Value_Size has been used to make the
9679                   --  sizes different, the conversion is not allowed even
9680                   --  though the subtypes statically match.
9681
9682                   if Known_Static_RM_Size (Target)
9683                     and then Known_Static_RM_Size (Opnd)
9684                     and then RM_Size (Target) /= RM_Size (Opnd)
9685                   then
9686                      Error_Msg_NE
9687                        ("target designated subtype not compatible with }",
9688                         N, Opnd);
9689                      Error_Msg_NE
9690                        ("\because sizes of the two designated subtypes differ",
9691                         N, Opnd);
9692                      return False;
9693
9694                   --  Normal case where conversion is allowed
9695
9696                   else
9697                      return True;
9698                   end if;
9699
9700                else
9701                   Error_Msg_NE
9702                     ("target designated subtype not compatible with }",
9703                      N, Opnd);
9704                   return False;
9705                end if;
9706             end if;
9707          end Check_Limited;
9708
9709       --  Access to subprogram types. If the operand is an access parameter,
9710       --  the type has a deeper accessibility that any master, and cannot
9711       --  be assigned. We must make an exception if the conversion is part
9712       --  of an assignment and the target is the return object of an extended
9713       --  return statement, because in that case the accessibility check
9714       --  takes place after the return.
9715
9716       elsif Is_Access_Subprogram_Type (Target_Type)
9717         and then No (Corresponding_Remote_Type (Opnd_Type))
9718       then
9719          if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type
9720            and then Is_Entity_Name (Operand)
9721            and then Ekind (Entity (Operand)) = E_In_Parameter
9722            and then
9723              (Nkind (Parent (N)) /= N_Assignment_Statement
9724                or else not Is_Entity_Name (Name (Parent (N)))
9725                or else not Is_Return_Object (Entity (Name (Parent (N)))))
9726          then
9727             Error_Msg_N
9728               ("illegal attempt to store anonymous access to subprogram",
9729                Operand);
9730             Error_Msg_N
9731               ("\value has deeper accessibility than any master " &
9732                "(RM 3.10.2 (13))",
9733                Operand);
9734
9735             Error_Msg_NE
9736              ("\use named access type for& instead of access parameter",
9737                Operand, Entity (Operand));
9738          end if;
9739
9740          --  Check that the designated types are subtype conformant
9741
9742          Check_Subtype_Conformant (New_Id  => Designated_Type (Target_Type),
9743                                    Old_Id  => Designated_Type (Opnd_Type),
9744                                    Err_Loc => N);
9745
9746          --  Check the static accessibility rule of 4.6(20)
9747
9748          if Type_Access_Level (Opnd_Type) >
9749             Type_Access_Level (Target_Type)
9750          then
9751             Error_Msg_N
9752               ("operand type has deeper accessibility level than target",
9753                Operand);
9754
9755          --  Check that if the operand type is declared in a generic body,
9756          --  then the target type must be declared within that same body
9757          --  (enforces last sentence of 4.6(20)).
9758
9759          elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
9760             declare
9761                O_Gen : constant Node_Id :=
9762                          Enclosing_Generic_Body (Opnd_Type);
9763
9764                T_Gen : Node_Id;
9765
9766             begin
9767                T_Gen := Enclosing_Generic_Body (Target_Type);
9768                while Present (T_Gen) and then T_Gen /= O_Gen loop
9769                   T_Gen := Enclosing_Generic_Body (T_Gen);
9770                end loop;
9771
9772                if T_Gen /= O_Gen then
9773                   Error_Msg_N
9774                     ("target type must be declared in same generic body"
9775                      & " as operand type", N);
9776                end if;
9777             end;
9778          end if;
9779
9780          return True;
9781
9782       --  Remote subprogram access types
9783
9784       elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
9785         and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
9786       then
9787          --  It is valid to convert from one RAS type to another provided
9788          --  that their specification statically match.
9789
9790          Check_Subtype_Conformant
9791            (New_Id  =>
9792               Designated_Type (Corresponding_Remote_Type (Target_Type)),
9793             Old_Id  =>
9794               Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
9795             Err_Loc =>
9796               N);
9797          return True;
9798
9799       --  If both are tagged types, check legality of view conversions
9800
9801       elsif Is_Tagged_Type (Target_Type)
9802         and then Is_Tagged_Type (Opnd_Type)
9803       then
9804          return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
9805
9806       --  Types derived from the same root type are convertible
9807
9808       elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
9809          return True;
9810
9811       --  In an instance or an inlined body, there may be inconsistent
9812       --  views of the same type, or of types derived from a common root.
9813
9814       elsif (In_Instance or In_Inlined_Body)
9815         and then
9816           Root_Type (Underlying_Type (Target_Type)) =
9817           Root_Type (Underlying_Type (Opnd_Type))
9818       then
9819          return True;
9820
9821       --  Special check for common access type error case
9822
9823       elsif Ekind (Target_Type) = E_Access_Type
9824          and then Is_Access_Type (Opnd_Type)
9825       then
9826          Error_Msg_N ("target type must be general access type!", N);
9827          Error_Msg_NE ("add ALL to }!", N, Target_Type);
9828          return False;
9829
9830       else
9831          Error_Msg_NE ("invalid conversion, not compatible with }",
9832            N, Opnd_Type);
9833          return False;
9834       end if;
9835    end Valid_Conversion;
9836
9837 end Sem_Res;