gcc/ada/sem_res.adb

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