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