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