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