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