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-2015, 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 Errout;   use Errout;
  32 with Expander; use Expander;
  33 with Exp_Disp; use Exp_Disp;
  34 with Exp_Ch6;  use Exp_Ch6;
  35 with Exp_Ch7;  use Exp_Ch7;
  36 with Exp_Tss;  use Exp_Tss;
  37 with Exp_Util; use Exp_Util;
  38 with Fname;    use Fname;
  39 with Freeze;   use Freeze;
  40 with Ghost;    use Ghost;
  41 with Inline;   use Inline;
  42 with Itypes;   use Itypes;
  43 with Lib;      use Lib;
  44 with Lib.Xref; use Lib.Xref;
  45 with Namet;    use Namet;
  46 with Nmake;    use Nmake;
  47 with Nlists;   use Nlists;
  48 with Opt;      use Opt;
  49 with Output;   use Output;
  50 with Par_SCO;  use Par_SCO;
  51 with Restrict; use Restrict;
  52 with Rident;   use Rident;
  53 with Rtsfind;  use Rtsfind;
  54 with Sem;      use Sem;
  55 with Sem_Aux;  use Sem_Aux;
  56 with Sem_Aggr; use Sem_Aggr;
  57 with Sem_Attr; use Sem_Attr;
  58 with Sem_Cat;  use Sem_Cat;
  59 with Sem_Ch4;  use Sem_Ch4;
  60 with Sem_Ch3;  use Sem_Ch3;
  61 with Sem_Ch6;  use Sem_Ch6;
  62 with Sem_Ch8;  use Sem_Ch8;
  63 with Sem_Ch13; use Sem_Ch13;
  64 with Sem_Dim;  use Sem_Dim;
  65 with Sem_Disp; use Sem_Disp;
  66 with Sem_Dist; use Sem_Dist;
  67 with Sem_Elim; use Sem_Elim;
  68 with Sem_Elab; use Sem_Elab;
  69 with Sem_Eval; use Sem_Eval;
  70 with Sem_Intr; use Sem_Intr;
  71 with Sem_Util; use Sem_Util;
  72 with Targparm; use Targparm;
  73 with Sem_Type; use Sem_Type;
  74 with Sem_Warn; use Sem_Warn;
  75 with Sinfo;    use Sinfo;
  76 with Sinfo.CN; use Sinfo.CN;
  77 with Snames;   use Snames;
  78 with Stand;    use Stand;
  79 with Stringt;  use Stringt;
  80 with Style;    use Style;
  81 with Tbuild;   use Tbuild;
  82 with Uintp;    use Uintp;
  83 with Urealp;   use Urealp;
  84
  85 package body Sem_Res is
  86
  87    -----------------------
  88    -- Local Subprograms --
  89    -----------------------
  90
  91    --  Second pass (top-down) type checking and overload resolution procedures
  92    --  Typ is the type required by context. These procedures propagate the
  93    --  type information recursively to the descendants of N. If the node is not
  94    --  overloaded, its Etype is established in the first pass. If overloaded,
  95    --  the Resolve routines set the correct type. For arithmetic operators, the
  96    --  Etype is the base type of the context.
  97
  98    --  Note that Resolve_Attribute is separated off in Sem_Attr
  99
 100    procedure Check_Discriminant_Use (N : Node_Id);
 101    --  Enforce the restrictions on the use of discriminants when constraining
 102    --  a component of a discriminated type (record or concurrent type).
 103
 104    procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);
 105    --  Given a node for an operator associated with type T, check that the
 106    --  operator is visible. Operators all of whose operands are universal must
 107    --  be checked for visibility during resolution because their type is not
 108    --  determinable based on their operands.
 109
 110    procedure Check_Fully_Declared_Prefix
 111      (Typ  : Entity_Id;
 112       Pref : Node_Id);
 113    --  Check that the type of the prefix of a dereference is not incomplete
 114
 115    function Check_Infinite_Recursion (N : Node_Id) return Boolean;
 116    --  Given a call node, N, which is known to occur immediately within the
 117    --  subprogram being called, determines whether it is a detectable case of
 118    --  an infinite recursion, and if so, outputs appropriate messages. Returns
 119    --  True if an infinite recursion is detected, and False otherwise.
 120
 121    procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
 122    --  If the type of the object being initialized uses the secondary stack
 123    --  directly or indirectly, create a transient scope for the call to the
 124    --  init proc. This is because we do not create transient scopes for the
 125    --  initialization of individual components within the init proc itself.
 126    --  Could be optimized away perhaps?
 127
 128    procedure Check_No_Direct_Boolean_Operators (N : Node_Id);
 129    --  N is the node for a logical operator. If the operator is predefined, and
 130    --  the root type of the operands is Standard.Boolean, then a check is made
 131    --  for restriction No_Direct_Boolean_Operators. This procedure also handles
 132    --  the style check for Style_Check_Boolean_And_Or.
 133
 134    function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean;
 135    --  N is either an indexed component or a selected component. This function
 136    --  returns true if the prefix refers to an object that has an address
 137    --  clause (the case in which we may want to issue a warning).
 138
 139    function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
 140    --  Determine whether E is an access type declared by an access declaration,
 141    --  and not an (anonymous) allocator type.
 142
 143    function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
 144    --  Utility to check whether the entity for an operator is a predefined
 145    --  operator, in which case the expression is left as an operator in the
 146    --  tree (else it is rewritten into a call). An instance of an intrinsic
 147    --  conversion operation may be given an operator name, but is not treated
 148    --  like an operator. Note that an operator that is an imported back-end
 149    --  builtin has convention Intrinsic, but is expected to be rewritten into
 150    --  a call, so such an operator is not treated as predefined by this
 151    --  predicate.
 152
 153    procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);
 154    --  If a default expression in entry call N depends on the discriminants
 155    --  of the task, it must be replaced with a reference to the discriminant
 156    --  of the task being called.
 157
 158    procedure Resolve_Op_Concat_Arg
 159      (N       : Node_Id;
 160       Arg     : Node_Id;
 161       Typ     : Entity_Id;
 162       Is_Comp : Boolean);
 163    --  Internal procedure for Resolve_Op_Concat to resolve one operand of
 164    --  concatenation operator.  The operand is either of the array type or of
 165    --  the component type. If the operand is an aggregate, and the component
 166    --  type is composite, this is ambiguous if component type has aggregates.
 167
 168    procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id);
 169    --  Does the first part of the work of Resolve_Op_Concat
 170
 171    procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id);
 172    --  Does the "rest" of the work of Resolve_Op_Concat, after the left operand
 173    --  has been resolved. See Resolve_Op_Concat for details.
 174
 175    procedure Resolve_Allocator                 (N : Node_Id; Typ : Entity_Id);
 176    procedure Resolve_Arithmetic_Op             (N : Node_Id; Typ : Entity_Id);
 177    procedure Resolve_Call                      (N : Node_Id; Typ : Entity_Id);
 178    procedure Resolve_Case_Expression           (N : Node_Id; Typ : Entity_Id);
 179    procedure Resolve_Character_Literal         (N : Node_Id; Typ : Entity_Id);
 180    procedure Resolve_Comparison_Op             (N : Node_Id; Typ : Entity_Id);
 181    procedure Resolve_Entity_Name               (N : Node_Id; Typ : Entity_Id);
 182    procedure Resolve_Equality_Op               (N : Node_Id; Typ : Entity_Id);
 183    procedure Resolve_Explicit_Dereference      (N : Node_Id; Typ : Entity_Id);
 184    procedure Resolve_Expression_With_Actions   (N : Node_Id; Typ : Entity_Id);
 185    procedure Resolve_If_Expression             (N : Node_Id; Typ : Entity_Id);
 186    procedure Resolve_Generalized_Indexing      (N : Node_Id; Typ : Entity_Id);
 187    procedure Resolve_Indexed_Component         (N : Node_Id; Typ : Entity_Id);
 188    procedure Resolve_Integer_Literal           (N : Node_Id; Typ : Entity_Id);
 189    procedure Resolve_Logical_Op                (N : Node_Id; Typ : Entity_Id);
 190    procedure Resolve_Membership_Op             (N : Node_Id; Typ : Entity_Id);
 191    procedure Resolve_Null                      (N : Node_Id; Typ : Entity_Id);
 192    procedure Resolve_Operator_Symbol           (N : Node_Id; Typ : Entity_Id);
 193    procedure Resolve_Op_Concat                 (N : Node_Id; Typ : Entity_Id);
 194    procedure Resolve_Op_Expon                  (N : Node_Id; Typ : Entity_Id);
 195    procedure Resolve_Op_Not                    (N : Node_Id; Typ : Entity_Id);
 196    procedure Resolve_Qualified_Expression      (N : Node_Id; Typ : Entity_Id);
 197    procedure Resolve_Raise_Expression          (N : Node_Id; Typ : Entity_Id);
 198    procedure Resolve_Range                     (N : Node_Id; Typ : Entity_Id);
 199    procedure Resolve_Real_Literal              (N : Node_Id; Typ : Entity_Id);
 200    procedure Resolve_Reference                 (N : Node_Id; Typ : Entity_Id);
 201    procedure Resolve_Selected_Component        (N : Node_Id; Typ : Entity_Id);
 202    procedure Resolve_Shift                     (N : Node_Id; Typ : Entity_Id);
 203    procedure Resolve_Short_Circuit             (N : Node_Id; Typ : Entity_Id);
 204    procedure Resolve_Slice                     (N : Node_Id; Typ : Entity_Id);
 205    procedure Resolve_String_Literal            (N : Node_Id; Typ : Entity_Id);
 206    procedure Resolve_Type_Conversion           (N : Node_Id; Typ : Entity_Id);
 207    procedure Resolve_Unary_Op                  (N : Node_Id; Typ : Entity_Id);
 208    procedure Resolve_Unchecked_Expression      (N : Node_Id; Typ : Entity_Id);
 209    procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id);
 210
 211    function Operator_Kind
 212      (Op_Name   : Name_Id;
 213       Is_Binary : Boolean) return Node_Kind;
 214    --  Utility to map the name of an operator into the corresponding Node. Used
 215    --  by other node rewriting procedures.
 216
 217    procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
 218    --  Resolve actuals of call, and add default expressions for missing ones.
 219    --  N is the Node_Id for the subprogram call, and Nam is the entity of the
 220    --  called subprogram.
 221
 222    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
 223    --  Called from Resolve_Call, when the prefix denotes an entry or element
 224    --  of entry family. Actuals are resolved as for subprograms, and the node
 225    --  is rebuilt as an entry call. Also called for protected operations. Typ
 226    --  is the context type, which is used when the operation is a protected
 227    --  function with no arguments, and the return value is indexed.
 228
 229    procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
 230    --  A call to a user-defined intrinsic operator is rewritten as a call to
 231    --  the corresponding predefined operator, with suitable conversions. Note
 232    --  that this applies only for intrinsic operators that denote predefined
 233    --  operators, not ones that are intrinsic imports of back-end builtins.
 234
 235    procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
 236    --  Ditto, for arithmetic unary operators
 237
 238    procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
 239    --  If an operator node resolves to a call to a user-defined operator,
 240    --  rewrite the node as a function call.
 241
 242    procedure Make_Call_Into_Operator
 243      (N     : Node_Id;
 244       Typ   : Entity_Id;
 245       Op_Id : Entity_Id);
 246    --  Inverse transformation: if an operator is given in functional notation,
 247    --  then after resolving the node, transform into an operator node, so that
 248    --  operands are resolved properly. Recall that predefined operators do not
 249    --  have a full signature and special resolution rules apply.
 250
 251    procedure Rewrite_Renamed_Operator
 252      (N   : Node_Id;
 253       Op  : Entity_Id;
 254       Typ : Entity_Id);
 255    --  An operator can rename another, e.g. in an instantiation. In that
 256    --  case, the proper operator node must be constructed and resolved.
 257
 258    procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
 259    --  The String_Literal_Subtype is built for all strings that are not
 260    --  operands of a static concatenation operation. If the argument is not
 261    --  a N_String_Literal node, then the call has no effect.
 262
 263    procedure Set_Slice_Subtype (N : Node_Id);
 264    --  Build subtype of array type, with the range specified by the slice
 265
 266    procedure Simplify_Type_Conversion (N : Node_Id);
 267    --  Called after N has been resolved and evaluated, but before range checks
 268    --  have been applied. Currently simplifies a combination of floating-point
 269    --  to integer conversion and Rounding or Truncation attribute.
 270
 271    function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
 272    --  A universal_fixed expression in an universal context is unambiguous if
 273    --  there is only one applicable fixed point type. Determining whether there
 274    --  is only one requires a search over all visible entities, and happens
 275    --  only in very pathological cases (see 6115-006).
 276
 277    -------------------------
 278    -- Ambiguous_Character --
 279    -------------------------
 280
 281    procedure Ambiguous_Character (C : Node_Id) is
 282       E : Entity_Id;
 283
 284    begin
 285       if Nkind (C) = N_Character_Literal then
 286          Error_Msg_N ("ambiguous character literal", C);
 287
 288          --  First the ones in Standard
 289
 290          Error_Msg_N ("\\possible interpretation: Character!", C);
 291          Error_Msg_N ("\\possible interpretation: Wide_Character!", C);
 292
 293          --  Include Wide_Wide_Character in Ada 2005 mode
 294
 295          if Ada_Version >= Ada_2005 then
 296             Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C);
 297          end if;
 298
 299          --  Now any other types that match
 300
 301          E := Current_Entity (C);
 302          while Present (E) loop
 303             Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E));
 304             E := Homonym (E);
 305          end loop;
 306       end if;
 307    end Ambiguous_Character;
 308
 309    -------------------------
 310    -- Analyze_And_Resolve --
 311    -------------------------
 312
 313    procedure Analyze_And_Resolve (N : Node_Id) is
 314    begin
 315       Analyze (N);
 316       Resolve (N);
 317    end Analyze_And_Resolve;
 318
 319    procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
 320    begin
 321       Analyze (N);
 322       Resolve (N, Typ);
 323    end Analyze_And_Resolve;
 324
 325    --  Versions with check(s) suppressed
 326
 327    procedure Analyze_And_Resolve
 328      (N        : Node_Id;
 329       Typ      : Entity_Id;
 330       Suppress : Check_Id)
 331    is
 332       Scop : constant Entity_Id := Current_Scope;
 333
 334    begin
 335       if Suppress = All_Checks then
 336          declare
 337             Sva : constant Suppress_Array := Scope_Suppress.Suppress;
 338          begin
 339             Scope_Suppress.Suppress := (others => True);
 340             Analyze_And_Resolve (N, Typ);
 341             Scope_Suppress.Suppress := Sva;
 342          end;
 343
 344       else
 345          declare
 346             Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
 347          begin
 348             Scope_Suppress.Suppress (Suppress) := True;
 349             Analyze_And_Resolve (N, Typ);
 350             Scope_Suppress.Suppress (Suppress) := Svg;
 351          end;
 352       end if;
 353
 354       if Current_Scope /= Scop
 355         and then Scope_Is_Transient
 356       then
 357          --  This can only happen if a transient scope was created for an inner
 358          --  expression, which will be removed upon completion of the analysis
 359          --  of an enclosing construct. The transient scope must have the
 360          --  suppress status of the enclosing environment, not of this Analyze
 361          --  call.
 362
 363          Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
 364            Scope_Suppress;
 365       end if;
 366    end Analyze_And_Resolve;
 367
 368    procedure Analyze_And_Resolve
 369      (N        : Node_Id;
 370       Suppress : Check_Id)
 371    is
 372       Scop : constant Entity_Id := Current_Scope;
 373
 374    begin
 375       if Suppress = All_Checks then
 376          declare
 377             Sva : constant Suppress_Array := Scope_Suppress.Suppress;
 378          begin
 379             Scope_Suppress.Suppress := (others => True);
 380             Analyze_And_Resolve (N);
 381             Scope_Suppress.Suppress := Sva;
 382          end;
 383
 384       else
 385          declare
 386             Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
 387          begin
 388             Scope_Suppress.Suppress (Suppress) := True;
 389             Analyze_And_Resolve (N);
 390             Scope_Suppress.Suppress (Suppress) := Svg;
 391          end;
 392       end if;
 393
 394       if Current_Scope /= Scop and then Scope_Is_Transient then
 395          Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
 396            Scope_Suppress;
 397       end if;
 398    end Analyze_And_Resolve;
 399
 400    ----------------------------
 401    -- Check_Discriminant_Use --
 402    ----------------------------
 403
 404    procedure Check_Discriminant_Use (N : Node_Id) is
 405       PN   : constant Node_Id   := Parent (N);
 406       Disc : constant Entity_Id := Entity (N);
 407       P    : Node_Id;
 408       D    : Node_Id;
 409
 410    begin
 411       --  Any use in a spec-expression is legal
 412
 413       if In_Spec_Expression then
 414          null;
 415
 416       elsif Nkind (PN) = N_Range then
 417
 418          --  Discriminant cannot be used to constrain a scalar type
 419
 420          P := Parent (PN);
 421
 422          if Nkind (P) = N_Range_Constraint
 423            and then Nkind (Parent (P)) = N_Subtype_Indication
 424            and then Nkind (Parent (Parent (P))) = N_Component_Definition
 425          then
 426             Error_Msg_N ("discriminant cannot constrain scalar type", N);
 427
 428          elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then
 429
 430             --  The following check catches the unusual case where a
 431             --  discriminant appears within an index constraint that is part
 432             --  of a larger expression within a constraint on a component,
 433             --  e.g. "C : Int range 1 .. F (new A(1 .. D))". For now we only
 434             --  check case of record components, and note that a similar check
 435             --  should also apply in the case of discriminant constraints
 436             --  below. ???
 437
 438             --  Note that the check for N_Subtype_Declaration below is to
 439             --  detect the valid use of discriminants in the constraints of a
 440             --  subtype declaration when this subtype declaration appears
 441             --  inside the scope of a record type (which is syntactically
 442             --  illegal, but which may be created as part of derived type
 443             --  processing for records). See Sem_Ch3.Build_Derived_Record_Type
 444             --  for more info.
 445
 446             if Ekind (Current_Scope) = E_Record_Type
 447               and then Scope (Disc) = Current_Scope
 448               and then not
 449                 (Nkind (Parent (P)) = N_Subtype_Indication
 450                   and then
 451                     Nkind_In (Parent (Parent (P)), N_Component_Definition,
 452                                                    N_Subtype_Declaration)
 453                   and then Paren_Count (N) = 0)
 454             then
 455                Error_Msg_N
 456                  ("discriminant must appear alone in component constraint", N);
 457                return;
 458             end if;
 459
 460             --   Detect a common error:
 461
 462             --   type R (D : Positive := 100) is record
 463             --     Name : String (1 .. D);
 464             --   end record;
 465
 466             --  The default value causes an object of type R to be allocated
 467             --  with room for Positive'Last characters. The RM does not mandate
 468             --  the allocation of the maximum size, but that is what GNAT does
 469             --  so we should warn the programmer that there is a problem.
 470
 471             Check_Large : declare
 472                SI : Node_Id;
 473                T  : Entity_Id;
 474                TB : Node_Id;
 475                CB : Entity_Id;
 476
 477                function Large_Storage_Type (T : Entity_Id) return Boolean;
 478                --  Return True if type T has a large enough range that any
 479                --  array whose index type covered the whole range of the type
 480                --  would likely raise Storage_Error.
 481
 482                ------------------------
 483                -- Large_Storage_Type --
 484                ------------------------
 485
 486                function Large_Storage_Type (T : Entity_Id) return Boolean is
 487                begin
 488                   --  The type is considered large if its bounds are known at
 489                   --  compile time and if it requires at least as many bits as
 490                   --  a Positive to store the possible values.
 491
 492                   return Compile_Time_Known_Value (Type_Low_Bound (T))
 493                     and then Compile_Time_Known_Value (Type_High_Bound (T))
 494                     and then
 495                       Minimum_Size (T, Biased => True) >=
 496                         RM_Size (Standard_Positive);
 497                end Large_Storage_Type;
 498
 499             --  Start of processing for Check_Large
 500
 501             begin
 502                --  Check that the Disc has a large range
 503
 504                if not Large_Storage_Type (Etype (Disc)) then
 505                   goto No_Danger;
 506                end if;
 507
 508                --  If the enclosing type is limited, we allocate only the
 509                --  default value, not the maximum, and there is no need for
 510                --  a warning.
 511
 512                if Is_Limited_Type (Scope (Disc)) then
 513                   goto No_Danger;
 514                end if;
 515
 516                --  Check that it is the high bound
 517
 518                if N /= High_Bound (PN)
 519                  or else No (Discriminant_Default_Value (Disc))
 520                then
 521                   goto No_Danger;
 522                end if;
 523
 524                --  Check the array allows a large range at this bound. First
 525                --  find the array
 526
 527                SI := Parent (P);
 528
 529                if Nkind (SI) /= N_Subtype_Indication then
 530                   goto No_Danger;
 531                end if;
 532
 533                T := Entity (Subtype_Mark (SI));
 534
 535                if not Is_Array_Type (T) then
 536                   goto No_Danger;
 537                end if;
 538
 539                --  Next, find the dimension
 540
 541                TB := First_Index (T);
 542                CB := First (Constraints (P));
 543                while True
 544                  and then Present (TB)
 545                  and then Present (CB)
 546                  and then CB /= PN
 547                loop
 548                   Next_Index (TB);
 549                   Next (CB);
 550                end loop;
 551
 552                if CB /= PN then
 553                   goto No_Danger;
 554                end if;
 555
 556                --  Now, check the dimension has a large range
 557
 558                if not Large_Storage_Type (Etype (TB)) then
 559                   goto No_Danger;
 560                end if;
 561
 562                --  Warn about the danger
 563
 564                Error_Msg_N
 565                  ("??creation of & object may raise Storage_Error!",
 566                   Scope (Disc));
 567
 568                <<No_Danger>>
 569                   null;
 570
 571             end Check_Large;
 572          end if;
 573
 574       --  Legal case is in index or discriminant constraint
 575
 576       elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,
 577                           N_Discriminant_Association)
 578       then
 579          if Paren_Count (N) > 0 then
 580             Error_Msg_N
 581               ("discriminant in constraint must appear alone",  N);
 582
 583          elsif Nkind (N) = N_Expanded_Name
 584            and then Comes_From_Source (N)
 585          then
 586             Error_Msg_N
 587               ("discriminant must appear alone as a direct name", N);
 588          end if;
 589
 590          return;
 591
 592       --  Otherwise, context is an expression. It should not be within (i.e. a
 593       --  subexpression of) a constraint for a component.
 594
 595       else
 596          D := PN;
 597          P := Parent (PN);
 598          while not Nkind_In (P, N_Component_Declaration,
 599                                 N_Subtype_Indication,
 600                                 N_Entry_Declaration)
 601          loop
 602             D := P;
 603             P := Parent (P);
 604             exit when No (P);
 605          end loop;
 606
 607          --  If the discriminant is used in an expression that is a bound of a
 608          --  scalar type, an Itype is created and the bounds are attached to
 609          --  its range, not to the original subtype indication. Such use is of
 610          --  course a double fault.
 611
 612          if (Nkind (P) = N_Subtype_Indication
 613               and then Nkind_In (Parent (P), N_Component_Definition,
 614                                              N_Derived_Type_Definition)
 615               and then D = Constraint (P))
 616
 617            --  The constraint itself may be given by a subtype indication,
 618            --  rather than by a more common discrete range.
 619
 620            or else (Nkind (P) = N_Subtype_Indication
 621                       and then
 622                     Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
 623            or else Nkind (P) = N_Entry_Declaration
 624            or else Nkind (D) = N_Defining_Identifier
 625          then
 626             Error_Msg_N
 627               ("discriminant in constraint must appear alone",  N);
 628          end if;
 629       end if;
 630    end Check_Discriminant_Use;
 631
 632    --------------------------------
 633    -- Check_For_Visible_Operator --
 634    --------------------------------
 635
 636    procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
 637    begin
 638       if Is_Invisible_Operator (N, T) then
 639          Error_Msg_NE -- CODEFIX
 640            ("operator for} is not directly visible!", N, First_Subtype (T));
 641          Error_Msg_N -- CODEFIX
 642            ("use clause would make operation legal!", N);
 643       end if;
 644    end Check_For_Visible_Operator;
 645
 646    ----------------------------------
 647    --  Check_Fully_Declared_Prefix --
 648    ----------------------------------
 649
 650    procedure Check_Fully_Declared_Prefix
 651      (Typ  : Entity_Id;
 652       Pref : Node_Id)
 653    is
 654    begin
 655       --  Check that the designated type of the prefix of a dereference is
 656       --  not an incomplete type. This cannot be done unconditionally, because
 657       --  dereferences of private types are legal in default expressions. This
 658       --  case is taken care of in Check_Fully_Declared, called below. There
 659       --  are also 2005 cases where it is legal for the prefix to be unfrozen.
 660
 661       --  This consideration also applies to similar checks for allocators,
 662       --  qualified expressions, and type conversions.
 663
 664       --  An additional exception concerns other per-object expressions that
 665       --  are not directly related to component declarations, in particular
 666       --  representation pragmas for tasks. These will be per-object
 667       --  expressions if they depend on discriminants or some global entity.
 668       --  If the task has access discriminants, the designated type may be
 669       --  incomplete at the point the expression is resolved. This resolution
 670       --  takes place within the body of the initialization procedure, where
 671       --  the discriminant is replaced by its discriminal.
 672
 673       if Is_Entity_Name (Pref)
 674         and then Ekind (Entity (Pref)) = E_In_Parameter
 675       then
 676          null;
 677
 678       --  Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
 679       --  are handled by Analyze_Access_Attribute, Analyze_Assignment,
 680       --  Analyze_Object_Renaming, and Freeze_Entity.
 681
 682       elsif Ada_Version >= Ada_2005
 683         and then Is_Entity_Name (Pref)
 684         and then Is_Access_Type (Etype (Pref))
 685         and then Ekind (Directly_Designated_Type (Etype (Pref))) =
 686                                                        E_Incomplete_Type
 687         and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref)))
 688       then
 689          null;
 690       else
 691          Check_Fully_Declared (Typ, Parent (Pref));
 692       end if;
 693    end Check_Fully_Declared_Prefix;
 694
 695    ------------------------------
 696    -- Check_Infinite_Recursion --
 697    ------------------------------
 698
 699    function Check_Infinite_Recursion (N : Node_Id) return Boolean is
 700       P : Node_Id;
 701       C : Node_Id;
 702
 703       function Same_Argument_List return Boolean;
 704       --  Check whether list of actuals is identical to list of formals of
 705       --  called function (which is also the enclosing scope).
 706
 707       ------------------------
 708       -- Same_Argument_List --
 709       ------------------------
 710
 711       function Same_Argument_List return Boolean is
 712          A    : Node_Id;
 713          F    : Entity_Id;
 714          Subp : Entity_Id;
 715
 716       begin
 717          if not Is_Entity_Name (Name (N)) then
 718             return False;
 719          else
 720             Subp := Entity (Name (N));
 721          end if;
 722
 723          F := First_Formal (Subp);
 724          A := First_Actual (N);
 725          while Present (F) and then Present (A) loop
 726             if not Is_Entity_Name (A) or else Entity (A) /= F then
 727                return False;
 728             end if;
 729
 730             Next_Actual (A);
 731             Next_Formal (F);
 732          end loop;
 733
 734          return True;
 735       end Same_Argument_List;
 736
 737    --  Start of processing for Check_Infinite_Recursion
 738
 739    begin
 740       --  Special case, if this is a procedure call and is a call to the
 741       --  current procedure with the same argument list, then this is for
 742       --  sure an infinite recursion and we insert a call to raise SE.
 743
 744       if Is_List_Member (N)
 745         and then List_Length (List_Containing (N)) = 1
 746         and then Same_Argument_List
 747       then
 748          declare
 749             P : constant Node_Id := Parent (N);
 750          begin
 751             if Nkind (P) = N_Handled_Sequence_Of_Statements
 752               and then Nkind (Parent (P)) = N_Subprogram_Body
 753               and then Is_Empty_List (Declarations (Parent (P)))
 754             then
 755                Error_Msg_Warn := SPARK_Mode /= On;
 756                Error_Msg_N ("!infinite recursion<<", N);
 757                Error_Msg_N ("\!Storage_Error [<<", N);
 758                Insert_Action (N,
 759                  Make_Raise_Storage_Error (Sloc (N),
 760                    Reason => SE_Infinite_Recursion));
 761                return True;
 762             end if;
 763          end;
 764       end if;
 765
 766       --  If not that special case, search up tree, quitting if we reach a
 767       --  construct (e.g. a conditional) that tells us that this is not a
 768       --  case for an infinite recursion warning.
 769
 770       C := N;
 771       loop
 772          P := Parent (C);
 773
 774          --  If no parent, then we were not inside a subprogram, this can for
 775          --  example happen when processing certain pragmas in a spec. Just
 776          --  return False in this case.
 777
 778          if No (P) then
 779             return False;
 780          end if;
 781
 782          --  Done if we get to subprogram body, this is definitely an infinite
 783          --  recursion case if we did not find anything to stop us.
 784
 785          exit when Nkind (P) = N_Subprogram_Body;
 786
 787          --  If appearing in conditional, result is false
 788
 789          if Nkind_In (P, N_Or_Else,
 790                          N_And_Then,
 791                          N_Case_Expression,
 792                          N_Case_Statement,
 793                          N_If_Expression,
 794                          N_If_Statement)
 795          then
 796             return False;
 797
 798          elsif Nkind (P) = N_Handled_Sequence_Of_Statements
 799            and then C /= First (Statements (P))
 800          then
 801             --  If the call is the expression of a return statement and the
 802             --  actuals are identical to the formals, it's worth a warning.
 803             --  However, we skip this if there is an immediately preceding
 804             --  raise statement, since the call is never executed.
 805
 806             --  Furthermore, this corresponds to a common idiom:
 807
 808             --    function F (L : Thing) return Boolean is
 809             --    begin
 810             --       raise Program_Error;
 811             --       return F (L);
 812             --    end F;
 813
 814             --  for generating a stub function
 815
 816             if Nkind (Parent (N)) = N_Simple_Return_Statement
 817               and then Same_Argument_List
 818             then
 819                exit when not Is_List_Member (Parent (N));
 820
 821                --  OK, return statement is in a statement list, look for raise
 822
 823                declare
 824                   Nod : Node_Id;
 825
 826                begin
 827                   --  Skip past N_Freeze_Entity nodes generated by expansion
 828
 829                   Nod := Prev (Parent (N));
 830                   while Present (Nod)
 831                     and then Nkind (Nod) = N_Freeze_Entity
 832                   loop
 833                      Prev (Nod);
 834                   end loop;
 835
 836                   --  If no raise statement, give warning. We look at the
 837                   --  original node, because in the case of "raise ... with
 838                   --  ...", the node has been transformed into a call.
 839
 840                   exit when Nkind (Original_Node (Nod)) /= N_Raise_Statement
 841                     and then
 842                       (Nkind (Nod) not in N_Raise_xxx_Error
 843                         or else Present (Condition (Nod)));
 844                end;
 845             end if;
 846
 847             return False;
 848
 849          else
 850             C := P;
 851          end if;
 852       end loop;
 853
 854       Error_Msg_Warn := SPARK_Mode /= On;
 855       Error_Msg_N ("!possible infinite recursion<<", N);
 856       Error_Msg_N ("\!??Storage_Error ]<<", N);
 857
 858       return True;
 859    end Check_Infinite_Recursion;
 860
 861    -------------------------------
 862    -- Check_Initialization_Call --
 863    -------------------------------
 864
 865    procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
 866       Typ : constant Entity_Id := Etype (First_Formal (Nam));
 867
 868       function Uses_SS (T : Entity_Id) return Boolean;
 869       --  Check whether the creation of an object of the type will involve
 870       --  use of the secondary stack. If T is a record type, this is true
 871       --  if the expression for some component uses the secondary stack, e.g.
 872       --  through a call to a function that returns an unconstrained value.
 873       --  False if T is controlled, because cleanups occur elsewhere.
 874
 875       -------------
 876       -- Uses_SS --
 877       -------------
 878
 879       function Uses_SS (T : Entity_Id) return Boolean is
 880          Comp      : Entity_Id;
 881          Expr      : Node_Id;
 882          Full_Type : Entity_Id := Underlying_Type (T);
 883
 884       begin
 885          --  Normally we want to use the underlying type, but if it's not set
 886          --  then continue with T.
 887
 888          if not Present (Full_Type) then
 889             Full_Type := T;
 890          end if;
 891
 892          if Is_Controlled (Full_Type) then
 893             return False;
 894
 895          elsif Is_Array_Type (Full_Type) then
 896             return Uses_SS (Component_Type (Full_Type));
 897
 898          elsif Is_Record_Type (Full_Type) then
 899             Comp := First_Component (Full_Type);
 900             while Present (Comp) loop
 901                if Ekind (Comp) = E_Component
 902                  and then Nkind (Parent (Comp)) = N_Component_Declaration
 903                then
 904                   --  The expression for a dynamic component may be rewritten
 905                   --  as a dereference, so retrieve original node.
 906
 907                   Expr := Original_Node (Expression (Parent (Comp)));
 908
 909                   --  Return True if the expression is a call to a function
 910                   --  (including an attribute function such as Image, or a
 911                   --  user-defined operator) with a result that requires a
 912                   --  transient scope.
 913
 914                   if (Nkind (Expr) = N_Function_Call
 915                        or else Nkind (Expr) in N_Op
 916                        or else (Nkind (Expr) = N_Attribute_Reference
 917                                  and then Present (Expressions (Expr))))
 918                     and then Requires_Transient_Scope (Etype (Expr))
 919                   then
 920                      return True;
 921
 922                   elsif Uses_SS (Etype (Comp)) then
 923                      return True;
 924                   end if;
 925                end if;
 926
 927                Next_Component (Comp);
 928             end loop;
 929
 930             return False;
 931
 932          else
 933             return False;
 934          end if;
 935       end Uses_SS;
 936
 937    --  Start of processing for Check_Initialization_Call
 938
 939    begin
 940       --  Establish a transient scope if the type needs it
 941
 942       if Uses_SS (Typ) then
 943          Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
 944       end if;
 945    end Check_Initialization_Call;
 946
 947    ---------------------------------------
 948    -- Check_No_Direct_Boolean_Operators --
 949    ---------------------------------------
 950
 951    procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is
 952    begin
 953       if Scope (Entity (N)) = Standard_Standard
 954         and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
 955       then
 956          --  Restriction only applies to original source code
 957
 958          if Comes_From_Source (N) then
 959             Check_Restriction (No_Direct_Boolean_Operators, N);
 960          end if;
 961       end if;
 962
 963       --  Do style check (but skip if in instance, error is on template)
 964
 965       if Style_Check then
 966          if not In_Instance then
 967             Check_Boolean_Operator (N);
 968          end if;
 969       end if;
 970    end Check_No_Direct_Boolean_Operators;
 971
 972    ------------------------------
 973    -- Check_Parameterless_Call --
 974    ------------------------------
 975
 976    procedure Check_Parameterless_Call (N : Node_Id) is
 977       Nam : Node_Id;
 978
 979       function Prefix_Is_Access_Subp return Boolean;
 980       --  If the prefix is of an access_to_subprogram type, the node must be
 981       --  rewritten as a call. Ditto if the prefix is overloaded and all its
 982       --  interpretations are access to subprograms.
 983
 984       ---------------------------
 985       -- Prefix_Is_Access_Subp --
 986       ---------------------------
 987
 988       function Prefix_Is_Access_Subp return Boolean is
 989          I   : Interp_Index;
 990          It  : Interp;
 991
 992       begin
 993          --  If the context is an attribute reference that can apply to
 994          --  functions, this is never a parameterless call (RM 4.1.4(6)).
 995
 996          if Nkind (Parent (N)) = N_Attribute_Reference
 997             and then Nam_In (Attribute_Name (Parent (N)), Name_Address,
 998                                                           Name_Code_Address,
 999                                                           Name_Access)
1000          then
1001             return False;
1002          end if;
1003
1004          if not Is_Overloaded (N) then
1005             return
1006               Ekind (Etype (N)) = E_Subprogram_Type
1007                 and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type;
1008          else
1009             Get_First_Interp (N, I, It);
1010             while Present (It.Typ) loop
1011                if Ekind (It.Typ) /= E_Subprogram_Type
1012                  or else Base_Type (Etype (It.Typ)) = Standard_Void_Type
1013                then
1014                   return False;
1015                end if;
1016
1017                Get_Next_Interp (I, It);
1018             end loop;
1019
1020             return True;
1021          end if;
1022       end Prefix_Is_Access_Subp;
1023
1024    --  Start of processing for Check_Parameterless_Call
1025
1026    begin
1027       --  Defend against junk stuff if errors already detected
1028
1029       if Total_Errors_Detected /= 0 then
1030          if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
1031             return;
1032          elsif Nkind (N) in N_Has_Chars
1033            and then Chars (N) in Error_Name_Or_No_Name
1034          then
1035             return;
1036          end if;
1037
1038          Require_Entity (N);
1039       end if;
1040
1041       --  If the context expects a value, and the name is a procedure, this is
1042       --  most likely a missing 'Access. Don't try to resolve the parameterless
1043       --  call, error will be caught when the outer call is analyzed.
1044
1045       if Is_Entity_Name (N)
1046         and then Ekind (Entity (N)) = E_Procedure
1047         and then not Is_Overloaded (N)
1048         and then
1049          Nkind_In (Parent (N), N_Parameter_Association,
1050                                N_Function_Call,
1051                                N_Procedure_Call_Statement)
1052       then
1053          return;
1054       end if;
1055
1056       --  Rewrite as call if overloadable entity that is (or could be, in the
1057       --  overloaded case) a function call. If we know for sure that the entity
1058       --  is an enumeration literal, we do not rewrite it.
1059
1060       --  If the entity is the name of an operator, it cannot be a call because
1061       --  operators cannot have default parameters. In this case, this must be
1062       --  a string whose contents coincide with an operator name. Set the kind
1063       --  of the node appropriately.
1064
1065       if (Is_Entity_Name (N)
1066             and then Nkind (N) /= N_Operator_Symbol
1067             and then Is_Overloadable (Entity (N))
1068             and then (Ekind (Entity (N)) /= E_Enumeration_Literal
1069                        or else Is_Overloaded (N)))
1070
1071       --  Rewrite as call if it is an explicit dereference of an expression of
1072       --  a subprogram access type, and the subprogram type is not that of a
1073       --  procedure or entry.
1074
1075       or else
1076         (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp)
1077
1078       --  Rewrite as call if it is a selected component which is a function,
1079       --  this is the case of a call to a protected function (which may be
1080       --  overloaded with other protected operations).
1081
1082       or else
1083         (Nkind (N) = N_Selected_Component
1084           and then (Ekind (Entity (Selector_Name (N))) = E_Function
1085                      or else
1086                        (Ekind_In (Entity (Selector_Name (N)), E_Entry,
1087                                                               E_Procedure)
1088                          and then Is_Overloaded (Selector_Name (N)))))
1089
1090       --  If one of the above three conditions is met, rewrite as call. Apply
1091       --  the rewriting only once.
1092
1093       then
1094          if Nkind (Parent (N)) /= N_Function_Call
1095            or else N /= Name (Parent (N))
1096          then
1097
1098             --  This may be a prefixed call that was not fully analyzed, e.g.
1099             --  an actual in an instance.
1100
1101             if Ada_Version >= Ada_2005
1102               and then Nkind (N) = N_Selected_Component
1103               and then Is_Dispatching_Operation (Entity (Selector_Name (N)))
1104             then
1105                Analyze_Selected_Component (N);
1106
1107                if Nkind (N) /= N_Selected_Component then
1108                   return;
1109                end if;
1110             end if;
1111
1112             --  The node is the name of the parameterless call. Preserve its
1113             --  descendants, which may be complex expressions.
1114
1115             Nam := Relocate_Node (N);
1116
1117             --  If overloaded, overload set belongs to new copy
1118
1119             Save_Interps (N, Nam);
1120
1121             --  Change node to parameterless function call (note that the
1122             --  Parameter_Associations associations field is left set to Empty,
1123             --  its normal default value since there are no parameters)
1124
1125             Change_Node (N, N_Function_Call);
1126             Set_Name (N, Nam);
1127             Set_Sloc (N, Sloc (Nam));
1128             Analyze_Call (N);
1129          end if;
1130
1131       elsif Nkind (N) = N_Parameter_Association then
1132          Check_Parameterless_Call (Explicit_Actual_Parameter (N));
1133
1134       elsif Nkind (N) = N_Operator_Symbol then
1135          Change_Operator_Symbol_To_String_Literal (N);
1136          Set_Is_Overloaded (N, False);
1137          Set_Etype (N, Any_String);
1138       end if;
1139    end Check_Parameterless_Call;
1140
1141    --------------------------------
1142    -- Is_Atomic_Ref_With_Address --
1143    --------------------------------
1144
1145    function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean is
1146       Pref : constant Node_Id := Prefix (N);
1147
1148    begin
1149       if not Is_Entity_Name (Pref) then
1150          return False;
1151
1152       else
1153          declare
1154             Pent : constant Entity_Id := Entity (Pref);
1155             Ptyp : constant Entity_Id := Etype (Pent);
1156          begin
1157             return not Is_Access_Type (Ptyp)
1158               and then (Is_Atomic (Ptyp) or else Is_Atomic (Pent))
1159               and then Present (Address_Clause (Pent));
1160          end;
1161       end if;
1162    end Is_Atomic_Ref_With_Address;
1163
1164    -----------------------------
1165    -- Is_Definite_Access_Type --
1166    -----------------------------
1167
1168    function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
1169       Btyp : constant Entity_Id := Base_Type (E);
1170    begin
1171       return Ekind (Btyp) = E_Access_Type
1172         or else (Ekind (Btyp) = E_Access_Subprogram_Type
1173                   and then Comes_From_Source (Btyp));
1174    end Is_Definite_Access_Type;
1175
1176    ----------------------
1177    -- Is_Predefined_Op --
1178    ----------------------
1179
1180    function Is_Predefined_Op (Nam : Entity_Id) return Boolean is
1181    begin
1182       --  Predefined operators are intrinsic subprograms
1183
1184       if not Is_Intrinsic_Subprogram (Nam) then
1185          return False;
1186       end if;
1187
1188       --  A call to a back-end builtin is never a predefined operator
1189
1190       if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then
1191          return False;
1192       end if;
1193
1194       return not Is_Generic_Instance (Nam)
1195         and then Chars (Nam) in Any_Operator_Name
1196         and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam)));
1197    end Is_Predefined_Op;
1198
1199    -----------------------------
1200    -- Make_Call_Into_Operator --
1201    -----------------------------
1202
1203    procedure Make_Call_Into_Operator
1204      (N     : Node_Id;
1205       Typ   : Entity_Id;
1206       Op_Id : Entity_Id)
1207    is
1208       Op_Name   : constant Name_Id := Chars (Op_Id);
1209       Act1      : Node_Id := First_Actual (N);
1210       Act2      : Node_Id := Next_Actual (Act1);
1211       Error     : Boolean := False;
1212       Func      : constant Entity_Id := Entity (Name (N));
1213       Is_Binary : constant Boolean   := Present (Act2);
1214       Op_Node   : Node_Id;
1215       Opnd_Type : Entity_Id;
1216       Orig_Type : Entity_Id := Empty;
1217       Pack      : Entity_Id;
1218
1219       type Kind_Test is access function (E : Entity_Id) return Boolean;
1220
1221       function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
1222       --  If the operand is not universal, and the operator is given by an
1223       --  expanded name, verify that the operand has an interpretation with a
1224       --  type defined in the given scope of the operator.
1225
1226       function Type_In_P (Test : Kind_Test) return Entity_Id;
1227       --  Find a type of the given class in package Pack that contains the
1228       --  operator.
1229
1230       ---------------------------
1231       -- Operand_Type_In_Scope --
1232       ---------------------------
1233
1234       function Operand_Type_In_Scope (S : Entity_Id) return Boolean is
1235          Nod : constant Node_Id := Right_Opnd (Op_Node);
1236          I   : Interp_Index;
1237          It  : Interp;
1238
1239       begin
1240          if not Is_Overloaded (Nod) then
1241             return Scope (Base_Type (Etype (Nod))) = S;
1242
1243          else
1244             Get_First_Interp (Nod, I, It);
1245             while Present (It.Typ) loop
1246                if Scope (Base_Type (It.Typ)) = S then
1247                   return True;
1248                end if;
1249
1250                Get_Next_Interp (I, It);
1251             end loop;
1252
1253             return False;
1254          end if;
1255       end Operand_Type_In_Scope;
1256
1257       ---------------
1258       -- Type_In_P --
1259       ---------------
1260
1261       function Type_In_P (Test : Kind_Test) return Entity_Id is
1262          E : Entity_Id;
1263
1264          function In_Decl return Boolean;
1265          --  Verify that node is not part of the type declaration for the
1266          --  candidate type, which would otherwise be invisible.
1267
1268          -------------
1269          -- In_Decl --
1270          -------------
1271
1272          function In_Decl return Boolean is
1273             Decl_Node : constant Node_Id := Parent (E);
1274             N2        : Node_Id;
1275
1276          begin
1277             N2 := N;
1278
1279             if Etype (E) = Any_Type then
1280                return True;
1281
1282             elsif No (Decl_Node) then
1283                return False;
1284
1285             else
1286                while Present (N2)
1287                  and then Nkind (N2) /= N_Compilation_Unit
1288                loop
1289                   if N2 = Decl_Node then
1290                      return True;
1291                   else
1292                      N2 := Parent (N2);
1293                   end if;
1294                end loop;
1295
1296                return False;
1297             end if;
1298          end In_Decl;
1299
1300       --  Start of processing for Type_In_P
1301
1302       begin
1303          --  If the context type is declared in the prefix package, this is the
1304          --  desired base type.
1305
1306          if Scope (Base_Type (Typ)) = Pack and then Test (Typ) then
1307             return Base_Type (Typ);
1308
1309          else
1310             E := First_Entity (Pack);
1311             while Present (E) loop
1312                if Test (E) and then not In_Decl then
1313                   return E;
1314                end if;
1315
1316                Next_Entity (E);
1317             end loop;
1318
1319             return Empty;
1320          end if;
1321       end Type_In_P;
1322
1323    --  Start of processing for Make_Call_Into_Operator
1324
1325    begin
1326       Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
1327
1328       --  Binary operator
1329
1330       if Is_Binary then
1331          Set_Left_Opnd  (Op_Node, Relocate_Node (Act1));
1332          Set_Right_Opnd (Op_Node, Relocate_Node (Act2));
1333          Save_Interps (Act1, Left_Opnd  (Op_Node));
1334          Save_Interps (Act2, Right_Opnd (Op_Node));
1335          Act1 := Left_Opnd (Op_Node);
1336          Act2 := Right_Opnd (Op_Node);
1337
1338       --  Unary operator
1339
1340       else
1341          Set_Right_Opnd (Op_Node, Relocate_Node (Act1));
1342          Save_Interps (Act1, Right_Opnd (Op_Node));
1343          Act1 := Right_Opnd (Op_Node);
1344       end if;
1345
1346       --  If the operator is denoted by an expanded name, and the prefix is
1347       --  not Standard, but the operator is a predefined one whose scope is
1348       --  Standard, then this is an implicit_operator, inserted as an
1349       --  interpretation by the procedure of the same name. This procedure
1350       --  overestimates the presence of implicit operators, because it does
1351       --  not examine the type of the operands. Verify now that the operand
1352       --  type appears in the given scope. If right operand is universal,
1353       --  check the other operand. In the case of concatenation, either
1354       --  argument can be the component type, so check the type of the result.
1355       --  If both arguments are literals, look for a type of the right kind
1356       --  defined in the given scope. This elaborate nonsense is brought to
1357       --  you courtesy of b33302a. The type itself must be frozen, so we must
1358       --  find the type of the proper class in the given scope.
1359
1360       --  A final wrinkle is the multiplication operator for fixed point types,
1361       --  which is defined in Standard only, and not in the scope of the
1362       --  fixed point type itself.
1363
1364       if Nkind (Name (N)) = N_Expanded_Name then
1365          Pack := Entity (Prefix (Name (N)));
1366
1367          --  If this is a package renaming, get renamed entity, which will be
1368          --  the scope of the operands if operaton is type-correct.
1369
1370          if Present (Renamed_Entity (Pack)) then
1371             Pack := Renamed_Entity (Pack);
1372          end if;
1373
1374          --  If the entity being called is defined in the given package, it is
1375          --  a renaming of a predefined operator, and known to be legal.
1376
1377          if Scope (Entity (Name (N))) = Pack
1378             and then Pack /= Standard_Standard
1379          then
1380             null;
1381
1382          --  Visibility does not need to be checked in an instance: if the
1383          --  operator was not visible in the generic it has been diagnosed
1384          --  already, else there is an implicit copy of it in the instance.
1385
1386          elsif In_Instance then
1387             null;
1388
1389          elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide)
1390            and then Is_Fixed_Point_Type (Etype (Left_Opnd  (Op_Node)))
1391            and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
1392          then
1393             if Pack /= Standard_Standard then
1394                Error := True;
1395             end if;
1396
1397          --  Ada 2005 AI-420: Predefined equality on Universal_Access is
1398          --  available.
1399
1400          elsif Ada_Version >= Ada_2005
1401            and then Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne)
1402            and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
1403          then
1404             null;
1405
1406          else
1407             Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
1408
1409             if Op_Name = Name_Op_Concat then
1410                Opnd_Type := Base_Type (Typ);
1411
1412             elsif (Scope (Opnd_Type) = Standard_Standard
1413                      and then Is_Binary)
1414               or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference
1415                         and then Is_Binary
1416                         and then not Comes_From_Source (Opnd_Type))
1417             then
1418                Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node)));
1419             end if;
1420
1421             if Scope (Opnd_Type) = Standard_Standard then
1422
1423                --  Verify that the scope contains a type that corresponds to
1424                --  the given literal. Optimize the case where Pack is Standard.
1425
1426                if Pack /= Standard_Standard then
1427
1428                   if Opnd_Type = Universal_Integer then
1429                      Orig_Type := Type_In_P (Is_Integer_Type'Access);
1430
1431                   elsif Opnd_Type = Universal_Real then
1432                      Orig_Type := Type_In_P (Is_Real_Type'Access);
1433
1434                   elsif Opnd_Type = Any_String then
1435                      Orig_Type := Type_In_P (Is_String_Type'Access);
1436
1437                   elsif Opnd_Type = Any_Access then
1438                      Orig_Type := Type_In_P (Is_Definite_Access_Type'Access);
1439
1440                   elsif Opnd_Type = Any_Composite then
1441                      Orig_Type := Type_In_P (Is_Composite_Type'Access);
1442
1443                      if Present (Orig_Type) then
1444                         if Has_Private_Component (Orig_Type) then
1445                            Orig_Type := Empty;
1446                         else
1447                            Set_Etype (Act1, Orig_Type);
1448
1449                            if Is_Binary then
1450                               Set_Etype (Act2, Orig_Type);
1451                            end if;
1452                         end if;
1453                      end if;
1454
1455                   else
1456                      Orig_Type := Empty;
1457                   end if;
1458
1459                   Error := No (Orig_Type);
1460                end if;
1461
1462             elsif Ekind (Opnd_Type) = E_Allocator_Type
1463                and then No (Type_In_P (Is_Definite_Access_Type'Access))
1464             then
1465                Error := True;
1466
1467             --  If the type is defined elsewhere, and the operator is not
1468             --  defined in the given scope (by a renaming declaration, e.g.)
1469             --  then this is an error as well. If an extension of System is
1470             --  present, and the type may be defined there, Pack must be
1471             --  System itself.
1472
1473             elsif Scope (Opnd_Type) /= Pack
1474               and then Scope (Op_Id) /= Pack
1475               and then (No (System_Aux_Id)
1476                          or else Scope (Opnd_Type) /= System_Aux_Id
1477                          or else Pack /= Scope (System_Aux_Id))
1478             then
1479                if not Is_Overloaded (Right_Opnd (Op_Node)) then
1480                   Error := True;
1481                else
1482                   Error := not Operand_Type_In_Scope (Pack);
1483                end if;
1484
1485             elsif Pack = Standard_Standard
1486               and then not Operand_Type_In_Scope (Standard_Standard)
1487             then
1488                Error := True;
1489             end if;
1490          end if;
1491
1492          if Error then
1493             Error_Msg_Node_2 := Pack;
1494             Error_Msg_NE
1495               ("& not declared in&", N, Selector_Name (Name (N)));
1496             Set_Etype (N, Any_Type);
1497             return;
1498
1499          --  Detect a mismatch between the context type and the result type
1500          --  in the named package, which is otherwise not detected if the
1501          --  operands are universal. Check is only needed if source entity is
1502          --  an operator, not a function that renames an operator.
1503
1504          elsif Nkind (Parent (N)) /= N_Type_Conversion
1505            and then Ekind (Entity (Name (N))) = E_Operator
1506            and then Is_Numeric_Type (Typ)
1507            and then not Is_Universal_Numeric_Type (Typ)
1508            and then Scope (Base_Type (Typ)) /= Pack
1509            and then not In_Instance
1510          then
1511             if Is_Fixed_Point_Type (Typ)
1512               and then Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide)
1513             then
1514                --  Already checked above
1515
1516                null;
1517
1518             --  Operator may be defined in an extension of System
1519
1520             elsif Present (System_Aux_Id)
1521               and then Scope (Opnd_Type) = System_Aux_Id
1522             then
1523                null;
1524
1525             else
1526                --  Could we use Wrong_Type here??? (this would require setting
1527                --  Etype (N) to the actual type found where Typ was expected).
1528
1529                Error_Msg_NE ("expect }", N, Typ);
1530             end if;
1531          end if;
1532       end if;
1533
1534       Set_Chars  (Op_Node, Op_Name);
1535
1536       if not Is_Private_Type (Etype (N)) then
1537          Set_Etype (Op_Node, Base_Type (Etype (N)));
1538       else
1539          Set_Etype (Op_Node, Etype (N));
1540       end if;
1541
1542       --  If this is a call to a function that renames a predefined equality,
1543       --  the renaming declaration provides a type that must be used to
1544       --  resolve the operands. This must be done now because resolution of
1545       --  the equality node will not resolve any remaining ambiguity, and it
1546       --  assumes that the first operand is not overloaded.
1547
1548       if Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne)
1549         and then Ekind (Func) = E_Function
1550         and then Is_Overloaded (Act1)
1551       then
1552          Resolve (Act1, Base_Type (Etype (First_Formal (Func))));
1553          Resolve (Act2, Base_Type (Etype (First_Formal (Func))));
1554       end if;
1555
1556       Set_Entity (Op_Node, Op_Id);
1557       Generate_Reference (Op_Id, N, ' ');
1558
1559       --  Do rewrite setting Comes_From_Source on the result if the original
1560       --  call came from source. Although it is not strictly the case that the
1561       --  operator as such comes from the source, logically it corresponds
1562       --  exactly to the function call in the source, so it should be marked
1563       --  this way (e.g. to make sure that validity checks work fine).
1564
1565       declare
1566          CS : constant Boolean := Comes_From_Source (N);
1567       begin
1568          Rewrite (N, Op_Node);
1569          Set_Comes_From_Source (N, CS);
1570       end;
1571
1572       --  If this is an arithmetic operator and the result type is private,
1573       --  the operands and the result must be wrapped in conversion to
1574       --  expose the underlying numeric type and expand the proper checks,
1575       --  e.g. on division.
1576
1577       if Is_Private_Type (Typ) then
1578          case Nkind (N) is
1579             when N_Op_Add   | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
1580                  N_Op_Expon | N_Op_Mod      | N_Op_Rem      =>
1581                Resolve_Intrinsic_Operator (N, Typ);
1582
1583             when N_Op_Plus  | N_Op_Minus    | N_Op_Abs      =>
1584                Resolve_Intrinsic_Unary_Operator (N, Typ);
1585
1586             when others =>
1587                Resolve (N, Typ);
1588          end case;
1589       else
1590          Resolve (N, Typ);
1591       end if;
1592
1593       --  If in ASIS_Mode, propagate operand types to original actuals of
1594       --  function call, which would otherwise not be fully resolved. If
1595       --  the call has already been constant-folded, nothing to do. We
1596       --  relocate the operand nodes rather than copy them, to preserve
1597       --  original_node pointers, given that the operands themselves may
1598       --  have been rewritten. If the call was itself a rewriting of an
1599       --  operator node, nothing to do.
1600
1601       if ASIS_Mode
1602         and then Nkind (N) in N_Op
1603         and then Nkind (Original_Node (N)) = N_Function_Call
1604       then
1605          declare
1606             L : Node_Id;
1607             R : constant Node_Id := Right_Opnd (N);
1608
1609             Old_First : constant Node_Id :=
1610                           First (Parameter_Associations (Original_Node (N)));
1611             Old_Sec   : Node_Id;
1612
1613          begin
1614             if Is_Binary then
1615                L       := Left_Opnd (N);
1616                Old_Sec := Next (Old_First);
1617
1618                --  If the original call has named associations, replace the
1619                --  explicit actual parameter in the association with the proper
1620                --  resolved operand.
1621
1622                if Nkind (Old_First) = N_Parameter_Association then
1623                   if Chars (Selector_Name (Old_First)) =
1624                      Chars (First_Entity (Op_Id))
1625                   then
1626                      Rewrite (Explicit_Actual_Parameter (Old_First),
1627                        Relocate_Node (L));
1628                   else
1629                      Rewrite (Explicit_Actual_Parameter (Old_First),
1630                        Relocate_Node (R));
1631                   end if;
1632
1633                else
1634                   Rewrite (Old_First, Relocate_Node (L));
1635                end if;
1636
1637                if Nkind (Old_Sec) = N_Parameter_Association then
1638                   if Chars (Selector_Name (Old_Sec)) =
1639                      Chars (First_Entity (Op_Id))
1640                   then
1641                      Rewrite (Explicit_Actual_Parameter (Old_Sec),
1642                        Relocate_Node (L));
1643                   else
1644                      Rewrite (Explicit_Actual_Parameter (Old_Sec),
1645                        Relocate_Node (R));
1646                   end if;
1647
1648                else
1649                   Rewrite (Old_Sec, Relocate_Node (R));
1650                end if;
1651
1652             else
1653                if Nkind (Old_First) = N_Parameter_Association then
1654                   Rewrite (Explicit_Actual_Parameter (Old_First),
1655                     Relocate_Node (R));
1656                else
1657                   Rewrite (Old_First, Relocate_Node (R));
1658                end if;
1659             end if;
1660          end;
1661
1662          Set_Parent (Original_Node (N), Parent (N));
1663       end if;
1664    end Make_Call_Into_Operator;
1665
1666    -------------------
1667    -- Operator_Kind --
1668    -------------------
1669
1670    function Operator_Kind
1671      (Op_Name   : Name_Id;
1672       Is_Binary : Boolean) return Node_Kind
1673    is
1674       Kind : Node_Kind;
1675
1676    begin
1677       --  Use CASE statement or array???
1678
1679       if Is_Binary then
1680          if    Op_Name = Name_Op_And      then
1681             Kind := N_Op_And;
1682          elsif Op_Name = Name_Op_Or       then
1683             Kind := N_Op_Or;
1684          elsif Op_Name = Name_Op_Xor      then
1685             Kind := N_Op_Xor;
1686          elsif Op_Name = Name_Op_Eq       then
1687             Kind := N_Op_Eq;
1688          elsif Op_Name = Name_Op_Ne       then
1689             Kind := N_Op_Ne;
1690          elsif Op_Name = Name_Op_Lt       then
1691             Kind := N_Op_Lt;
1692          elsif Op_Name = Name_Op_Le       then
1693             Kind := N_Op_Le;
1694          elsif Op_Name = Name_Op_Gt       then
1695             Kind := N_Op_Gt;
1696          elsif Op_Name = Name_Op_Ge       then
1697             Kind := N_Op_Ge;
1698          elsif Op_Name = Name_Op_Add      then
1699             Kind := N_Op_Add;
1700          elsif Op_Name = Name_Op_Subtract then
1701             Kind := N_Op_Subtract;
1702          elsif Op_Name = Name_Op_Concat   then
1703             Kind := N_Op_Concat;
1704          elsif Op_Name = Name_Op_Multiply then
1705             Kind := N_Op_Multiply;
1706          elsif Op_Name = Name_Op_Divide   then
1707             Kind := N_Op_Divide;
1708          elsif Op_Name = Name_Op_Mod      then
1709             Kind := N_Op_Mod;
1710          elsif Op_Name = Name_Op_Rem      then
1711             Kind := N_Op_Rem;
1712          elsif Op_Name = Name_Op_Expon    then
1713             Kind := N_Op_Expon;
1714          else
1715             raise Program_Error;
1716          end if;
1717
1718       --  Unary operators
1719
1720       else
1721          if    Op_Name = Name_Op_Add      then
1722             Kind := N_Op_Plus;
1723          elsif Op_Name = Name_Op_Subtract then
1724             Kind := N_Op_Minus;
1725          elsif Op_Name = Name_Op_Abs      then
1726             Kind := N_Op_Abs;
1727          elsif Op_Name = Name_Op_Not      then
1728             Kind := N_Op_Not;
1729          else
1730             raise Program_Error;
1731          end if;
1732       end if;
1733
1734       return Kind;
1735    end Operator_Kind;
1736
1737    ----------------------------
1738    -- Preanalyze_And_Resolve --
1739    ----------------------------
1740
1741    procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is
1742       Save_Full_Analysis : constant Boolean := Full_Analysis;
1743
1744    begin
1745       Full_Analysis := False;
1746       Expander_Mode_Save_And_Set (False);
1747
1748       --  Normally, we suppress all checks for this preanalysis. There is no
1749       --  point in processing them now, since they will be applied properly
1750       --  and in the proper location when the default expressions reanalyzed
1751       --  and reexpanded later on. We will also have more information at that
1752       --  point for possible suppression of individual checks.
1753
1754       --  However, in SPARK mode, most expansion is suppressed, and this
1755       --  later reanalysis and reexpansion may not occur. SPARK mode does
1756       --  require the setting of checking flags for proof purposes, so we
1757       --  do the SPARK preanalysis without suppressing checks.
1758
1759       --  This special handling for SPARK mode is required for example in the
1760       --  case of Ada 2012 constructs such as quantified expressions, which are
1761       --  expanded in two separate steps.
1762
1763       if GNATprove_Mode then
1764          Analyze_And_Resolve (N, T);
1765       else
1766          Analyze_And_Resolve (N, T, Suppress => All_Checks);
1767       end if;
1768
1769       Expander_Mode_Restore;
1770       Full_Analysis := Save_Full_Analysis;
1771    end Preanalyze_And_Resolve;
1772
1773    --  Version without context type
1774
1775    procedure Preanalyze_And_Resolve (N : Node_Id) is
1776       Save_Full_Analysis : constant Boolean := Full_Analysis;
1777
1778    begin
1779       Full_Analysis := False;
1780       Expander_Mode_Save_And_Set (False);
1781
1782       Analyze (N);
1783       Resolve (N, Etype (N), Suppress => All_Checks);
1784
1785       Expander_Mode_Restore;
1786       Full_Analysis := Save_Full_Analysis;
1787    end Preanalyze_And_Resolve;
1788
1789    ----------------------------------
1790    -- Replace_Actual_Discriminants --
1791    ----------------------------------
1792
1793    procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is
1794       Loc : constant Source_Ptr := Sloc (N);
1795       Tsk : Node_Id := Empty;
1796
1797       function Process_Discr (Nod : Node_Id) return Traverse_Result;
1798       --  Comment needed???
1799
1800       -------------------
1801       -- Process_Discr --
1802       -------------------
1803
1804       function Process_Discr (Nod : Node_Id) return Traverse_Result is
1805          Ent : Entity_Id;
1806
1807       begin
1808          if Nkind (Nod) = N_Identifier then
1809             Ent := Entity (Nod);
1810
1811             if Present (Ent)
1812               and then Ekind (Ent) = E_Discriminant
1813             then
1814                Rewrite (Nod,
1815                  Make_Selected_Component (Loc,
1816                    Prefix        => New_Copy_Tree (Tsk, New_Sloc => Loc),
1817                    Selector_Name => Make_Identifier (Loc, Chars (Ent))));
1818
1819                Set_Etype (Nod, Etype (Ent));
1820             end if;
1821
1822          end if;
1823
1824          return OK;
1825       end Process_Discr;
1826
1827       procedure Replace_Discrs is new Traverse_Proc (Process_Discr);
1828
1829    --  Start of processing for Replace_Actual_Discriminants
1830
1831    begin
1832       if not Expander_Active then
1833          return;
1834       end if;
1835
1836       if Nkind (Name (N)) = N_Selected_Component then
1837          Tsk := Prefix (Name (N));
1838
1839       elsif Nkind (Name (N)) = N_Indexed_Component then
1840          Tsk := Prefix (Prefix (Name (N)));
1841       end if;
1842
1843       if No (Tsk) then
1844          return;
1845       else
1846          Replace_Discrs (Default);
1847       end if;
1848    end Replace_Actual_Discriminants;
1849
1850    -------------
1851    -- Resolve --
1852    -------------
1853
1854    procedure Resolve (N : Node_Id; Typ : Entity_Id) is
1855       Ambiguous : Boolean   := False;
1856       Ctx_Type  : Entity_Id := Typ;
1857       Expr_Type : Entity_Id := Empty; -- prevent junk warning
1858       Err_Type  : Entity_Id := Empty;
1859       Found     : Boolean   := False;
1860       From_Lib  : Boolean;
1861       I         : Interp_Index;
1862       I1        : Interp_Index := 0;  -- prevent junk warning
1863       It        : Interp;
1864       It1       : Interp;
1865       Seen      : Entity_Id := Empty; -- prevent junk warning
1866
1867       function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
1868       --  Determine whether a node comes from a predefined library unit or
1869       --  Standard.
1870
1871       procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
1872       --  Try and fix up a literal so that it matches its expected type. New
1873       --  literals are manufactured if necessary to avoid cascaded errors.
1874
1875       procedure Report_Ambiguous_Argument;
1876       --  Additional diagnostics when an ambiguous call has an ambiguous
1877       --  argument (typically a controlling actual).
1878
1879       procedure Resolution_Failed;
1880       --  Called when attempt at resolving current expression fails
1881
1882       ------------------------------------
1883       -- Comes_From_Predefined_Lib_Unit --
1884       -------------------------------------
1885
1886       function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is
1887       begin
1888          return
1889            Sloc (Nod) = Standard_Location
1890              or else Is_Predefined_File_Name
1891                        (Unit_File_Name (Get_Source_Unit (Sloc (Nod))));
1892       end Comes_From_Predefined_Lib_Unit;
1893
1894       --------------------
1895       -- Patch_Up_Value --
1896       --------------------
1897
1898       procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is
1899       begin
1900          if Nkind (N) = N_Integer_Literal and then Is_Real_Type (Typ) then
1901             Rewrite (N,
1902               Make_Real_Literal (Sloc (N),
1903                 Realval => UR_From_Uint (Intval (N))));
1904             Set_Etype (N, Universal_Real);
1905             Set_Is_Static_Expression (N);
1906
1907          elsif Nkind (N) = N_Real_Literal and then Is_Integer_Type (Typ) then
1908             Rewrite (N,
1909               Make_Integer_Literal (Sloc (N),
1910                 Intval => UR_To_Uint (Realval (N))));
1911             Set_Etype (N, Universal_Integer);
1912             Set_Is_Static_Expression (N);
1913
1914          elsif Nkind (N) = N_String_Literal
1915                  and then Is_Character_Type (Typ)
1916          then
1917             Set_Character_Literal_Name (Char_Code (Character'Pos ('A')));
1918             Rewrite (N,
1919               Make_Character_Literal (Sloc (N),
1920                 Chars => Name_Find,
1921                 Char_Literal_Value =>
1922                   UI_From_Int (Character'Pos ('A'))));
1923             Set_Etype (N, Any_Character);
1924             Set_Is_Static_Expression (N);
1925
1926          elsif Nkind (N) /= N_String_Literal and then Is_String_Type (Typ) then
1927             Rewrite (N,
1928               Make_String_Literal (Sloc (N),
1929                 Strval => End_String));
1930
1931          elsif Nkind (N) = N_Range then
1932             Patch_Up_Value (Low_Bound (N),  Typ);
1933             Patch_Up_Value (High_Bound (N), Typ);
1934          end if;
1935       end Patch_Up_Value;
1936
1937       -------------------------------
1938       -- Report_Ambiguous_Argument --
1939       -------------------------------
1940
1941       procedure Report_Ambiguous_Argument is
1942          Arg : constant Node_Id := First (Parameter_Associations (N));
1943          I   : Interp_Index;
1944          It  : Interp;
1945
1946       begin
1947          if Nkind (Arg) = N_Function_Call
1948            and then Is_Entity_Name (Name (Arg))
1949            and then Is_Overloaded (Name (Arg))
1950          then
1951             Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg));
1952
1953             --  Could use comments on what is going on here???
1954
1955             Get_First_Interp (Name (Arg), I, It);
1956             while Present (It.Nam) loop
1957                Error_Msg_Sloc := Sloc (It.Nam);
1958
1959                if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then
1960                   Error_Msg_N ("interpretation (inherited) #!", Arg);
1961                else
1962                   Error_Msg_N ("interpretation #!", Arg);
1963                end if;
1964
1965                Get_Next_Interp (I, It);
1966             end loop;
1967          end if;
1968       end Report_Ambiguous_Argument;
1969
1970       -----------------------
1971       -- Resolution_Failed --
1972       -----------------------
1973
1974       procedure Resolution_Failed is
1975       begin
1976          Patch_Up_Value (N, Typ);
1977          Set_Etype (N, Typ);
1978          Debug_A_Exit ("resolving  ", N, " (done, resolution failed)");
1979          Set_Is_Overloaded (N, False);
1980
1981          --  The caller will return without calling the expander, so we need
1982          --  to set the analyzed flag. Note that it is fine to set Analyzed
1983          --  to True even if we are in the middle of a shallow analysis,
1984          --  (see the spec of sem for more details) since this is an error
1985          --  situation anyway, and there is no point in repeating the
1986          --  analysis later (indeed it won't work to repeat it later, since
1987          --  we haven't got a clear resolution of which entity is being
1988          --  referenced.)
1989
1990          Set_Analyzed (N, True);
1991          return;
1992       end Resolution_Failed;
1993
1994       --  Local variables
1995
1996       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1997
1998    --  Start of processing for Resolve
1999
2000    begin
2001       if N = Error then
2002          return;
2003       end if;
2004
2005       --  A declaration may be subject to pragma Ghost. Set the mode now to
2006       --  ensure that any nodes generated during analysis and expansion are
2007       --  marked as Ghost.
2008
2009       if Is_Declaration (N) then
2010          Set_Ghost_Mode (N);
2011       end if;
2012
2013       --  Access attribute on remote subprogram cannot be used for a non-remote
2014       --  access-to-subprogram type.
2015
2016       if Nkind (N) = N_Attribute_Reference
2017         and then Nam_In (Attribute_Name (N), Name_Access,
2018                                              Name_Unrestricted_Access,
2019                                              Name_Unchecked_Access)
2020         and then Comes_From_Source (N)
2021         and then Is_Entity_Name (Prefix (N))
2022         and then Is_Subprogram (Entity (Prefix (N)))
2023         and then Is_Remote_Call_Interface (Entity (Prefix (N)))
2024         and then not Is_Remote_Access_To_Subprogram_Type (Typ)
2025       then
2026          Error_Msg_N
2027            ("prefix must statically denote a non-remote subprogram", N);
2028       end if;
2029
2030       From_Lib := Comes_From_Predefined_Lib_Unit (N);
2031
2032       --  If the context is a Remote_Access_To_Subprogram, access attributes
2033       --  must be resolved with the corresponding fat pointer. There is no need
2034       --  to check for the attribute name since the return type of an
2035       --  attribute is never a remote type.
2036
2037       if Nkind (N) = N_Attribute_Reference
2038         and then Comes_From_Source (N)
2039         and then (Is_Remote_Call_Interface (Typ) or else Is_Remote_Types (Typ))
2040       then
2041          declare
2042             Attr      : constant Attribute_Id :=
2043                           Get_Attribute_Id (Attribute_Name (N));
2044             Pref      : constant Node_Id      := Prefix (N);
2045             Decl      : Node_Id;
2046             Spec      : Node_Id;
2047             Is_Remote : Boolean := True;
2048
2049          begin
2050             --  Check that Typ is a remote access-to-subprogram type
2051
2052             if Is_Remote_Access_To_Subprogram_Type (Typ) then
2053
2054                --  Prefix (N) must statically denote a remote subprogram
2055                --  declared in a package specification.
2056
2057                if Attr = Attribute_Access           or else
2058                   Attr = Attribute_Unchecked_Access or else
2059                   Attr = Attribute_Unrestricted_Access
2060                then
2061                   Decl := Unit_Declaration_Node (Entity (Pref));
2062
2063                   if Nkind (Decl) = N_Subprogram_Body then
2064                      Spec := Corresponding_Spec (Decl);
2065
2066                      if Present (Spec) then
2067                         Decl := Unit_Declaration_Node (Spec);
2068                      end if;
2069                   end if;
2070
2071                   Spec := Parent (Decl);
2072
2073                   if not Is_Entity_Name (Prefix (N))
2074                     or else Nkind (Spec) /= N_Package_Specification
2075                     or else
2076                       not Is_Remote_Call_Interface (Defining_Entity (Spec))
2077                   then
2078                      Is_Remote := False;
2079                      Error_Msg_N
2080                        ("prefix must statically denote a remote subprogram ",
2081                         N);
2082                   end if;
2083
2084                   --  If we are generating code in distributed mode, perform
2085                   --  semantic checks against corresponding remote entities.
2086
2087                   if Expander_Active
2088                     and then Get_PCS_Name /= Name_No_DSA
2089                   then
2090                      Check_Subtype_Conformant
2091                        (New_Id  => Entity (Prefix (N)),
2092                         Old_Id  => Designated_Type
2093                                      (Corresponding_Remote_Type (Typ)),
2094                         Err_Loc => N);
2095
2096                      if Is_Remote then
2097                         Process_Remote_AST_Attribute (N, Typ);
2098                      end if;
2099                   end if;
2100                end if;
2101             end if;
2102          end;
2103       end if;
2104
2105       Debug_A_Entry ("resolving  ", N);
2106
2107       if Debug_Flag_V then
2108          Write_Overloads (N);
2109       end if;
2110
2111       if Comes_From_Source (N) then
2112          if Is_Fixed_Point_Type (Typ) then
2113             Check_Restriction (No_Fixed_Point, N);
2114
2115          elsif Is_Floating_Point_Type (Typ)
2116            and then Typ /= Universal_Real
2117            and then Typ /= Any_Real
2118          then
2119             Check_Restriction (No_Floating_Point, N);
2120          end if;
2121       end if;
2122
2123       --  Return if already analyzed
2124
2125       if Analyzed (N) then
2126          Debug_A_Exit ("resolving  ", N, "  (done, already analyzed)");
2127          Analyze_Dimension (N);
2128          Ghost_Mode := Save_Ghost_Mode;
2129          return;
2130
2131       --  Any case of Any_Type as the Etype value means that we had a
2132       --  previous error.
2133
2134       elsif Etype (N) = Any_Type then
2135          Debug_A_Exit ("resolving  ", N, "  (done, Etype = Any_Type)");
2136          Ghost_Mode := Save_Ghost_Mode;
2137          return;
2138       end if;
2139
2140       Check_Parameterless_Call (N);
2141
2142       --  The resolution of an Expression_With_Actions is determined by
2143       --  its Expression.
2144
2145       if Nkind (N) = N_Expression_With_Actions then
2146          Resolve (Expression (N), Typ);
2147
2148          Found := True;
2149          Expr_Type := Etype (Expression (N));
2150
2151       --  If not overloaded, then we know the type, and all that needs doing
2152       --  is to check that this type is compatible with the context.
2153
2154       elsif not Is_Overloaded (N) then
2155          Found := Covers (Typ, Etype (N));
2156          Expr_Type := Etype (N);
2157
2158       --  In the overloaded case, we must select the interpretation that
2159       --  is compatible with the context (i.e. the type passed to Resolve)
2160
2161       else
2162          --  Loop through possible interpretations
2163
2164          Get_First_Interp (N, I, It);
2165          Interp_Loop : while Present (It.Typ) loop
2166             if Debug_Flag_V then
2167                Write_Str ("Interp: ");
2168                Write_Interp (It);
2169             end if;
2170
2171             --  We are only interested in interpretations that are compatible
2172             --  with the expected type, any other interpretations are ignored.
2173
2174             if not Covers (Typ, It.Typ) then
2175                if Debug_Flag_V then
2176                   Write_Str ("    interpretation incompatible with context");
2177                   Write_Eol;
2178                end if;
2179
2180             else
2181                --  Skip the current interpretation if it is disabled by an
2182                --  abstract operator. This action is performed only when the
2183                --  type against which we are resolving is the same as the
2184                --  type of the interpretation.
2185
2186                if Ada_Version >= Ada_2005
2187                  and then It.Typ = Typ
2188                  and then Typ /= Universal_Integer
2189                  and then Typ /= Universal_Real
2190                  and then Present (It.Abstract_Op)
2191                then
2192                   if Debug_Flag_V then
2193                      Write_Line ("Skip.");
2194                   end if;
2195
2196                   goto Continue;
2197                end if;
2198
2199                --  First matching interpretation
2200
2201                if not Found then
2202                   Found := True;
2203                   I1    := I;
2204                   Seen  := It.Nam;
2205                   Expr_Type := It.Typ;
2206
2207                --  Matching interpretation that is not the first, maybe an
2208                --  error, but there are some cases where preference rules are
2209                --  used to choose between the two possibilities. These and
2210                --  some more obscure cases are handled in Disambiguate.
2211
2212                else
2213                   --  If the current statement is part of a predefined library
2214                   --  unit, then all interpretations which come from user level
2215                   --  packages should not be considered. Check previous and
2216                   --  current one.
2217
2218                   if From_Lib then
2219                      if not Comes_From_Predefined_Lib_Unit (It.Nam) then
2220                         goto Continue;
2221
2222                      elsif not Comes_From_Predefined_Lib_Unit (Seen) then
2223
2224                         --  Previous interpretation must be discarded
2225
2226                         I1 := I;
2227                         Seen := It.Nam;
2228                         Expr_Type := It.Typ;
2229                         Set_Entity (N, Seen);
2230                         goto Continue;
2231                      end if;
2232                   end if;
2233
2234                   --  Otherwise apply further disambiguation steps
2235
2236                   Error_Msg_Sloc := Sloc (Seen);
2237                   It1 := Disambiguate (N, I1, I, Typ);
2238
2239                   --  Disambiguation has succeeded. Skip the remaining
2240                   --  interpretations.
2241
2242                   if It1 /= No_Interp then
2243                      Seen := It1.Nam;
2244                      Expr_Type := It1.Typ;
2245
2246                      while Present (It.Typ) loop
2247                         Get_Next_Interp (I, It);
2248                      end loop;
2249
2250                   else
2251                      --  Before we issue an ambiguity complaint, check for
2252                      --  the case of a subprogram call where at least one
2253                      --  of the arguments is Any_Type, and if so, suppress
2254                      --  the message, since it is a cascaded error.
2255
2256                      if Nkind (N) in N_Subprogram_Call then
2257                         declare
2258                            A : Node_Id;
2259                            E : Node_Id;
2260
2261                         begin
2262                            A := First_Actual (N);
2263                            while Present (A) loop
2264                               E := A;
2265
2266                               if Nkind (E) = N_Parameter_Association then
2267                                  E := Explicit_Actual_Parameter (E);
2268                               end if;
2269
2270                               if Etype (E) = Any_Type then
2271                                  if Debug_Flag_V then
2272                                     Write_Str ("Any_Type in call");
2273                                     Write_Eol;
2274                                  end if;
2275
2276                                  exit Interp_Loop;
2277                               end if;
2278
2279                               Next_Actual (A);
2280                            end loop;
2281                         end;
2282
2283                      elsif Nkind (N) in N_Binary_Op
2284                        and then (Etype (Left_Opnd (N)) = Any_Type
2285                                   or else Etype (Right_Opnd (N)) = Any_Type)
2286                      then
2287                         exit Interp_Loop;
2288
2289                      elsif Nkind (N) in N_Unary_Op
2290                        and then Etype (Right_Opnd (N)) = Any_Type
2291                      then
2292                         exit Interp_Loop;
2293                      end if;
2294
2295                      --  Not that special case, so issue message using the
2296                      --  flag Ambiguous to control printing of the header
2297                      --  message only at the start of an ambiguous set.
2298
2299                      if not Ambiguous then
2300                         if Nkind (N) = N_Function_Call
2301                           and then Nkind (Name (N)) = N_Explicit_Dereference
2302                         then
2303                            Error_Msg_N
2304                              ("ambiguous expression "
2305                                & "(cannot resolve indirect call)!", N);
2306                         else
2307                            Error_Msg_NE -- CODEFIX
2308                              ("ambiguous expression (cannot resolve&)!",
2309                               N, It.Nam);
2310                         end if;
2311
2312                         Ambiguous := True;
2313
2314                         if Nkind (Parent (Seen)) = N_Full_Type_Declaration then
2315                            Error_Msg_N
2316                              ("\\possible interpretation (inherited)#!", N);
2317                         else
2318                            Error_Msg_N -- CODEFIX
2319                              ("\\possible interpretation#!", N);
2320                         end if;
2321
2322                         if Nkind (N) in N_Subprogram_Call
2323                           and then Present (Parameter_Associations (N))
2324                         then
2325                            Report_Ambiguous_Argument;
2326                         end if;
2327                      end if;
2328
2329                      Error_Msg_Sloc := Sloc (It.Nam);
2330
2331                      --  By default, the error message refers to the candidate
2332                      --  interpretation. But if it is a predefined operator, it
2333                      --  is implicitly declared at the declaration of the type
2334                      --  of the operand. Recover the sloc of that declaration
2335                      --  for the error message.
2336
2337                      if Nkind (N) in N_Op
2338                        and then Scope (It.Nam) = Standard_Standard
2339                        and then not Is_Overloaded (Right_Opnd (N))
2340                        and then Scope (Base_Type (Etype (Right_Opnd (N)))) /=
2341                                                              Standard_Standard
2342                      then
2343                         Err_Type := First_Subtype (Etype (Right_Opnd (N)));
2344
2345                         if Comes_From_Source (Err_Type)
2346                           and then Present (Parent (Err_Type))
2347                         then
2348                            Error_Msg_Sloc := Sloc (Parent (Err_Type));
2349                         end if;
2350
2351                      elsif Nkind (N) in N_Binary_Op
2352                        and then Scope (It.Nam) = Standard_Standard
2353                        and then not Is_Overloaded (Left_Opnd (N))
2354                        and then Scope (Base_Type (Etype (Left_Opnd (N)))) /=
2355                                                              Standard_Standard
2356                      then
2357                         Err_Type := First_Subtype (Etype (Left_Opnd (N)));
2358
2359                         if Comes_From_Source (Err_Type)
2360                           and then Present (Parent (Err_Type))
2361                         then
2362                            Error_Msg_Sloc := Sloc (Parent (Err_Type));
2363                         end if;
2364
2365                      --  If this is an indirect call, use the subprogram_type
2366                      --  in the message, to have a meaningful location. Also
2367                      --  indicate if this is an inherited operation, created
2368                      --  by a type declaration.
2369
2370                      elsif Nkind (N) = N_Function_Call
2371                        and then Nkind (Name (N)) = N_Explicit_Dereference
2372                        and then Is_Type (It.Nam)
2373                      then
2374                         Err_Type := It.Nam;
2375                         Error_Msg_Sloc :=
2376                           Sloc (Associated_Node_For_Itype (Err_Type));
2377                      else
2378                         Err_Type := Empty;
2379                      end if;
2380
2381                      if Nkind (N) in N_Op
2382                        and then Scope (It.Nam) = Standard_Standard
2383                        and then Present (Err_Type)
2384                      then
2385                         --  Special-case the message for universal_fixed
2386                         --  operators, which are not declared with the type
2387                         --  of the operand, but appear forever in Standard.
2388
2389                         if It.Typ = Universal_Fixed
2390                           and then Scope (It.Nam) = Standard_Standard
2391                         then
2392                            Error_Msg_N
2393                              ("\\possible interpretation as universal_fixed "
2394                               & "operation (RM 4.5.5 (19))", N);
2395                         else
2396                            Error_Msg_N
2397                              ("\\possible interpretation (predefined)#!", N);
2398                         end if;
2399
2400                      elsif
2401                        Nkind (Parent (It.Nam)) = N_Full_Type_Declaration
2402                      then
2403                         Error_Msg_N
2404                           ("\\possible interpretation (inherited)#!", N);
2405                      else
2406                         Error_Msg_N -- CODEFIX
2407                           ("\\possible interpretation#!", N);
2408                      end if;
2409
2410                   end if;
2411                end if;
2412
2413                --  We have a matching interpretation, Expr_Type is the type
2414                --  from this interpretation, and Seen is the entity.
2415
2416                --  For an operator, just set the entity name. The type will be
2417                --  set by the specific operator resolution routine.
2418
2419                if Nkind (N) in N_Op then
2420                   Set_Entity (N, Seen);
2421                   Generate_Reference (Seen, N);
2422
2423                elsif Nkind (N) = N_Case_Expression then
2424                   Set_Etype (N, Expr_Type);
2425
2426                elsif Nkind (N) = N_Character_Literal then
2427                   Set_Etype (N, Expr_Type);
2428
2429                elsif Nkind (N) = N_If_Expression then
2430                   Set_Etype (N, Expr_Type);
2431
2432                --  AI05-0139-2: Expression is overloaded because type has
2433                --  implicit dereference. If type matches context, no implicit
2434                --  dereference is involved.
2435
2436                elsif Has_Implicit_Dereference (Expr_Type) then
2437                   Set_Etype (N, Expr_Type);
2438                   Set_Is_Overloaded (N, False);
2439                   exit Interp_Loop;
2440
2441                elsif Is_Overloaded (N)
2442                  and then Present (It.Nam)
2443                  and then Ekind (It.Nam) = E_Discriminant
2444                  and then Has_Implicit_Dereference (It.Nam)
2445                then
2446                   --  If the node is a general indexing, the dereference is
2447                   --  is inserted when resolving the rewritten form, else
2448                   --  insert it now.
2449
2450                   if Nkind (N) /= N_Indexed_Component
2451                     or else No (Generalized_Indexing (N))
2452                   then
2453                      Build_Explicit_Dereference (N, It.Nam);
2454                   end if;
2455
2456                --  For an explicit dereference, attribute reference, range,
2457                --  short-circuit form (which is not an operator node), or call
2458                --  with a name that is an explicit dereference, there is
2459                --  nothing to be done at this point.
2460
2461                elsif Nkind_In (N, N_Explicit_Dereference,
2462                                   N_Attribute_Reference,
2463                                   N_And_Then,
2464                                   N_Indexed_Component,
2465                                   N_Or_Else,
2466                                   N_Range,
2467                                   N_Selected_Component,
2468                                   N_Slice)
2469                  or else Nkind (Name (N)) = N_Explicit_Dereference
2470                then
2471                   null;
2472
2473                --  For procedure or function calls, set the type of the name,
2474                --  and also the entity pointer for the prefix.
2475
2476                elsif Nkind (N) in N_Subprogram_Call
2477                  and then Is_Entity_Name (Name (N))
2478                then
2479                   Set_Etype  (Name (N), Expr_Type);
2480                   Set_Entity (Name (N), Seen);
2481                   Generate_Reference (Seen, Name (N));
2482
2483                elsif Nkind (N) = N_Function_Call
2484                  and then Nkind (Name (N)) = N_Selected_Component
2485                then
2486                   Set_Etype (Name (N), Expr_Type);
2487                   Set_Entity (Selector_Name (Name (N)), Seen);
2488                   Generate_Reference (Seen, Selector_Name (Name (N)));
2489
2490                --  For all other cases, just set the type of the Name
2491
2492                else
2493                   Set_Etype (Name (N), Expr_Type);
2494                end if;
2495
2496             end if;
2497
2498             <<Continue>>
2499
2500             --  Move to next interpretation
2501
2502             exit Interp_Loop when No (It.Typ);
2503
2504             Get_Next_Interp (I, It);
2505          end loop Interp_Loop;
2506       end if;
2507
2508       --  At this stage Found indicates whether or not an acceptable
2509       --  interpretation exists. If not, then we have an error, except that if
2510       --  the context is Any_Type as a result of some other error, then we
2511       --  suppress the error report.
2512
2513       if not Found then
2514          if Typ /= Any_Type then
2515
2516             --  If type we are looking for is Void, then this is the procedure
2517             --  call case, and the error is simply that what we gave is not a
2518             --  procedure name (we think of procedure calls as expressions with
2519             --  types internally, but the user doesn't think of them this way).
2520
2521             if Typ = Standard_Void_Type then
2522
2523                --  Special case message if function used as a procedure
2524
2525                if Nkind (N) = N_Procedure_Call_Statement
2526                  and then Is_Entity_Name (Name (N))
2527                  and then Ekind (Entity (Name (N))) = E_Function
2528                then
2529                   Error_Msg_NE
2530                     ("cannot use function & in a procedure call",
2531                      Name (N), Entity (Name (N)));
2532
2533                --  Otherwise give general message (not clear what cases this
2534                --  covers, but no harm in providing for them).
2535
2536                else
2537                   Error_Msg_N ("expect procedure name in procedure call", N);
2538                end if;
2539
2540                Found := True;
2541
2542             --  Otherwise we do have a subexpression with the wrong type
2543
2544             --  Check for the case of an allocator which uses an access type
2545             --  instead of the designated type. This is a common error and we
2546             --  specialize the message, posting an error on the operand of the
2547             --  allocator, complaining that we expected the designated type of
2548             --  the allocator.
2549
2550             elsif Nkind (N) = N_Allocator
2551               and then Is_Access_Type (Typ)
2552               and then Is_Access_Type (Etype (N))
2553               and then Designated_Type (Etype (N)) = Typ
2554             then
2555                Wrong_Type (Expression (N), Designated_Type (Typ));
2556                Found := True;
2557
2558             --  Check for view mismatch on Null in instances, for which the
2559             --  view-swapping mechanism has no identifier.
2560
2561             elsif (In_Instance or else In_Inlined_Body)
2562               and then (Nkind (N) = N_Null)
2563               and then Is_Private_Type (Typ)
2564               and then Is_Access_Type (Full_View (Typ))
2565             then
2566                Resolve (N, Full_View (Typ));
2567                Set_Etype (N, Typ);
2568                Ghost_Mode := Save_Ghost_Mode;
2569                return;
2570
2571             --  Check for an aggregate. Sometimes we can get bogus aggregates
2572             --  from misuse of parentheses, and we are about to complain about
2573             --  the aggregate without even looking inside it.
2574
2575             --  Instead, if we have an aggregate of type Any_Composite, then
2576             --  analyze and resolve the component fields, and then only issue
2577             --  another message if we get no errors doing this (otherwise
2578             --  assume that the errors in the aggregate caused the problem).
2579
2580             elsif Nkind (N) = N_Aggregate
2581               and then Etype (N) = Any_Composite
2582             then
2583                --  Disable expansion in any case. If there is a type mismatch
2584                --  it may be fatal to try to expand the aggregate. The flag
2585                --  would otherwise be set to false when the error is posted.
2586
2587                Expander_Active := False;
2588
2589                declare
2590                   procedure Check_Aggr (Aggr : Node_Id);
2591                   --  Check one aggregate, and set Found to True if we have a
2592                   --  definite error in any of its elements
2593
2594                   procedure Check_Elmt (Aelmt : Node_Id);
2595                   --  Check one element of aggregate and set Found to True if
2596                   --  we definitely have an error in the element.
2597
2598                   ----------------
2599                   -- Check_Aggr --
2600                   ----------------
2601
2602                   procedure Check_Aggr (Aggr : Node_Id) is
2603                      Elmt : Node_Id;
2604
2605                   begin
2606                      if Present (Expressions (Aggr)) then
2607                         Elmt := First (Expressions (Aggr));
2608                         while Present (Elmt) loop
2609                            Check_Elmt (Elmt);
2610                            Next (Elmt);
2611                         end loop;
2612                      end if;
2613
2614                      if Present (Component_Associations (Aggr)) then
2615                         Elmt := First (Component_Associations (Aggr));
2616                         while Present (Elmt) loop
2617
2618                            --  If this is a default-initialized component, then
2619                            --  there is nothing to check. The box will be
2620                            --  replaced by the appropriate call during late
2621                            --  expansion.
2622
2623                            if not Box_Present (Elmt) then
2624                               Check_Elmt (Expression (Elmt));
2625                            end if;
2626
2627                            Next (Elmt);
2628                         end loop;
2629                      end if;
2630                   end Check_Aggr;
2631
2632                   ----------------
2633                   -- Check_Elmt --
2634                   ----------------
2635
2636                   procedure Check_Elmt (Aelmt : Node_Id) is
2637                   begin
2638                      --  If we have a nested aggregate, go inside it (to
2639                      --  attempt a naked analyze-resolve of the aggregate can
2640                      --  cause undesirable cascaded errors). Do not resolve
2641                      --  expression if it needs a type from context, as for
2642                      --  integer * fixed expression.
2643
2644                      if Nkind (Aelmt) = N_Aggregate then
2645                         Check_Aggr (Aelmt);
2646
2647                      else
2648                         Analyze (Aelmt);
2649
2650                         if not Is_Overloaded (Aelmt)
2651                           and then Etype (Aelmt) /= Any_Fixed
2652                         then
2653                            Resolve (Aelmt);
2654                         end if;
2655
2656                         if Etype (Aelmt) = Any_Type then
2657                            Found := True;
2658                         end if;
2659                      end if;
2660                   end Check_Elmt;
2661
2662                begin
2663                   Check_Aggr (N);
2664                end;
2665             end if;
2666
2667             --  Looks like we have a type error, but check for special case
2668             --  of Address wanted, integer found, with the configuration pragma
2669             --  Allow_Integer_Address active. If we have this case, introduce
2670             --  an unchecked conversion to allow the integer expression to be
2671             --  treated as an Address. The reverse case of integer wanted,
2672             --  Address found, is treated in an analogous manner.
2673
2674             if Address_Integer_Convert_OK (Typ, Etype (N)) then
2675                Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N)));
2676                Analyze_And_Resolve (N, Typ);
2677                Ghost_Mode := Save_Ghost_Mode;
2678                return;
2679             end if;
2680
2681             --  That special Allow_Integer_Address check did not appply, so we
2682             --  have a real type error. If an error message was issued already,
2683             --  Found got reset to True, so if it's still False, issue standard
2684             --  Wrong_Type message.
2685
2686             if not Found then
2687                if Is_Overloaded (N) and then Nkind (N) = N_Function_Call then
2688                   declare
2689                      Subp_Name : Node_Id;
2690
2691                   begin
2692                      if Is_Entity_Name (Name (N)) then
2693                         Subp_Name := Name (N);
2694
2695                      elsif Nkind (Name (N)) = N_Selected_Component then
2696
2697                         --  Protected operation: retrieve operation name
2698
2699                         Subp_Name := Selector_Name (Name (N));
2700
2701                      else
2702                         raise Program_Error;
2703                      end if;
2704
2705                      Error_Msg_Node_2 := Typ;
2706                      Error_Msg_NE
2707                        ("no visible interpretation of& "
2708                         & "matches expected type&", N, Subp_Name);
2709                   end;
2710
2711                   if All_Errors_Mode then
2712                      declare
2713                         Index : Interp_Index;
2714                         It    : Interp;
2715
2716                      begin
2717                         Error_Msg_N ("\\possible interpretations:", N);
2718
2719                         Get_First_Interp (Name (N), Index, It);
2720                         while Present (It.Nam) loop
2721                            Error_Msg_Sloc := Sloc (It.Nam);
2722                            Error_Msg_Node_2 := It.Nam;
2723                            Error_Msg_NE
2724                              ("\\  type& for & declared#", N, It.Typ);
2725                            Get_Next_Interp (Index, It);
2726                         end loop;
2727                      end;
2728
2729                   else
2730                      Error_Msg_N ("\use -gnatf for details", N);
2731                   end if;
2732
2733                else
2734                   Wrong_Type (N, Typ);
2735                end if;
2736             end if;
2737          end if;
2738
2739          Resolution_Failed;
2740          Ghost_Mode := Save_Ghost_Mode;
2741          return;
2742
2743       --  Test if we have more than one interpretation for the context
2744
2745       elsif Ambiguous then
2746          Resolution_Failed;
2747          Ghost_Mode := Save_Ghost_Mode;
2748          return;
2749
2750       --  Only one intepretation
2751
2752       else
2753          --  In Ada 2005, if we have something like "X : T := 2 + 2;", where
2754          --  the "+" on T is abstract, and the operands are of universal type,
2755          --  the above code will have (incorrectly) resolved the "+" to the
2756          --  universal one in Standard. Therefore check for this case and give
2757          --  an error. We can't do this earlier, because it would cause legal
2758          --  cases to get errors (when some other type has an abstract "+").
2759
2760          if Ada_Version >= Ada_2005
2761            and then Nkind (N) in N_Op
2762            and then Is_Overloaded (N)
2763            and then Is_Universal_Numeric_Type (Etype (Entity (N)))
2764          then
2765             Get_First_Interp (N, I, It);
2766             while Present (It.Typ) loop
2767                if Present (It.Abstract_Op) and then
2768                  Etype (It.Abstract_Op) = Typ
2769                then
2770                   Error_Msg_NE
2771                     ("cannot call abstract subprogram &!", N, It.Abstract_Op);
2772                   return;
2773                end if;
2774
2775                Get_Next_Interp (I, It);
2776             end loop;
2777          end if;
2778
2779          --  Here we have an acceptable interpretation for the context
2780
2781          --  Propagate type information and normalize tree for various
2782          --  predefined operations. If the context only imposes a class of
2783          --  types, rather than a specific type, propagate the actual type
2784          --  downward.
2785
2786          if Typ = Any_Integer or else
2787             Typ = Any_Boolean or else
2788             Typ = Any_Modular or else
2789             Typ = Any_Real    or else
2790             Typ = Any_Discrete
2791          then
2792             Ctx_Type := Expr_Type;
2793
2794             --  Any_Fixed is legal in a real context only if a specific fixed-
2795             --  point type is imposed. If Norman Cohen can be confused by this,
2796             --  it deserves a separate message.
2797
2798             if Typ = Any_Real
2799               and then Expr_Type = Any_Fixed
2800             then
2801                Error_Msg_N ("illegal context for mixed mode operation", N);
2802                Set_Etype (N, Universal_Real);
2803                Ctx_Type := Universal_Real;
2804             end if;
2805          end if;
2806
2807          --  A user-defined operator is transformed into a function call at
2808          --  this point, so that further processing knows that operators are
2809          --  really operators (i.e. are predefined operators). User-defined
2810          --  operators that are intrinsic are just renamings of the predefined
2811          --  ones, and need not be turned into calls either, but if they rename
2812          --  a different operator, we must transform the node accordingly.
2813          --  Instantiations of Unchecked_Conversion are intrinsic but are
2814          --  treated as functions, even if given an operator designator.
2815
2816          if Nkind (N) in N_Op
2817            and then Present (Entity (N))
2818            and then Ekind (Entity (N)) /= E_Operator
2819          then
2820
2821             if not Is_Predefined_Op (Entity (N)) then
2822                Rewrite_Operator_As_Call (N, Entity (N));
2823
2824             elsif Present (Alias (Entity (N)))
2825               and then
2826                 Nkind (Parent (Parent (Entity (N)))) =
2827                                     N_Subprogram_Renaming_Declaration
2828             then
2829                Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
2830
2831                --  If the node is rewritten, it will be fully resolved in
2832                --  Rewrite_Renamed_Operator.
2833
2834                if Analyzed (N) then
2835                   Ghost_Mode := Save_Ghost_Mode;
2836                   return;
2837                end if;
2838             end if;
2839          end if;
2840
2841          case N_Subexpr'(Nkind (N)) is
2842
2843             when N_Aggregate => Resolve_Aggregate                (N, Ctx_Type);
2844
2845             when N_Allocator => Resolve_Allocator                (N, Ctx_Type);
2846
2847             when N_Short_Circuit
2848                              => Resolve_Short_Circuit            (N, Ctx_Type);
2849
2850             when N_Attribute_Reference
2851                              => Resolve_Attribute                (N, Ctx_Type);
2852
2853             when N_Case_Expression
2854                              => Resolve_Case_Expression          (N, Ctx_Type);
2855
2856             when N_Character_Literal
2857                              => Resolve_Character_Literal        (N, Ctx_Type);
2858
2859             when N_Expanded_Name
2860                              => Resolve_Entity_Name              (N, Ctx_Type);
2861
2862             when N_Explicit_Dereference
2863                              => Resolve_Explicit_Dereference     (N, Ctx_Type);
2864
2865             when N_Expression_With_Actions
2866                              => Resolve_Expression_With_Actions  (N, Ctx_Type);
2867
2868             when N_Extension_Aggregate
2869                              => Resolve_Extension_Aggregate      (N, Ctx_Type);
2870
2871             when N_Function_Call
2872                              => Resolve_Call                     (N, Ctx_Type);
2873
2874             when N_Identifier
2875                              => Resolve_Entity_Name              (N, Ctx_Type);
2876
2877             when N_If_Expression
2878                              => Resolve_If_Expression            (N, Ctx_Type);
2879
2880             when N_Indexed_Component
2881                              => Resolve_Indexed_Component        (N, Ctx_Type);
2882
2883             when N_Integer_Literal
2884                              => Resolve_Integer_Literal          (N, Ctx_Type);
2885
2886             when N_Membership_Test
2887                              => Resolve_Membership_Op            (N, Ctx_Type);
2888
2889             when N_Null      => Resolve_Null                     (N, Ctx_Type);
2890
2891             when N_Op_And | N_Op_Or | N_Op_Xor
2892                              => Resolve_Logical_Op               (N, Ctx_Type);
2893
2894             when N_Op_Eq | N_Op_Ne
2895                              => Resolve_Equality_Op              (N, Ctx_Type);
2896
2897             when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
2898                              => Resolve_Comparison_Op            (N, Ctx_Type);
2899
2900             when N_Op_Not    => Resolve_Op_Not                   (N, Ctx_Type);
2901
2902             when N_Op_Add    | N_Op_Subtract | N_Op_Multiply |
2903                  N_Op_Divide | N_Op_Mod      | N_Op_Rem
2904
2905                              => Resolve_Arithmetic_Op            (N, Ctx_Type);
2906
2907             when N_Op_Concat => Resolve_Op_Concat                (N, Ctx_Type);
2908
2909             when N_Op_Expon  => Resolve_Op_Expon                 (N, Ctx_Type);
2910
2911             when N_Op_Plus | N_Op_Minus  | N_Op_Abs
2912                              => Resolve_Unary_Op                 (N, Ctx_Type);
2913
2914             when N_Op_Shift  => Resolve_Shift                    (N, Ctx_Type);
2915
2916             when N_Procedure_Call_Statement
2917                              => Resolve_Call                     (N, Ctx_Type);
2918
2919             when N_Operator_Symbol
2920                              => Resolve_Operator_Symbol          (N, Ctx_Type);
2921
2922             when N_Qualified_Expression
2923                              => Resolve_Qualified_Expression     (N, Ctx_Type);
2924
2925             --  Why is the following null, needs a comment ???
2926
2927             when N_Quantified_Expression
2928                              => null;
2929
2930             when N_Raise_Expression
2931                              => Resolve_Raise_Expression         (N, Ctx_Type);
2932
2933             when N_Raise_xxx_Error
2934                              => Set_Etype (N, Ctx_Type);
2935
2936             when N_Range     => Resolve_Range                    (N, Ctx_Type);
2937
2938             when N_Real_Literal
2939                              => Resolve_Real_Literal             (N, Ctx_Type);
2940
2941             when N_Reference => Resolve_Reference                (N, Ctx_Type);
2942
2943             when N_Selected_Component
2944                              => Resolve_Selected_Component       (N, Ctx_Type);
2945
2946             when N_Slice     => Resolve_Slice                    (N, Ctx_Type);
2947
2948             when N_String_Literal
2949                              => Resolve_String_Literal           (N, Ctx_Type);
2950
2951             when N_Type_Conversion
2952                              => Resolve_Type_Conversion          (N, Ctx_Type);
2953
2954             when N_Unchecked_Expression =>
2955                Resolve_Unchecked_Expression                      (N, Ctx_Type);
2956
2957             when N_Unchecked_Type_Conversion =>
2958                Resolve_Unchecked_Type_Conversion                 (N, Ctx_Type);
2959          end case;
2960
2961          --  Ada 2012 (AI05-0149): Apply an (implicit) conversion to an
2962          --  expression of an anonymous access type that occurs in the context
2963          --  of a named general access type, except when the expression is that
2964          --  of a membership test. This ensures proper legality checking in
2965          --  terms of allowed conversions (expressions that would be illegal to
2966          --  convert implicitly are allowed in membership tests).
2967
2968          if Ada_Version >= Ada_2012
2969            and then Ekind (Ctx_Type) = E_General_Access_Type
2970            and then Ekind (Etype (N)) = E_Anonymous_Access_Type
2971            and then Nkind (Parent (N)) not in N_Membership_Test
2972          then
2973             Rewrite (N, Convert_To (Ctx_Type, Relocate_Node (N)));
2974             Analyze_And_Resolve (N, Ctx_Type);
2975          end if;
2976
2977          --  If the subexpression was replaced by a non-subexpression, then
2978          --  all we do is to expand it. The only legitimate case we know of
2979          --  is converting procedure call statement to entry call statements,
2980          --  but there may be others, so we are making this test general.
2981
2982          if Nkind (N) not in N_Subexpr then
2983             Debug_A_Exit ("resolving  ", N, "  (done)");
2984             Expand (N);
2985             Ghost_Mode := Save_Ghost_Mode;
2986             return;
2987          end if;
2988
2989          --  The expression is definitely NOT overloaded at this point, so
2990          --  we reset the Is_Overloaded flag to avoid any confusion when
2991          --  reanalyzing the node.
2992
2993          Set_Is_Overloaded (N, False);
2994
2995          --  Freeze expression type, entity if it is a name, and designated
2996          --  type if it is an allocator (RM 13.14(10,11,13)).
2997
2998          --  Now that the resolution of the type of the node is complete, and
2999          --  we did not detect an error, we can expand this node. We skip the
3000          --  expand call if we are in a default expression, see section
3001          --  "Handling of Default Expressions" in Sem spec.
3002
3003          Debug_A_Exit ("resolving  ", N, "  (done)");
3004
3005          --  We unconditionally freeze the expression, even if we are in
3006          --  default expression mode (the Freeze_Expression routine tests this
3007          --  flag and only freezes static types if it is set).
3008
3009          --  Ada 2012 (AI05-177): The declaration of an expression function
3010          --  does not cause freezing, but we never reach here in that case.
3011          --  Here we are resolving the corresponding expanded body, so we do
3012          --  need to perform normal freezing.
3013
3014          Freeze_Expression (N);
3015
3016          --  Now we can do the expansion
3017
3018          Expand (N);
3019       end if;
3020
3021       Ghost_Mode := Save_Ghost_Mode;
3022    end Resolve;
3023
3024    -------------
3025    -- Resolve --
3026    -------------
3027
3028    --  Version with check(s) suppressed
3029
3030    procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
3031    begin
3032       if Suppress = All_Checks then
3033          declare
3034             Sva : constant Suppress_Array := Scope_Suppress.Suppress;
3035          begin
3036             Scope_Suppress.Suppress := (others => True);
3037             Resolve (N, Typ);
3038             Scope_Suppress.Suppress := Sva;
3039          end;
3040
3041       else
3042          declare
3043             Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
3044          begin
3045             Scope_Suppress.Suppress (Suppress) := True;
3046             Resolve (N, Typ);
3047             Scope_Suppress.Suppress (Suppress) := Svg;
3048          end;
3049       end if;
3050    end Resolve;
3051
3052    -------------
3053    -- Resolve --
3054    -------------
3055
3056    --  Version with implicit type
3057
3058    procedure Resolve (N : Node_Id) is
3059    begin
3060       Resolve (N, Etype (N));
3061    end Resolve;
3062
3063    ---------------------
3064    -- Resolve_Actuals --
3065    ---------------------
3066
3067    procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
3068       Loc    : constant Source_Ptr := Sloc (N);
3069       A      : Node_Id;
3070       A_Id   : Entity_Id;
3071       A_Typ  : Entity_Id;
3072       F      : Entity_Id;
3073       F_Typ  : Entity_Id;
3074       Prev   : Node_Id := Empty;
3075       Orig_A : Node_Id;
3076       Real_F : Entity_Id;
3077
3078       Real_Subp : Entity_Id;
3079       --  If the subprogram being called is an inherited operation for
3080       --  a formal derived type in an instance, Real_Subp is the subprogram
3081       --  that will be called. It may have different formal names than the
3082       --  operation of the formal in the generic, so after actual is resolved
3083       --  the name of the actual in a named association must carry the name
3084       --  of the actual of the subprogram being called.
3085
3086       procedure Check_Aliased_Parameter;
3087       --  Check rules on aliased parameters and related accessibility rules
3088       --  in (RM 3.10.2 (10.2-10.4)).
3089
3090       procedure Check_Argument_Order;
3091       --  Performs a check for the case where the actuals are all simple
3092       --  identifiers that correspond to the formal names, but in the wrong
3093       --  order, which is considered suspicious and cause for a warning.
3094
3095       procedure Check_Prefixed_Call;
3096       --  If the original node is an overloaded call in prefix notation,
3097       --  insert an 'Access or a dereference as needed over the first actual.
3098       --  Try_Object_Operation has already verified that there is a valid
3099       --  interpretation, but the form of the actual can only be determined
3100       --  once the primitive operation is identified.
3101
3102       procedure Insert_Default;
3103       --  If the actual is missing in a call, insert in the actuals list
3104       --  an instance of the default expression. The insertion is always
3105       --  a named association.
3106
3107       procedure Property_Error
3108         (Var      : Node_Id;
3109          Var_Id   : Entity_Id;
3110          Prop_Nam : Name_Id);
3111       --  Emit an error concerning variable Var with entity Var_Id that has
3112       --  enabled property Prop_Nam when it acts as an actual parameter in a
3113       --  call and the corresponding formal parameter is of mode IN.
3114
3115       function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
3116       --  Check whether T1 and T2, or their full views, are derived from a
3117       --  common type. Used to enforce the restrictions on array conversions
3118       --  of AI95-00246.
3119
3120       function Static_Concatenation (N : Node_Id) return Boolean;
3121       --  Predicate to determine whether an actual that is a concatenation
3122       --  will be evaluated statically and does not need a transient scope.
3123       --  This must be determined before the actual is resolved and expanded
3124       --  because if needed the transient scope must be introduced earlier.
3125
3126       -----------------------------
3127       -- Check_Aliased_Parameter --
3128       -----------------------------
3129
3130       procedure Check_Aliased_Parameter is
3131          Nominal_Subt : Entity_Id;
3132
3133       begin
3134          if Is_Aliased (F) then
3135             if Is_Tagged_Type (A_Typ) then
3136                null;
3137
3138             elsif Is_Aliased_View (A) then
3139                if Is_Constr_Subt_For_U_Nominal (A_Typ) then
3140                   Nominal_Subt := Base_Type (A_Typ);
3141                else
3142                   Nominal_Subt := A_Typ;
3143                end if;
3144
3145                if Subtypes_Statically_Match (F_Typ, Nominal_Subt) then
3146                   null;
3147
3148                --  In a generic body assume the worst for generic formals:
3149                --  they can have a constrained partial view (AI05-041).
3150
3151                elsif Has_Discriminants (F_Typ)
3152                  and then not Is_Constrained (F_Typ)
3153                  and then not Has_Constrained_Partial_View (F_Typ)
3154                  and then not Is_Generic_Type (F_Typ)
3155                then
3156                   null;
3157
3158                else
3159                   Error_Msg_NE ("untagged actual does not match "
3160                                 & "aliased formal&", A, F);
3161                end if;
3162
3163             else
3164                Error_Msg_NE ("actual for aliased formal& must be "
3165                              & "aliased object", A, F);
3166             end if;
3167
3168             if Ekind (Nam) = E_Procedure then
3169                null;
3170
3171             elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then
3172                if Nkind (Parent (N)) = N_Type_Conversion
3173                  and then Type_Access_Level (Etype (Parent (N))) <
3174                                                         Object_Access_Level (A)
3175                then
3176                   Error_Msg_N ("aliased actual has wrong accessibility", A);
3177                end if;
3178
3179             elsif Nkind (Parent (N)) = N_Qualified_Expression
3180               and then Nkind (Parent (Parent (N))) = N_Allocator
3181               and then Type_Access_Level (Etype (Parent (Parent (N)))) <
3182                                                         Object_Access_Level (A)
3183             then
3184                Error_Msg_N
3185                  ("aliased actual in allocator has wrong accessibility", A);
3186             end if;
3187          end if;
3188       end Check_Aliased_Parameter;
3189
3190       --------------------------
3191       -- Check_Argument_Order --
3192       --------------------------
3193
3194       procedure Check_Argument_Order is
3195       begin
3196          --  Nothing to do if no parameters, or original node is neither a
3197          --  function call nor a procedure call statement (happens in the
3198          --  operator-transformed-to-function call case), or the call does
3199          --  not come from source, or this warning is off.
3200
3201          if not Warn_On_Parameter_Order
3202            or else No (Parameter_Associations (N))
3203            or else Nkind (Original_Node (N)) not in N_Subprogram_Call
3204            or else not Comes_From_Source (N)
3205          then
3206             return;
3207          end if;
3208
3209          declare
3210             Nargs : constant Nat := List_Length (Parameter_Associations (N));
3211
3212          begin
3213             --  Nothing to do if only one parameter
3214
3215             if Nargs < 2 then
3216                return;
3217             end if;
3218
3219             --  Here if at least two arguments
3220
3221             declare
3222                Actuals : array (1 .. Nargs) of Node_Id;
3223                Actual  : Node_Id;
3224                Formal  : Node_Id;
3225
3226                Wrong_Order : Boolean := False;
3227                --  Set True if an out of order case is found
3228
3229             begin
3230                --  Collect identifier names of actuals, fail if any actual is
3231                --  not a simple identifier, and record max length of name.
3232
3233                Actual := First (Parameter_Associations (N));
3234                for J in Actuals'Range loop
3235                   if Nkind (Actual) /= N_Identifier then
3236                      return;
3237                   else
3238                      Actuals (J) := Actual;
3239                      Next (Actual);
3240                   end if;
3241                end loop;
3242
3243                --  If we got this far, all actuals are identifiers and the list
3244                --  of their names is stored in the Actuals array.
3245
3246                Formal := First_Formal (Nam);
3247                for J in Actuals'Range loop
3248
3249                   --  If we ran out of formals, that's odd, probably an error
3250                   --  which will be detected elsewhere, but abandon the search.
3251
3252                   if No (Formal) then
3253                      return;
3254                   end if;
3255
3256                   --  If name matches and is in order OK
3257
3258                   if Chars (Formal) = Chars (Actuals (J)) then
3259                      null;
3260
3261                   else
3262                      --  If no match, see if it is elsewhere in list and if so
3263                      --  flag potential wrong order if type is compatible.
3264
3265                      for K in Actuals'Range loop
3266                         if Chars (Formal) = Chars (Actuals (K))
3267                           and then
3268                             Has_Compatible_Type (Actuals (K), Etype (Formal))
3269                         then
3270                            Wrong_Order := True;
3271                            goto Continue;
3272                         end if;
3273                      end loop;
3274
3275                      --  No match
3276
3277                      return;
3278                   end if;
3279
3280                   <<Continue>> Next_Formal (Formal);
3281                end loop;
3282
3283                --  If Formals left over, also probably an error, skip warning
3284
3285                if Present (Formal) then
3286                   return;
3287                end if;
3288
3289                --  Here we give the warning if something was out of order
3290
3291                if Wrong_Order then
3292                   Error_Msg_N
3293                     ("?P?actuals for this call may be in wrong order", N);
3294                end if;
3295             end;
3296          end;
3297       end Check_Argument_Order;
3298
3299       -------------------------
3300       -- Check_Prefixed_Call --
3301       -------------------------
3302
3303       procedure Check_Prefixed_Call is
3304          Act    : constant Node_Id   := First_Actual (N);
3305          A_Type : constant Entity_Id := Etype (Act);
3306          F_Type : constant Entity_Id := Etype (First_Formal (Nam));
3307          Orig   : constant Node_Id := Original_Node (N);
3308          New_A  : Node_Id;
3309
3310       begin
3311          --  Check whether the call is a prefixed call, with or without
3312          --  additional actuals.
3313
3314          if Nkind (Orig) = N_Selected_Component
3315            or else
3316              (Nkind (Orig) = N_Indexed_Component
3317                and then Nkind (Prefix (Orig)) = N_Selected_Component
3318                and then Is_Entity_Name (Prefix (Prefix (Orig)))
3319                and then Is_Entity_Name (Act)
3320                and then Chars (Act) = Chars (Prefix (Prefix (Orig))))
3321          then
3322             if Is_Access_Type (A_Type)
3323               and then not Is_Access_Type (F_Type)
3324             then
3325                --  Introduce dereference on object in prefix
3326
3327                New_A :=
3328                  Make_Explicit_Dereference (Sloc (Act),
3329                    Prefix => Relocate_Node (Act));
3330                Rewrite (Act, New_A);
3331                Analyze (Act);
3332
3333             elsif Is_Access_Type (F_Type)
3334               and then not Is_Access_Type (A_Type)
3335             then
3336                --  Introduce an implicit 'Access in prefix
3337
3338                if not Is_Aliased_View (Act) then
3339                   Error_Msg_NE
3340                     ("object in prefixed call to& must be aliased "
3341                      & "(RM 4.1.3 (13 1/2))",
3342                     Prefix (Act), Nam);
3343                end if;
3344
3345                Rewrite (Act,
3346                  Make_Attribute_Reference (Loc,
3347                    Attribute_Name => Name_Access,
3348                    Prefix         => Relocate_Node (Act)));
3349             end if;
3350
3351             Analyze (Act);
3352          end if;
3353       end Check_Prefixed_Call;
3354
3355       --------------------
3356       -- Insert_Default --
3357       --------------------
3358
3359       procedure Insert_Default is
3360          Actval : Node_Id;
3361          Assoc  : Node_Id;
3362
3363       begin
3364          --  Missing argument in call, nothing to insert
3365
3366          if No (Default_Value (F)) then
3367             return;
3368
3369          else
3370             --  Note that we do a full New_Copy_Tree, so that any associated
3371             --  Itypes are properly copied. This may not be needed any more,
3372             --  but it does no harm as a safety measure. Defaults of a generic
3373             --  formal may be out of bounds of the corresponding actual (see
3374             --  cc1311b) and an additional check may be required.
3375
3376             Actval :=
3377               New_Copy_Tree
3378                 (Default_Value (F),
3379                  New_Scope => Current_Scope,
3380                  New_Sloc  => Loc);
3381
3382             if Is_Concurrent_Type (Scope (Nam))
3383               and then Has_Discriminants (Scope (Nam))
3384             then
3385                Replace_Actual_Discriminants (N, Actval);
3386             end if;
3387
3388             if Is_Overloadable (Nam)
3389               and then Present (Alias (Nam))
3390             then
3391                if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
3392                  and then not Is_Tagged_Type (Etype (F))
3393                then
3394                   --  If default is a real literal, do not introduce a
3395                   --  conversion whose effect may depend on the run-time
3396                   --  size of universal real.
3397
3398                   if Nkind (Actval) = N_Real_Literal then
3399                      Set_Etype (Actval, Base_Type (Etype (F)));
3400                   else
3401                      Actval := Unchecked_Convert_To (Etype (F), Actval);
3402                   end if;
3403                end if;
3404
3405                if Is_Scalar_Type (Etype (F)) then
3406                   Enable_Range_Check (Actval);
3407                end if;
3408
3409                Set_Parent (Actval, N);
3410
3411                --  Resolve aggregates with their base type, to avoid scope
3412                --  anomalies: the subtype was first built in the subprogram
3413                --  declaration, and the current call may be nested.
3414
3415                if Nkind (Actval) = N_Aggregate then
3416                   Analyze_And_Resolve (Actval, Etype (F));
3417                else
3418                   Analyze_And_Resolve (Actval, Etype (Actval));
3419                end if;
3420
3421             else
3422                Set_Parent (Actval, N);
3423
3424                --  See note above concerning aggregates
3425
3426                if Nkind (Actval) = N_Aggregate
3427                  and then Has_Discriminants (Etype (Actval))
3428                then
3429                   Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
3430
3431                --  Resolve entities with their own type, which may differ from
3432                --  the type of a reference in a generic context (the view
3433                --  swapping mechanism did not anticipate the re-analysis of
3434                --  default values in calls).
3435
3436                elsif Is_Entity_Name (Actval) then
3437                   Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
3438
3439                else
3440                   Analyze_And_Resolve (Actval, Etype (Actval));
3441                end if;
3442             end if;
3443
3444             --  If default is a tag indeterminate function call, propagate tag
3445             --  to obtain proper dispatching.
3446
3447             if Is_Controlling_Formal (F)
3448               and then Nkind (Default_Value (F)) = N_Function_Call
3449             then
3450                Set_Is_Controlling_Actual (Actval);
3451             end if;
3452
3453          end if;
3454
3455          --  If the default expression raises constraint error, then just
3456          --  silently replace it with an N_Raise_Constraint_Error node, since
3457          --  we already gave the warning on the subprogram spec. If node is
3458          --  already a Raise_Constraint_Error leave as is, to prevent loops in
3459          --  the warnings removal machinery.
3460
3461          if Raises_Constraint_Error (Actval)
3462            and then Nkind (Actval) /= N_Raise_Constraint_Error
3463          then
3464             Rewrite (Actval,
3465               Make_Raise_Constraint_Error (Loc,
3466                 Reason => CE_Range_Check_Failed));
3467             Set_Raises_Constraint_Error (Actval);
3468             Set_Etype (Actval, Etype (F));
3469          end if;
3470
3471          Assoc :=
3472            Make_Parameter_Association (Loc,
3473              Explicit_Actual_Parameter => Actval,
3474              Selector_Name => Make_Identifier (Loc, Chars (F)));
3475
3476          --  Case of insertion is first named actual
3477
3478          if No (Prev) or else
3479             Nkind (Parent (Prev)) /= N_Parameter_Association
3480          then
3481             Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
3482             Set_First_Named_Actual (N, Actval);
3483
3484             if No (Prev) then
3485                if No (Parameter_Associations (N)) then
3486                   Set_Parameter_Associations (N, New_List (Assoc));
3487                else
3488                   Append (Assoc, Parameter_Associations (N));
3489                end if;
3490
3491             else
3492                Insert_After (Prev, Assoc);
3493             end if;
3494
3495          --  Case of insertion is not first named actual
3496
3497          else
3498             Set_Next_Named_Actual
3499               (Assoc, Next_Named_Actual (Parent (Prev)));
3500             Set_Next_Named_Actual (Parent (Prev), Actval);
3501             Append (Assoc, Parameter_Associations (N));
3502          end if;
3503
3504          Mark_Rewrite_Insertion (Assoc);
3505          Mark_Rewrite_Insertion (Actval);
3506
3507          Prev := Actval;
3508       end Insert_Default;
3509
3510       --------------------
3511       -- Property_Error --
3512       --------------------
3513
3514       procedure Property_Error
3515         (Var      : Node_Id;
3516          Var_Id   : Entity_Id;
3517          Prop_Nam : Name_Id)
3518       is
3519       begin
3520          Error_Msg_Name_1 := Prop_Nam;
3521          Error_Msg_NE
3522            ("external variable & with enabled property % cannot appear as "
3523             & "actual in procedure call (SPARK RM 7.1.3(11))", Var, Var_Id);
3524          Error_Msg_N ("\\corresponding formal parameter has mode In", Var);
3525       end Property_Error;
3526
3527       -------------------
3528       -- Same_Ancestor --
3529       -------------------
3530
3531       function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is
3532          FT1 : Entity_Id := T1;
3533          FT2 : Entity_Id := T2;
3534
3535       begin
3536          if Is_Private_Type (T1)
3537            and then Present (Full_View (T1))
3538          then
3539             FT1 := Full_View (T1);
3540          end if;
3541
3542          if Is_Private_Type (T2)
3543            and then Present (Full_View (T2))
3544          then
3545             FT2 := Full_View (T2);
3546          end if;
3547
3548          return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
3549       end Same_Ancestor;
3550
3551       --------------------------
3552       -- Static_Concatenation --
3553       --------------------------
3554
3555       function Static_Concatenation (N : Node_Id) return Boolean is
3556       begin
3557          case Nkind (N) is
3558             when N_String_Literal =>
3559                return True;
3560
3561             when N_Op_Concat =>
3562
3563                --  Concatenation is static when both operands are static and
3564                --  the concatenation operator is a predefined one.
3565
3566                return Scope (Entity (N)) = Standard_Standard
3567                         and then
3568                       Static_Concatenation (Left_Opnd (N))
3569                         and then
3570                       Static_Concatenation (Right_Opnd (N));
3571
3572             when others =>
3573                if Is_Entity_Name (N) then
3574                   declare
3575                      Ent : constant Entity_Id := Entity (N);
3576                   begin
3577                      return Ekind (Ent) = E_Constant
3578                               and then Present (Constant_Value (Ent))
3579                               and then
3580                                 Is_OK_Static_Expression (Constant_Value (Ent));
3581                   end;
3582
3583                else
3584                   return False;
3585                end if;
3586          end case;
3587       end Static_Concatenation;
3588
3589    --  Start of processing for Resolve_Actuals
3590
3591    begin
3592       Check_Argument_Order;
3593
3594       if Is_Overloadable (Nam)
3595         and then Is_Inherited_Operation (Nam)
3596         and then In_Instance
3597         and then Present (Alias (Nam))
3598         and then Present (Overridden_Operation (Alias (Nam)))
3599       then
3600          Real_Subp := Alias (Nam);
3601       else
3602          Real_Subp := Empty;
3603       end if;
3604
3605       if Present (First_Actual (N)) then
3606          Check_Prefixed_Call;
3607       end if;
3608
3609       A := First_Actual (N);
3610       F := First_Formal (Nam);
3611
3612       if Present (Real_Subp) then
3613          Real_F := First_Formal (Real_Subp);
3614       end if;
3615
3616       while Present (F) loop
3617          if No (A) and then Needs_No_Actuals (Nam) then
3618             null;
3619
3620          --  If we have an error in any actual or formal, indicated by a type
3621          --  of Any_Type, then abandon resolution attempt, and set result type
3622          --  to Any_Type. Skip this if the actual is a Raise_Expression, whose
3623          --  type is imposed from context.
3624
3625          elsif (Present (A) and then Etype (A) = Any_Type)
3626            or else Etype (F) = Any_Type
3627          then
3628             if Nkind (A) /= N_Raise_Expression then
3629                Set_Etype (N, Any_Type);
3630                return;
3631             end if;
3632          end if;
3633
3634          --  Case where actual is present
3635
3636          --  If the actual is an entity, generate a reference to it now. We
3637          --  do this before the actual is resolved, because a formal of some
3638          --  protected subprogram, or a task discriminant, will be rewritten
3639          --  during expansion, and the source entity reference may be lost.
3640
3641          if Present (A)
3642            and then Is_Entity_Name (A)
3643            and then Comes_From_Source (N)
3644          then
3645             Orig_A := Entity (A);
3646
3647             if Present (Orig_A) then
3648                if Is_Formal (Orig_A)
3649                  and then Ekind (F) /= E_In_Parameter
3650                then
3651                   Generate_Reference (Orig_A, A, 'm');
3652
3653                elsif not Is_Overloaded (A) then
3654                   if Ekind (F) /= E_Out_Parameter then
3655                      Generate_Reference (Orig_A, A);
3656
3657                   --  RM 6.4.1(12): For an out parameter that is passed by
3658                   --  copy, the formal parameter object is created, and:
3659
3660                   --  * For an access type, the formal parameter is initialized
3661                   --    from the value of the actual, without checking that the
3662                   --    value satisfies any constraint, any predicate, or any
3663                   --    exclusion of the null value.
3664
3665                   --  * For a scalar type that has the Default_Value aspect
3666                   --    specified, the formal parameter is initialized from the
3667                   --    value of the actual, without checking that the value
3668                   --    satisfies any constraint or any predicate.
3669                   --  I do not understand why this case is included??? this is
3670                   --  not a case where an OUT parameter is treated as IN OUT.
3671
3672                   --  * For a composite type with discriminants or that has
3673                   --    implicit initial values for any subcomponents, the
3674                   --    behavior is as for an in out parameter passed by copy.
3675
3676                   --  Hence for these cases we generate the read reference now
3677                   --  (the write reference will be generated later by
3678                   --   Note_Possible_Modification).
3679
3680                   elsif Is_By_Copy_Type (Etype (F))
3681                     and then
3682                       (Is_Access_Type (Etype (F))
3683                          or else
3684                            (Is_Scalar_Type (Etype (F))
3685                               and then
3686                                 Present (Default_Aspect_Value (Etype (F))))
3687                          or else
3688                            (Is_Composite_Type (Etype (F))
3689                               and then (Has_Discriminants (Etype (F))
3690                                          or else Is_Partially_Initialized_Type
3691                                                    (Etype (F)))))
3692                   then
3693                      Generate_Reference (Orig_A, A);
3694                   end if;
3695                end if;
3696             end if;
3697          end if;
3698
3699          if Present (A)
3700            and then (Nkind (Parent (A)) /= N_Parameter_Association
3701                       or else Chars (Selector_Name (Parent (A))) = Chars (F))
3702          then
3703             --  If style checking mode on, check match of formal name
3704
3705             if Style_Check then
3706                if Nkind (Parent (A)) = N_Parameter_Association then
3707                   Check_Identifier (Selector_Name (Parent (A)), F);
3708                end if;
3709             end if;
3710
3711             --  If the formal is Out or In_Out, do not resolve and expand the
3712             --  conversion, because it is subsequently expanded into explicit
3713             --  temporaries and assignments. However, the object of the
3714             --  conversion can be resolved. An exception is the case of tagged
3715             --  type conversion with a class-wide actual. In that case we want
3716             --  the tag check to occur and no temporary will be needed (no
3717             --  representation change can occur) and the parameter is passed by
3718             --  reference, so we go ahead and resolve the type conversion.
3719             --  Another exception is the case of reference to component or
3720             --  subcomponent of a bit-packed array, in which case we want to
3721             --  defer expansion to the point the in and out assignments are
3722             --  performed.
3723
3724             if Ekind (F) /= E_In_Parameter
3725               and then Nkind (A) = N_Type_Conversion
3726               and then not Is_Class_Wide_Type (Etype (Expression (A)))
3727             then
3728                if Ekind (F) = E_In_Out_Parameter
3729                  and then Is_Array_Type (Etype (F))
3730                then
3731                   --  In a view conversion, the conversion must be legal in
3732                   --  both directions, and thus both component types must be
3733                   --  aliased, or neither (4.6 (8)).
3734
3735                   --  The extra rule in 4.6 (24.9.2) seems unduly restrictive:
3736                   --  the privacy requirement should not apply to generic
3737                   --  types, and should be checked in an instance. ARG query
3738                   --  is in order ???
3739
3740                   if Has_Aliased_Components (Etype (Expression (A))) /=
3741                      Has_Aliased_Components (Etype (F))
3742                   then
3743                      Error_Msg_N
3744                        ("both component types in a view conversion must be"
3745                          & " aliased, or neither", A);
3746
3747                   --  Comment here??? what set of cases???
3748
3749                   elsif
3750                      not Same_Ancestor (Etype (F), Etype (Expression (A)))
3751                   then
3752                      --  Check view conv between unrelated by ref array types
3753
3754                      if Is_By_Reference_Type (Etype (F))
3755                         or else Is_By_Reference_Type (Etype (Expression (A)))
3756                      then
3757                         Error_Msg_N
3758                           ("view conversion between unrelated by reference "
3759                            & "array types not allowed (\'A'I-00246)", A);
3760
3761                      --  In Ada 2005 mode, check view conversion component
3762                      --  type cannot be private, tagged, or volatile. Note
3763                      --  that we only apply this to source conversions. The
3764                      --  generated code can contain conversions which are
3765                      --  not subject to this test, and we cannot extract the
3766                      --  component type in such cases since it is not present.
3767
3768                      elsif Comes_From_Source (A)
3769                        and then Ada_Version >= Ada_2005
3770                      then
3771                         declare
3772                            Comp_Type : constant Entity_Id :=
3773                                          Component_Type
3774                                            (Etype (Expression (A)));
3775                         begin
3776                            if (Is_Private_Type (Comp_Type)
3777                                  and then not Is_Generic_Type (Comp_Type))
3778                              or else Is_Tagged_Type (Comp_Type)
3779                              or else Is_Volatile (Comp_Type)
3780                            then
3781                               Error_Msg_N
3782                                 ("component type of a view conversion cannot"
3783                                    & " be private, tagged, or volatile"
3784                                    & " (RM 4.6 (24))",
3785                                    Expression (A));
3786                            end if;
3787                         end;
3788                      end if;
3789                   end if;
3790                end if;
3791
3792                --  Resolve expression if conversion is all OK
3793
3794                if (Conversion_OK (A)
3795                     or else Valid_Conversion (A, Etype (A), Expression (A)))
3796                  and then not Is_Ref_To_Bit_Packed_Array (Expression (A))
3797                then
3798                   Resolve (Expression (A));
3799                end if;
3800
3801             --  If the actual is a function call that returns a limited
3802             --  unconstrained object that needs finalization, create a
3803             --  transient scope for it, so that it can receive the proper
3804             --  finalization list.
3805
3806             elsif Nkind (A) = N_Function_Call
3807               and then Is_Limited_Record (Etype (F))
3808               and then not Is_Constrained (Etype (F))
3809               and then Expander_Active
3810               and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
3811             then
3812                Establish_Transient_Scope (A, Sec_Stack => False);
3813                Resolve (A, Etype (F));
3814
3815             --  A small optimization: if one of the actuals is a concatenation
3816             --  create a block around a procedure call to recover stack space.
3817             --  This alleviates stack usage when several procedure calls in
3818             --  the same statement list use concatenation. We do not perform
3819             --  this wrapping for code statements, where the argument is a
3820             --  static string, and we want to preserve warnings involving
3821             --  sequences of such statements.
3822
3823             elsif Nkind (A) = N_Op_Concat
3824               and then Nkind (N) = N_Procedure_Call_Statement
3825               and then Expander_Active
3826               and then
3827                 not (Is_Intrinsic_Subprogram (Nam)
3828                       and then Chars (Nam) = Name_Asm)
3829               and then not Static_Concatenation (A)
3830             then
3831                Establish_Transient_Scope (A, Sec_Stack => False);
3832                Resolve (A, Etype (F));
3833
3834             else
3835                if Nkind (A) = N_Type_Conversion
3836                  and then Is_Array_Type (Etype (F))
3837                  and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
3838                  and then
3839                   (Is_Limited_Type (Etype (F))
3840                     or else Is_Limited_Type (Etype (Expression (A))))
3841                then
3842                   Error_Msg_N
3843                     ("conversion between unrelated limited array types "
3844                      & "not allowed ('A'I-00246)", A);
3845
3846                   if Is_Limited_Type (Etype (F)) then
3847                      Explain_Limited_Type (Etype (F), A);
3848                   end if;
3849
3850                   if Is_Limited_Type (Etype (Expression (A))) then
3851                      Explain_Limited_Type (Etype (Expression (A)), A);
3852                   end if;
3853                end if;
3854
3855                --  (Ada 2005: AI-251): If the actual is an allocator whose
3856                --  directly designated type is a class-wide interface, we build
3857                --  an anonymous access type to use it as the type of the
3858                --  allocator. Later, when the subprogram call is expanded, if
3859                --  the interface has a secondary dispatch table the expander
3860                --  will add a type conversion to force the correct displacement
3861                --  of the pointer.
3862
3863                if Nkind (A) = N_Allocator then
3864                   declare
3865                      DDT : constant Entity_Id :=
3866                              Directly_Designated_Type (Base_Type (Etype (F)));
3867
3868                      New_Itype : Entity_Id;
3869
3870                   begin
3871                      if Is_Class_Wide_Type (DDT)
3872                        and then Is_Interface (DDT)
3873                      then
3874                         New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
3875                         Set_Etype (New_Itype, Etype (A));
3876                         Set_Directly_Designated_Type
3877                           (New_Itype, Directly_Designated_Type (Etype (A)));
3878                         Set_Etype (A, New_Itype);
3879                      end if;
3880
3881                      --  Ada 2005, AI-162:If the actual is an allocator, the
3882                      --  innermost enclosing statement is the master of the
3883                      --  created object. This needs to be done with expansion
3884                      --  enabled only, otherwise the transient scope will not
3885                      --  be removed in the expansion of the wrapped construct.
3886
3887                      if (Is_Controlled (DDT) or else Has_Task (DDT))
3888                        and then Expander_Active
3889                      then
3890                         Establish_Transient_Scope (A, Sec_Stack => False);
3891                      end if;
3892                   end;
3893
3894                   if Ekind (Etype (F)) = E_Anonymous_Access_Type then
3895                      Check_Restriction (No_Access_Parameter_Allocators, A);
3896                   end if;
3897                end if;
3898
3899                --  (Ada 2005): The call may be to a primitive operation of a
3900                --  tagged synchronized type, declared outside of the type. In
3901                --  this case the controlling actual must be converted to its
3902                --  corresponding record type, which is the formal type. The
3903                --  actual may be a subtype, either because of a constraint or
3904                --  because it is a generic actual, so use base type to locate
3905                --  concurrent type.
3906
3907                F_Typ := Base_Type (Etype (F));
3908
3909                if Is_Tagged_Type (F_Typ)
3910                  and then (Is_Concurrent_Type (F_Typ)
3911                             or else Is_Concurrent_Record_Type (F_Typ))
3912                then
3913                   --  If the actual is overloaded, look for an interpretation
3914                   --  that has a synchronized type.
3915
3916                   if not Is_Overloaded (A) then
3917                      A_Typ := Base_Type (Etype (A));
3918
3919                   else
3920                      declare
3921                         Index : Interp_Index;
3922                         It    : Interp;
3923
3924                      begin
3925                         Get_First_Interp (A, Index, It);
3926                         while Present (It.Typ) loop
3927                            if Is_Concurrent_Type (It.Typ)
3928                              or else Is_Concurrent_Record_Type (It.Typ)
3929                            then
3930                               A_Typ := Base_Type (It.Typ);
3931                               exit;
3932                            end if;
3933
3934                            Get_Next_Interp (Index, It);
3935                         end loop;
3936                      end;
3937                   end if;
3938
3939                   declare
3940                      Full_A_Typ : Entity_Id;
3941
3942                   begin
3943                      if Present (Full_View (A_Typ)) then
3944                         Full_A_Typ := Base_Type (Full_View (A_Typ));
3945                      else
3946                         Full_A_Typ := A_Typ;
3947                      end if;
3948
3949                      --  Tagged synchronized type (case 1): the actual is a
3950                      --  concurrent type.
3951
3952                      if Is_Concurrent_Type (A_Typ)
3953                        and then Corresponding_Record_Type (A_Typ) = F_Typ
3954                      then
3955                         Rewrite (A,
3956                           Unchecked_Convert_To
3957                             (Corresponding_Record_Type (A_Typ), A));
3958                         Resolve (A, Etype (F));
3959
3960                      --  Tagged synchronized type (case 2): the formal is a
3961                      --  concurrent type.
3962
3963                      elsif Ekind (Full_A_Typ) = E_Record_Type
3964                        and then Present
3965                                (Corresponding_Concurrent_Type (Full_A_Typ))
3966                        and then Is_Concurrent_Type (F_Typ)
3967                        and then Present (Corresponding_Record_Type (F_Typ))
3968                        and then Full_A_Typ = Corresponding_Record_Type (F_Typ)
3969                      then
3970                         Resolve (A, Corresponding_Record_Type (F_Typ));
3971
3972                      --  Common case
3973
3974                      else
3975                         Resolve (A, Etype (F));
3976                      end if;
3977                   end;
3978
3979                --  Not a synchronized operation
3980
3981                else
3982                   Resolve (A, Etype (F));
3983                end if;
3984             end if;
3985
3986             A_Typ := Etype (A);
3987             F_Typ := Etype (F);
3988
3989             --  An actual cannot be an untagged formal incomplete type
3990
3991             if Ekind (A_Typ) = E_Incomplete_Type
3992               and then not Is_Tagged_Type (A_Typ)
3993               and then Is_Generic_Type (A_Typ)
3994             then
3995                Error_Msg_N
3996                  ("invalid use of untagged formal incomplete type", A);
3997             end if;
3998
3999             if Comes_From_Source (Original_Node (N))
4000               and then Nkind_In (Original_Node (N), N_Function_Call,
4001                                                     N_Procedure_Call_Statement)
4002             then
4003                --  In formal mode, check that actual parameters matching
4004                --  formals of tagged types are objects (or ancestor type
4005                --  conversions of objects), not general expressions.
4006
4007                if Is_Actual_Tagged_Parameter (A) then
4008                   if Is_SPARK_05_Object_Reference (A) then
4009                      null;
4010
4011                   elsif Nkind (A) = N_Type_Conversion then
4012                      declare
4013                         Operand     : constant Node_Id   := Expression (A);
4014                         Operand_Typ : constant Entity_Id := Etype (Operand);
4015                         Target_Typ  : constant Entity_Id := A_Typ;
4016
4017                      begin
4018                         if not Is_SPARK_05_Object_Reference (Operand) then
4019                            Check_SPARK_05_Restriction
4020                              ("object required", Operand);
4021
4022                         --  In formal mode, the only view conversions are those
4023                         --  involving ancestor conversion of an extended type.
4024
4025                         elsif not
4026                           (Is_Tagged_Type (Target_Typ)
4027                            and then not Is_Class_Wide_Type (Target_Typ)
4028                            and then Is_Tagged_Type (Operand_Typ)
4029                            and then not Is_Class_Wide_Type (Operand_Typ)
4030                            and then Is_Ancestor (Target_Typ, Operand_Typ))
4031                         then
4032                            if Ekind_In
4033                              (F, E_Out_Parameter, E_In_Out_Parameter)
4034                            then
4035                               Check_SPARK_05_Restriction
4036                                 ("ancestor conversion is the only permitted "
4037                                  & "view conversion", A);
4038                            else
4039                               Check_SPARK_05_Restriction
4040                                 ("ancestor conversion required", A);
4041                            end if;
4042
4043                         else
4044                            null;
4045                         end if;
4046                      end;
4047
4048                   else
4049                      Check_SPARK_05_Restriction ("object required", A);
4050                   end if;
4051
4052                --  In formal mode, the only view conversions are those
4053                --  involving ancestor conversion of an extended type.
4054
4055                elsif Nkind (A) = N_Type_Conversion
4056                  and then Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter)
4057                then
4058                   Check_SPARK_05_Restriction
4059                     ("ancestor conversion is the only permitted view "
4060                      & "conversion", A);
4061                end if;
4062             end if;
4063
4064             --  has warnings suppressed, then we reset Never_Set_In_Source for
4065             --  the calling entity. The reason for this is to catch cases like
4066             --  GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram
4067             --  uses trickery to modify an IN parameter.
4068
4069             if Ekind (F) = E_In_Parameter
4070               and then Is_Entity_Name (A)
4071               and then Present (Entity (A))
4072               and then Ekind (Entity (A)) = E_Variable
4073               and then Has_Warnings_Off (F_Typ)
4074             then
4075                Set_Never_Set_In_Source (Entity (A), False);
4076             end if;
4077
4078             --  Perform error checks for IN and IN OUT parameters
4079
4080             if Ekind (F) /= E_Out_Parameter then
4081
4082                --  Check unset reference. For scalar parameters, it is clearly
4083                --  wrong to pass an uninitialized value as either an IN or
4084                --  IN-OUT parameter. For composites, it is also clearly an
4085                --  error to pass a completely uninitialized value as an IN
4086                --  parameter, but the case of IN OUT is trickier. We prefer
4087                --  not to give a warning here. For example, suppose there is
4088                --  a routine that sets some component of a record to False.
4089                --  It is perfectly reasonable to make this IN-OUT and allow
4090                --  either initialized or uninitialized records to be passed
4091                --  in this case.
4092
4093                --  For partially initialized composite values, we also avoid
4094                --  warnings, since it is quite likely that we are passing a
4095                --  partially initialized value and only the initialized fields
4096                --  will in fact be read in the subprogram.
4097
4098                if Is_Scalar_Type (A_Typ)
4099                  or else (Ekind (F) = E_In_Parameter
4100                            and then not Is_Partially_Initialized_Type (A_Typ))
4101                then
4102                   Check_Unset_Reference (A);
4103                end if;
4104
4105                --  In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT
4106                --  actual to a nested call, since this constitutes a reading of
4107                --  the parameter, which is not allowed.
4108
4109                if Ada_Version = Ada_83
4110                  and then Is_Entity_Name (A)
4111                  and then Ekind (Entity (A)) = E_Out_Parameter
4112                then
4113                   Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
4114                end if;
4115             end if;
4116
4117             --  Case of OUT or IN OUT parameter
4118
4119             if Ekind (F) /= E_In_Parameter then
4120
4121                --  For an Out parameter, check for useless assignment. Note
4122                --  that we can't set Last_Assignment this early, because we may
4123                --  kill current values in Resolve_Call, and that call would
4124                --  clobber the Last_Assignment field.
4125
4126                --  Note: call Warn_On_Useless_Assignment before doing the check
4127                --  below for Is_OK_Variable_For_Out_Formal so that the setting
4128                --  of Referenced_As_LHS/Referenced_As_Out_Formal properly
4129                --  reflects the last assignment, not this one.
4130
4131                if Ekind (F) = E_Out_Parameter then
4132                   if Warn_On_Modified_As_Out_Parameter (F)
4133                     and then Is_Entity_Name (A)
4134                     and then Present (Entity (A))
4135                     and then Comes_From_Source (N)
4136                   then
4137                      Warn_On_Useless_Assignment (Entity (A), A);
4138                   end if;
4139                end if;
4140
4141                --  Validate the form of the actual. Note that the call to
4142                --  Is_OK_Variable_For_Out_Formal generates the required
4143                --  reference in this case.
4144
4145                --  A call to an initialization procedure for an aggregate
4146                --  component may initialize a nested component of a constant
4147                --  designated object. In this context the object is variable.
4148
4149                if not Is_OK_Variable_For_Out_Formal (A)
4150                  and then not Is_Init_Proc (Nam)
4151                then
4152                   Error_Msg_NE ("actual for& must be a variable", A, F);
4153
4154                   if Is_Subprogram (Current_Scope)
4155                     and then
4156                       (Is_Invariant_Procedure (Current_Scope)
4157                         or else Is_Predicate_Function (Current_Scope))
4158                   then
4159                      Error_Msg_N
4160                        ("function used in predicate cannot "
4161                         & "modify its argument", F);
4162                   end if;
4163                end if;
4164
4165                --  What's the following about???
4166
4167                if Is_Entity_Name (A) then
4168                   Kill_Checks (Entity (A));
4169                else
4170                   Kill_All_Checks;
4171                end if;
4172             end if;
4173
4174             if Etype (A) = Any_Type then
4175                Set_Etype (N, Any_Type);
4176                return;
4177             end if;
4178
4179             --  Apply appropriate constraint/predicate checks for IN [OUT] case
4180
4181             if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then
4182
4183                --  Apply predicate tests except in certain special cases. Note
4184                --  that it might be more consistent to apply these only when
4185                --  expansion is active (in Exp_Ch6.Expand_Actuals), as we do
4186                --  for the outbound predicate tests ???
4187
4188                if Predicate_Tests_On_Arguments (Nam) then
4189                   Apply_Predicate_Check (A, F_Typ);
4190                end if;
4191
4192                --  Apply required constraint checks
4193
4194                --  Gigi looks at the check flag and uses the appropriate types.
4195                --  For now since one flag is used there is an optimization
4196                --  which might not be done in the IN OUT case since Gigi does
4197                --  not do any analysis. More thought required about this ???
4198
4199                --  In fact is this comment obsolete??? doesn't the expander now
4200                --  generate all these tests anyway???
4201
4202                if Is_Scalar_Type (Etype (A)) then
4203                   Apply_Scalar_Range_Check (A, F_Typ);
4204
4205                elsif Is_Array_Type (Etype (A)) then
4206                   Apply_Length_Check (A, F_Typ);
4207
4208                elsif Is_Record_Type (F_Typ)
4209                  and then Has_Discriminants (F_Typ)
4210                  and then Is_Constrained (F_Typ)
4211                  and then (not Is_Derived_Type (F_Typ)
4212                             or else Comes_From_Source (Nam))
4213                then
4214                   Apply_Discriminant_Check (A, F_Typ);
4215
4216                   --  For view conversions of a discriminated object, apply
4217                   --  check to object itself, the conversion alreay has the
4218                   --  proper type.
4219
4220                   if Nkind (A) = N_Type_Conversion
4221                     and then Is_Constrained (Etype (Expression (A)))
4222                   then
4223                      Apply_Discriminant_Check (Expression (A), F_Typ);
4224                   end if;
4225
4226                elsif Is_Access_Type (F_Typ)
4227                  and then Is_Array_Type (Designated_Type (F_Typ))
4228                  and then Is_Constrained (Designated_Type (F_Typ))
4229                then
4230                   Apply_Length_Check (A, F_Typ);
4231
4232                elsif Is_Access_Type (F_Typ)
4233                  and then Has_Discriminants (Designated_Type (F_Typ))
4234                  and then Is_Constrained (Designated_Type (F_Typ))
4235                then
4236                   Apply_Discriminant_Check (A, F_Typ);
4237
4238                else
4239                   Apply_Range_Check (A, F_Typ);
4240                end if;
4241
4242                --  Ada 2005 (AI-231): Note that the controlling parameter case
4243                --  already existed in Ada 95, which is partially checked
4244                --  elsewhere (see Checks), and we don't want the warning
4245                --  message to differ.
4246
4247                if Is_Access_Type (F_Typ)
4248                  and then Can_Never_Be_Null (F_Typ)
4249                  and then Known_Null (A)
4250                then
4251                   if Is_Controlling_Formal (F) then
4252                      Apply_Compile_Time_Constraint_Error
4253                        (N      => A,
4254                         Msg    => "null value not allowed here??",
4255                         Reason => CE_Access_Check_Failed);
4256
4257                   elsif Ada_Version >= Ada_2005 then
4258                      Apply_Compile_Time_Constraint_Error
4259                        (N      => A,
4260                         Msg    => "(Ada 2005) null not allowed in "
4261                                   & "null-excluding formal??",
4262                         Reason => CE_Null_Not_Allowed);
4263                   end if;
4264                end if;
4265             end if;
4266
4267             --  Checks for OUT parameters and IN OUT parameters
4268
4269             if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then
4270
4271                --  If there is a type conversion, to make sure the return value
4272                --  meets the constraints of the variable before the conversion.
4273
4274                if Nkind (A) = N_Type_Conversion then
4275                   if Is_Scalar_Type (A_Typ) then
4276                      Apply_Scalar_Range_Check
4277                        (Expression (A), Etype (Expression (A)), A_Typ);
4278                   else
4279                      Apply_Range_Check
4280                        (Expression (A), Etype (Expression (A)), A_Typ);
4281                   end if;
4282
4283                --  If no conversion apply scalar range checks and length checks
4284                --  base on the subtype of the actual (NOT that of the formal).
4285
4286                else
4287                   if Is_Scalar_Type (F_Typ) then
4288                      Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
4289                   elsif Is_Array_Type (F_Typ)
4290                     and then Ekind (F) = E_Out_Parameter
4291                   then
4292                      Apply_Length_Check (A, F_Typ);
4293                   else
4294                      Apply_Range_Check (A, A_Typ, F_Typ);
4295                   end if;
4296                end if;
4297
4298                --  Note: we do not apply the predicate checks for the case of
4299                --  OUT and IN OUT parameters. They are instead applied in the
4300                --  Expand_Actuals routine in Exp_Ch6.
4301             end if;
4302
4303             --  An actual associated with an access parameter is implicitly
4304             --  converted to the anonymous access type of the formal and must
4305             --  satisfy the legality checks for access conversions.
4306
4307             if Ekind (F_Typ) = E_Anonymous_Access_Type then
4308                if not Valid_Conversion (A, F_Typ, A) then
4309                   Error_Msg_N
4310                     ("invalid implicit conversion for access parameter", A);
4311                end if;
4312
4313                --  If the actual is an access selected component of a variable,
4314                --  the call may modify its designated object. It is reasonable
4315                --  to treat this as a potential modification of the enclosing
4316                --  record, to prevent spurious warnings that it should be
4317                --  declared as a constant, because intuitively programmers
4318                --  regard the designated subcomponent as part of the record.
4319
4320                if Nkind (A) = N_Selected_Component
4321                  and then Is_Entity_Name (Prefix (A))
4322                  and then not Is_Constant_Object (Entity (Prefix (A)))
4323                then
4324                   Note_Possible_Modification (A, Sure => False);
4325                end if;
4326             end if;
4327
4328             --  Check bad case of atomic/volatile argument (RM C.6(12))
4329
4330             if Is_By_Reference_Type (Etype (F))
4331               and then Comes_From_Source (N)
4332             then
4333                if Is_Atomic_Object (A)
4334                  and then not Is_Atomic (Etype (F))
4335                then
4336                   Error_Msg_NE
4337                     ("cannot pass atomic argument to non-atomic formal&",
4338                      A, F);
4339
4340                elsif Is_Volatile_Object (A)
4341                  and then not Is_Volatile (Etype (F))
4342                then
4343                   Error_Msg_NE
4344                     ("cannot pass volatile argument to non-volatile formal&",
4345                      A, F);
4346                end if;
4347             end if;
4348
4349             --  Check that subprograms don't have improper controlling
4350             --  arguments (RM 3.9.2 (9)).
4351
4352             --  A primitive operation may have an access parameter of an
4353             --  incomplete tagged type, but a dispatching call is illegal
4354             --  if the type is still incomplete.
4355
4356             if Is_Controlling_Formal (F) then
4357                Set_Is_Controlling_Actual (A);
4358
4359                if Ekind (Etype (F)) = E_Anonymous_Access_Type then
4360                   declare
4361                      Desig : constant Entity_Id := Designated_Type (Etype (F));
4362                   begin
4363                      if Ekind (Desig) = E_Incomplete_Type
4364                        and then No (Full_View (Desig))
4365                        and then No (Non_Limited_View (Desig))
4366                      then
4367                         Error_Msg_NE
4368                           ("premature use of incomplete type& "
4369                            & "in dispatching call", A, Desig);
4370                      end if;
4371                   end;
4372                end if;
4373
4374             elsif Nkind (A) = N_Explicit_Dereference then
4375                Validate_Remote_Access_To_Class_Wide_Type (A);
4376             end if;
4377
4378             --  Apply legality rule 3.9.2  (9/1)
4379
4380             if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
4381               and then not Is_Class_Wide_Type (F_Typ)
4382               and then not Is_Controlling_Formal (F)
4383               and then not In_Instance
4384             then
4385                Error_Msg_N ("class-wide argument not allowed here!", A);
4386
4387                if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then
4388                   Error_Msg_Node_2 := F_Typ;
4389                   Error_Msg_NE
4390                     ("& is not a dispatching operation of &!", A, Nam);
4391                end if;
4392
4393             --  Apply the checks described in 3.10.2(27): if the context is a
4394             --  specific access-to-object, the actual cannot be class-wide.
4395             --  Use base type to exclude access_to_subprogram cases.
4396
4397             elsif Is_Access_Type (A_Typ)
4398               and then Is_Access_Type (F_Typ)
4399               and then not Is_Access_Subprogram_Type (Base_Type (F_Typ))
4400               and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
4401                          or else (Nkind (A) = N_Attribute_Reference
4402                                    and then
4403                                      Is_Class_Wide_Type (Etype (Prefix (A)))))
4404               and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
4405               and then not Is_Controlling_Formal (F)
4406
4407               --  Disable these checks for call to imported C++ subprograms
4408
4409               and then not
4410                 (Is_Entity_Name (Name (N))
4411                   and then Is_Imported (Entity (Name (N)))
4412                   and then Convention (Entity (Name (N))) = Convention_CPP)
4413             then
4414                Error_Msg_N
4415                  ("access to class-wide argument not allowed here!", A);
4416
4417                if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then
4418                   Error_Msg_Node_2 := Designated_Type (F_Typ);
4419                   Error_Msg_NE
4420                     ("& is not a dispatching operation of &!", A, Nam);
4421                end if;
4422             end if;
4423
4424             Check_Aliased_Parameter;
4425
4426             Eval_Actual (A);
4427
4428             --  If it is a named association, treat the selector_name as a
4429             --  proper identifier, and mark the corresponding entity.
4430
4431             if Nkind (Parent (A)) = N_Parameter_Association
4432
4433               --  Ignore reference in SPARK mode, as it refers to an entity not
4434               --  in scope at the point of reference, so the reference should
4435               --  be ignored for computing effects of subprograms.
4436
4437               and then not GNATprove_Mode
4438             then
4439                --  If subprogram is overridden, use name of formal that
4440                --  is being called.
4441
4442                if Present (Real_Subp) then
4443                   Set_Entity (Selector_Name (Parent (A)), Real_F);
4444                   Set_Etype (Selector_Name (Parent (A)), Etype (Real_F));
4445
4446                else
4447                   Set_Entity (Selector_Name (Parent (A)), F);
4448                   Generate_Reference (F, Selector_Name (Parent (A)));
4449                   Set_Etype (Selector_Name (Parent (A)), F_Typ);
4450                   Generate_Reference (F_Typ, N, ' ');
4451                end if;
4452             end if;
4453
4454             Prev := A;
4455
4456             if Ekind (F) /= E_Out_Parameter then
4457                Check_Unset_Reference (A);
4458             end if;
4459
4460             --  The following checks are only relevant when SPARK_Mode is on as
4461             --  they are not standard Ada legality rule. Internally generated
4462             --  temporaries are ignored.
4463
4464             if SPARK_Mode = On
4465               and then Comes_From_Source (A)
4466               and then Is_Effectively_Volatile_Object (A)
4467             then
4468                --  An effectively volatile object may act as an actual when the
4469                --  corresponding formal is of a non-scalar effectively volatile
4470                --  type (SPARK RM 7.1.3(12)).
4471
4472                if not Is_Scalar_Type (Etype (F))
4473                  and then Is_Effectively_Volatile (Etype (F))
4474                then
4475                   null;
4476
4477                --  An effectively volatile object may act as an actual in a
4478                --  call to an instance of Unchecked_Conversion.
4479                --  (SPARK RM 7.1.3(12)).
4480
4481                elsif Is_Unchecked_Conversion_Instance (Nam) then
4482                   null;
4483
4484                else
4485                   Error_Msg_N
4486                     ("volatile object cannot act as actual in a call (SPARK "
4487                      & "RM 7.1.3(12))", A);
4488                end if;
4489
4490                --  Detect an external variable with an enabled property that
4491                --  does not match the mode of the corresponding formal in a
4492                --  procedure call. Functions are not considered because they
4493                --  cannot have effectively volatile formal parameters in the
4494                --  first place.
4495
4496                if Ekind (Nam) = E_Procedure
4497                  and then Ekind (F) = E_In_Parameter
4498                  and then Is_Entity_Name (A)
4499                  and then Present (Entity (A))
4500                  and then Ekind (Entity (A)) = E_Variable
4501                then
4502                   A_Id := Entity (A);
4503
4504                   if Async_Readers_Enabled (A_Id) then
4505                      Property_Error (A, A_Id, Name_Async_Readers);
4506                   elsif Effective_Reads_Enabled (A_Id) then
4507                      Property_Error (A, A_Id, Name_Effective_Reads);
4508                   elsif Effective_Writes_Enabled (A_Id) then
4509                      Property_Error (A, A_Id, Name_Effective_Writes);
4510                   end if;
4511                end if;
4512             end if;
4513
4514             --  A formal parameter of a specific tagged type whose related
4515             --  subprogram is subject to pragma Extensions_Visible with value
4516             --  "False" cannot act as an actual in a subprogram with value
4517             --  "True" (SPARK RM 6.1.7(3)).
4518
4519             if Is_EVF_Expression (A)
4520               and then Extensions_Visible_Status (Nam) =
4521                        Extensions_Visible_True
4522             then
4523                Error_Msg_N
4524                  ("formal parameter with Extensions_Visible False cannot act "
4525                   & "as actual parameter", A);
4526                Error_Msg_NE
4527                  ("\subprogram & has Extensions_Visible True", A, Nam);
4528             end if;
4529
4530             --  The actual parameter of a Ghost subprogram whose formal is of
4531             --  mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(13)).
4532
4533             if Comes_From_Source (Nam)
4534               and then Is_Ghost_Entity (Nam)
4535               and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter)
4536               and then Is_Entity_Name (A)
4537               and then Present (Entity (A))
4538               and then not Is_Ghost_Entity (Entity (A))
4539             then
4540                Error_Msg_NE
4541                  ("non-ghost variable & cannot appear as actual in call to "
4542                   & "ghost procedure", A, Entity (A));
4543
4544                if Ekind (F) = E_In_Out_Parameter then
4545                   Error_Msg_N ("\corresponding formal has mode `IN OUT`", A);
4546                else
4547                   Error_Msg_N ("\corresponding formal has mode OUT", A);
4548                end if;
4549             end if;
4550
4551             Next_Actual (A);
4552
4553          --  Case where actual is not present
4554
4555          else
4556             Insert_Default;
4557          end if;
4558
4559          Next_Formal (F);
4560
4561          if Present (Real_Subp) then
4562             Next_Formal (Real_F);
4563          end if;
4564       end loop;
4565    end Resolve_Actuals;
4566
4567    -----------------------
4568    -- Resolve_Allocator --
4569    -----------------------
4570
4571    procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
4572       Desig_T  : constant Entity_Id := Designated_Type (Typ);
4573       E        : constant Node_Id   := Expression (N);
4574       Subtyp   : Entity_Id;
4575       Discrim  : Entity_Id;
4576       Constr   : Node_Id;
4577       Aggr     : Node_Id;
4578       Assoc    : Node_Id := Empty;
4579       Disc_Exp : Node_Id;
4580
4581       procedure Check_Allocator_Discrim_Accessibility
4582         (Disc_Exp  : Node_Id;
4583          Alloc_Typ : Entity_Id);
4584       --  Check that accessibility level associated with an access discriminant
4585       --  initialized in an allocator by the expression Disc_Exp is not deeper
4586       --  than the level of the allocator type Alloc_Typ. An error message is
4587       --  issued if this condition is violated. Specialized checks are done for
4588       --  the cases of a constraint expression which is an access attribute or
4589       --  an access discriminant.
4590
4591       function In_Dispatching_Context return Boolean;
4592       --  If the allocator is an actual in a call, it is allowed to be class-
4593       --  wide when the context is not because it is a controlling actual.
4594
4595       -------------------------------------------
4596       -- Check_Allocator_Discrim_Accessibility --
4597       -------------------------------------------
4598
4599       procedure Check_Allocator_Discrim_Accessibility
4600         (Disc_Exp  : Node_Id;
4601          Alloc_Typ : Entity_Id)
4602       is
4603       begin
4604          if Type_Access_Level (Etype (Disc_Exp)) >
4605             Deepest_Type_Access_Level (Alloc_Typ)
4606          then
4607             Error_Msg_N
4608               ("operand type has deeper level than allocator type", Disc_Exp);
4609
4610          --  When the expression is an Access attribute the level of the prefix
4611          --  object must not be deeper than that of the allocator's type.
4612
4613          elsif Nkind (Disc_Exp) = N_Attribute_Reference
4614            and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) =
4615                       Attribute_Access
4616            and then Object_Access_Level (Prefix (Disc_Exp)) >
4617                       Deepest_Type_Access_Level (Alloc_Typ)
4618          then
4619             Error_Msg_N
4620               ("prefix of attribute has deeper level than allocator type",
4621                Disc_Exp);
4622
4623          --  When the expression is an access discriminant the check is against
4624          --  the level of the prefix object.
4625
4626          elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
4627            and then Nkind (Disc_Exp) = N_Selected_Component
4628            and then Object_Access_Level (Prefix (Disc_Exp)) >
4629                       Deepest_Type_Access_Level (Alloc_Typ)
4630          then
4631             Error_Msg_N
4632               ("access discriminant has deeper level than allocator type",
4633                Disc_Exp);
4634
4635          --  All other cases are legal
4636
4637          else
4638             null;
4639          end if;
4640       end Check_Allocator_Discrim_Accessibility;
4641
4642       ----------------------------
4643       -- In_Dispatching_Context --
4644       ----------------------------
4645
4646       function In_Dispatching_Context return Boolean is
4647          Par : constant Node_Id := Parent (N);
4648
4649       begin
4650          return Nkind (Par) in N_Subprogram_Call
4651            and then Is_Entity_Name (Name (Par))
4652            and then Is_Dispatching_Operation (Entity (Name (Par)));
4653       end In_Dispatching_Context;
4654
4655    --  Start of processing for Resolve_Allocator
4656
4657    begin
4658       --  Replace general access with specific type
4659
4660       if Ekind (Etype (N)) = E_Allocator_Type then
4661          Set_Etype (N, Base_Type (Typ));
4662       end if;
4663
4664       if Is_Abstract_Type (Typ) then
4665          Error_Msg_N ("type of allocator cannot be abstract",  N);
4666       end if;
4667
4668       --  For qualified expression, resolve the expression using the given
4669       --  subtype (nothing to do for type mark, subtype indication)
4670
4671       if Nkind (E) = N_Qualified_Expression then
4672          if Is_Class_Wide_Type (Etype (E))
4673            and then not Is_Class_Wide_Type (Desig_T)
4674            and then not In_Dispatching_Context
4675          then
4676             Error_Msg_N
4677               ("class-wide allocator not allowed for this access type", N);
4678          end if;
4679
4680          Resolve (Expression (E), Etype (E));
4681          Check_Non_Static_Context (Expression (E));
4682          Check_Unset_Reference (Expression (E));
4683
4684          --  Allocators generated by the build-in-place expansion mechanism
4685          --  are explicitly marked as coming from source but do not need to be
4686          --  checked for limited initialization. To exclude this case, ensure
4687          --  that the parent of the allocator is a source node.
4688
4689          if Is_Limited_Type (Etype (E))
4690            and then Comes_From_Source (N)
4691            and then Comes_From_Source (Parent (N))
4692            and then not In_Instance_Body
4693          then
4694             if not OK_For_Limited_Init (Etype (E), Expression (E)) then
4695                Error_Msg_N ("initialization not allowed for limited types", N);
4696                Explain_Limited_Type (Etype (E), N);
4697             end if;
4698          end if;
4699
4700          --  A qualified expression requires an exact match of the type.
4701          --  Class-wide matching is not allowed.
4702
4703          if (Is_Class_Wide_Type (Etype (Expression (E)))
4704               or else Is_Class_Wide_Type (Etype (E)))
4705            and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
4706          then
4707             Wrong_Type (Expression (E), Etype (E));
4708          end if;
4709
4710          --  Calls to build-in-place functions are not currently supported in
4711          --  allocators for access types associated with a simple storage pool.
4712          --  Supporting such allocators may require passing additional implicit
4713          --  parameters to build-in-place functions (or a significant revision
4714          --  of the current b-i-p implementation to unify the handling for
4715          --  multiple kinds of storage pools). ???
4716
4717          if Is_Limited_View (Desig_T)
4718            and then Nkind (Expression (E)) = N_Function_Call
4719          then
4720             declare
4721                Pool : constant Entity_Id :=
4722                         Associated_Storage_Pool (Root_Type (Typ));
4723             begin
4724                if Present (Pool)
4725                  and then
4726                    Present (Get_Rep_Pragma
4727                               (Etype (Pool), Name_Simple_Storage_Pool_Type))
4728                then
4729                   Error_Msg_N
4730                     ("limited function calls not yet supported in simple "
4731                      & "storage pool allocators", Expression (E));
4732                end if;
4733             end;
4734          end if;
4735
4736          --  A special accessibility check is needed for allocators that
4737          --  constrain access discriminants. The level of the type of the
4738          --  expression used to constrain an access discriminant cannot be
4739          --  deeper than the type of the allocator (in contrast to access
4740          --  parameters, where the level of the actual can be arbitrary).
4741
4742          --  We can't use Valid_Conversion to perform this check because in
4743          --  general the type of the allocator is unrelated to the type of
4744          --  the access discriminant.
4745
4746          if Ekind (Typ) /= E_Anonymous_Access_Type
4747            or else Is_Local_Anonymous_Access (Typ)
4748          then
4749             Subtyp := Entity (Subtype_Mark (E));
4750
4751             Aggr := Original_Node (Expression (E));
4752
4753             if Has_Discriminants (Subtyp)
4754               and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate)
4755             then
4756                Discrim := First_Discriminant (Base_Type (Subtyp));
4757
4758                --  Get the first component expression of the aggregate
4759
4760                if Present (Expressions (Aggr)) then
4761                   Disc_Exp := First (Expressions (Aggr));
4762
4763                elsif Present (Component_Associations (Aggr)) then
4764                   Assoc := First (Component_Associations (Aggr));
4765
4766                   if Present (Assoc) then
4767                      Disc_Exp := Expression (Assoc);
4768                   else
4769                      Disc_Exp := Empty;
4770                   end if;
4771
4772                else
4773                   Disc_Exp := Empty;
4774                end if;
4775
4776                while Present (Discrim) and then Present (Disc_Exp) loop
4777                   if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
4778                      Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ);
4779                   end if;
4780
4781                   Next_Discriminant (Discrim);
4782
4783                   if Present (Discrim) then
4784                      if Present (Assoc) then
4785                         Next (Assoc);
4786                         Disc_Exp := Expression (Assoc);
4787
4788                      elsif Present (Next (Disc_Exp)) then
4789                         Next (Disc_Exp);
4790
4791                      else
4792                         Assoc := First (Component_Associations (Aggr));
4793
4794                         if Present (Assoc) then
4795                            Disc_Exp := Expression (Assoc);
4796                         else
4797                            Disc_Exp := Empty;
4798                         end if;
4799                      end if;
4800                   end if;
4801                end loop;
4802             end if;
4803          end if;
4804
4805       --  For a subtype mark or subtype indication, freeze the subtype
4806
4807       else
4808          Freeze_Expression (E);
4809
4810          if Is_Access_Constant (Typ) and then not No_Initialization (N) then
4811             Error_Msg_N
4812               ("initialization required for access-to-constant allocator", N);
4813          end if;
4814
4815          --  A special accessibility check is needed for allocators that
4816          --  constrain access discriminants. The level of the type of the
4817          --  expression used to constrain an access discriminant cannot be
4818          --  deeper than the type of the allocator (in contrast to access
4819          --  parameters, where the level of the actual can be arbitrary).
4820          --  We can't use Valid_Conversion to perform this check because
4821          --  in general the type of the allocator is unrelated to the type
4822          --  of the access discriminant.
4823
4824          if Nkind (Original_Node (E)) = N_Subtype_Indication
4825            and then (Ekind (Typ) /= E_Anonymous_Access_Type
4826                       or else Is_Local_Anonymous_Access (Typ))
4827          then
4828             Subtyp := Entity (Subtype_Mark (Original_Node (E)));
4829
4830             if Has_Discriminants (Subtyp) then
4831                Discrim := First_Discriminant (Base_Type (Subtyp));
4832                Constr := First (Constraints (Constraint (Original_Node (E))));
4833                while Present (Discrim) and then Present (Constr) loop
4834                   if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
4835                      if Nkind (Constr) = N_Discriminant_Association then
4836                         Disc_Exp := Original_Node (Expression (Constr));
4837                      else
4838                         Disc_Exp := Original_Node (Constr);
4839                      end if;
4840
4841                      Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ);
4842                   end if;
4843
4844                   Next_Discriminant (Discrim);
4845                   Next (Constr);
4846                end loop;
4847             end if;
4848          end if;
4849       end if;
4850
4851       --  Ada 2005 (AI-344): A class-wide allocator requires an accessibility
4852       --  check that the level of the type of the created object is not deeper
4853       --  than the level of the allocator's access type, since extensions can
4854       --  now occur at deeper levels than their ancestor types. This is a
4855       --  static accessibility level check; a run-time check is also needed in
4856       --  the case of an initialized allocator with a class-wide argument (see
4857       --  Expand_Allocator_Expression).
4858
4859       if Ada_Version >= Ada_2005
4860         and then Is_Class_Wide_Type (Desig_T)
4861       then
4862          declare
4863             Exp_Typ : Entity_Id;
4864
4865          begin
4866             if Nkind (E) = N_Qualified_Expression then
4867                Exp_Typ := Etype (E);
4868             elsif Nkind (E) = N_Subtype_Indication then
4869                Exp_Typ := Entity (Subtype_Mark (Original_Node (E)));
4870             else
4871                Exp_Typ := Entity (E);
4872             end if;
4873
4874             if Type_Access_Level (Exp_Typ) >
4875                  Deepest_Type_Access_Level (Typ)
4876             then
4877                if In_Instance_Body then
4878                   Error_Msg_Warn := SPARK_Mode /= On;
4879                   Error_Msg_N
4880                     ("type in allocator has deeper level than "
4881                      & "designated class-wide type<<", E);
4882                   Error_Msg_N ("\Program_Error [<<", E);
4883                   Rewrite (N,
4884                     Make_Raise_Program_Error (Sloc (N),
4885                       Reason => PE_Accessibility_Check_Failed));
4886                   Set_Etype (N, Typ);
4887
4888                --  Do not apply Ada 2005 accessibility checks on a class-wide
4889                --  allocator if the type given in the allocator is a formal
4890                --  type. A run-time check will be performed in the instance.
4891
4892                elsif not Is_Generic_Type (Exp_Typ) then
4893                   Error_Msg_N ("type in allocator has deeper level than "
4894                                & "designated class-wide type", E);
4895                end if;
4896             end if;
4897          end;
4898       end if;
4899
4900       --  Check for allocation from an empty storage pool
4901
4902       if No_Pool_Assigned (Typ) then
4903          Error_Msg_N ("allocation from empty storage pool!", N);
4904
4905       --  If the context is an unchecked conversion, as may happen within an
4906       --  inlined subprogram, the allocator is being resolved with its own
4907       --  anonymous type. In that case, if the target type has a specific
4908       --  storage pool, it must be inherited explicitly by the allocator type.
4909
4910       elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
4911         and then No (Associated_Storage_Pool (Typ))
4912       then
4913          Set_Associated_Storage_Pool
4914            (Typ, Associated_Storage_Pool (Etype (Parent (N))));
4915       end if;
4916
4917       if Ekind (Etype (N)) = E_Anonymous_Access_Type then
4918          Check_Restriction (No_Anonymous_Allocators, N);
4919       end if;
4920
4921       --  Check that an allocator with task parts isn't for a nested access
4922       --  type when restriction No_Task_Hierarchy applies.
4923
4924       if not Is_Library_Level_Entity (Base_Type (Typ))
4925         and then Has_Task (Base_Type (Desig_T))
4926       then
4927          Check_Restriction (No_Task_Hierarchy, N);
4928       end if;
4929
4930       --  An illegal allocator may be rewritten as a raise Program_Error
4931       --  statement.
4932
4933       if Nkind (N) = N_Allocator then
4934
4935          --  An anonymous access discriminant is the definition of a
4936          --  coextension.
4937
4938          if Ekind (Typ) = E_Anonymous_Access_Type
4939            and then Nkind (Associated_Node_For_Itype (Typ)) =
4940                       N_Discriminant_Specification
4941          then
4942             declare
4943                Discr : constant Entity_Id :=
4944                          Defining_Identifier (Associated_Node_For_Itype (Typ));
4945
4946             begin
4947                Check_Restriction (No_Coextensions, N);
4948
4949                --  Ada 2012 AI05-0052: If the designated type of the allocator
4950                --  is limited, then the allocator shall not be used to define
4951                --  the value of an access discriminant unless the discriminated
4952                --  type is immutably limited.
4953
4954                if Ada_Version >= Ada_2012
4955                  and then Is_Limited_Type (Desig_T)
4956                  and then not Is_Limited_View (Scope (Discr))
4957                then
4958                   Error_Msg_N
4959                     ("only immutably limited types can have anonymous "
4960                      & "access discriminants designating a limited type", N);
4961                end if;
4962             end;
4963
4964             --  Avoid marking an allocator as a dynamic coextension if it is
4965             --  within a static construct.
4966
4967             if not Is_Static_Coextension (N) then
4968                Set_Is_Dynamic_Coextension (N);
4969             end if;
4970
4971          --  Cleanup for potential static coextensions
4972
4973          else
4974             Set_Is_Dynamic_Coextension (N, False);
4975             Set_Is_Static_Coextension  (N, False);
4976          end if;
4977       end if;
4978
4979       --  Report a simple error: if the designated object is a local task,
4980       --  its body has not been seen yet, and its activation will fail an
4981       --  elaboration check.
4982
4983       if Is_Task_Type (Desig_T)
4984         and then Scope (Base_Type (Desig_T)) = Current_Scope
4985         and then Is_Compilation_Unit (Current_Scope)
4986         and then Ekind (Current_Scope) = E_Package
4987         and then not In_Package_Body (Current_Scope)
4988       then
4989          Error_Msg_Warn := SPARK_Mode /= On;
4990          Error_Msg_N ("cannot activate task before body seen<<", N);
4991          Error_Msg_N ("\Program_Error [<<", N);
4992       end if;
4993
4994       --  Ada 2012 (AI05-0111-3): Detect an attempt to allocate a task or a
4995       --  type with a task component on a subpool. This action must raise
4996       --  Program_Error at runtime.
4997
4998       if Ada_Version >= Ada_2012
4999         and then Nkind (N) = N_Allocator
5000         and then Present (Subpool_Handle_Name (N))
5001         and then Has_Task (Desig_T)
5002       then
5003          Error_Msg_Warn := SPARK_Mode /= On;
5004          Error_Msg_N ("cannot allocate task on subpool<<", N);
5005          Error_Msg_N ("\Program_Error [<<", N);
5006
5007          Rewrite (N,
5008            Make_Raise_Program_Error (Sloc (N),
5009              Reason => PE_Explicit_Raise));
5010          Set_Etype (N, Typ);
5011       end if;
5012    end Resolve_Allocator;
5013
5014    ---------------------------
5015    -- Resolve_Arithmetic_Op --
5016    ---------------------------
5017
5018    --  Used for resolving all arithmetic operators except exponentiation
5019
5020    procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
5021       L   : constant Node_Id := Left_Opnd (N);
5022       R   : constant Node_Id := Right_Opnd (N);
5023       TL  : constant Entity_Id := Base_Type (Etype (L));
5024       TR  : constant Entity_Id := Base_Type (Etype (R));
5025       T   : Entity_Id;
5026       Rop : Node_Id;
5027
5028       B_Typ : constant Entity_Id := Base_Type (Typ);
5029       --  We do the resolution using the base type, because intermediate values
5030       --  in expressions always are of the base type, not a subtype of it.
5031
5032       function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean;
5033       --  Returns True if N is in a context that expects "any real type"
5034
5035       function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
5036       --  Return True iff given type is Integer or universal real/integer
5037
5038       procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
5039       --  Choose type of integer literal in fixed-point operation to conform
5040       --  to available fixed-point type. T is the type of the other operand,
5041       --  which is needed to determine the expected type of N.
5042
5043       procedure Set_Operand_Type (N : Node_Id);
5044       --  Set operand type to T if universal
5045
5046       -------------------------------
5047       -- Expected_Type_Is_Any_Real --
5048       -------------------------------
5049
5050       function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is
5051       begin
5052          --  N is the expression after "delta" in a fixed_point_definition;
5053          --  see RM-3.5.9(6):
5054
5055          return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition,
5056                                       N_Decimal_Fixed_Point_Definition,
5057
5058          --  N is one of the bounds in a real_range_specification;
5059          --  see RM-3.5.7(5):
5060
5061                                       N_Real_Range_Specification,
5062
5063          --  N is the expression of a delta_constraint;
5064          --  see RM-J.3(3):
5065
5066                                       N_Delta_Constraint);
5067       end Expected_Type_Is_Any_Real;
5068
5069       -----------------------------
5070       -- Is_Integer_Or_Universal --
5071       -----------------------------
5072
5073       function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
5074          T     : Entity_Id;
5075          Index : Interp_Index;
5076          It    : Interp;
5077
5078       begin
5079          if not Is_Overloaded (N) then
5080             T := Etype (N);
5081             return Base_Type (T) = Base_Type (Standard_Integer)
5082               or else T = Universal_Integer
5083               or else T = Universal_Real;
5084          else
5085             Get_First_Interp (N, Index, It);
5086             while Present (It.Typ) loop
5087                if Base_Type (It.Typ) = Base_Type (Standard_Integer)
5088                  or else It.Typ = Universal_Integer
5089                  or else It.Typ = Universal_Real
5090                then
5091                   return True;
5092                end if;
5093
5094                Get_Next_Interp (Index, It);
5095             end loop;
5096          end if;
5097
5098          return False;
5099       end Is_Integer_Or_Universal;
5100
5101       ----------------------------
5102       -- Set_Mixed_Mode_Operand --
5103       ----------------------------
5104
5105       procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
5106          Index : Interp_Index;
5107          It    : Interp;
5108
5109       begin
5110          if Universal_Interpretation (N) = Universal_Integer then
5111
5112             --  A universal integer literal is resolved as standard integer
5113             --  except in the case of a fixed-point result, where we leave it
5114             --  as universal (to be handled by Exp_Fixd later on)
5115
5116             if Is_Fixed_Point_Type (T) then
5117                Resolve (N, Universal_Integer);
5118             else
5119                Resolve (N, Standard_Integer);
5120             end if;
5121
5122          elsif Universal_Interpretation (N) = Universal_Real
5123            and then (T = Base_Type (Standard_Integer)
5124                       or else T = Universal_Integer
5125                       or else T = Universal_Real)
5126          then
5127             --  A universal real can appear in a fixed-type context. We resolve
5128             --  the literal with that context, even though this might raise an
5129             --  exception prematurely (the other operand may be zero).
5130
5131             Resolve (N, B_Typ);
5132
5133          elsif Etype (N) = Base_Type (Standard_Integer)
5134            and then T = Universal_Real
5135            and then Is_Overloaded (N)
5136          then
5137             --  Integer arg in mixed-mode operation. Resolve with universal
5138             --  type, in case preference rule must be applied.
5139
5140             Resolve (N, Universal_Integer);
5141
5142          elsif Etype (N) = T
5143            and then B_Typ /= Universal_Fixed
5144          then
5145             --  Not a mixed-mode operation, resolve with context
5146
5147             Resolve (N, B_Typ);
5148
5149          elsif Etype (N) = Any_Fixed then
5150
5151             --  N may itself be a mixed-mode operation, so use context type
5152
5153             Resolve (N, B_Typ);
5154
5155          elsif Is_Fixed_Point_Type (T)
5156            and then B_Typ = Universal_Fixed
5157            and then Is_Overloaded (N)
5158          then
5159             --  Must be (fixed * fixed) operation, operand must have one
5160             --  compatible interpretation.
5161
5162             Resolve (N, Any_Fixed);
5163
5164          elsif Is_Fixed_Point_Type (B_Typ)
5165            and then (T = Universal_Real or else Is_Fixed_Point_Type (T))
5166            and then Is_Overloaded (N)
5167          then
5168             --  C * F(X) in a fixed context, where C is a real literal or a
5169             --  fixed-point expression. F must have either a fixed type
5170             --  interpretation or an integer interpretation, but not both.
5171
5172             Get_First_Interp (N, Index, It);
5173             while Present (It.Typ) loop
5174                if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
5175                   if Analyzed (N) then
5176                      Error_Msg_N ("ambiguous operand in fixed operation", N);
5177                   else
5178                      Resolve (N, Standard_Integer);
5179                   end if;
5180
5181                elsif Is_Fixed_Point_Type (It.Typ) then
5182                   if Analyzed (N) then
5183                      Error_Msg_N ("ambiguous operand in fixed operation", N);
5184                   else
5185                      Resolve (N, It.Typ);
5186                   end if;
5187                end if;
5188
5189                Get_Next_Interp (Index, It);
5190             end loop;
5191
5192             --  Reanalyze the literal with the fixed type of the context. If
5193             --  context is Universal_Fixed, we are within a conversion, leave
5194             --  the literal as a universal real because there is no usable
5195             --  fixed type, and the target of the conversion plays no role in
5196             --  the resolution.
5197
5198             declare
5199                Op2 : Node_Id;
5200                T2  : Entity_Id;
5201
5202             begin
5203                if N = L then
5204                   Op2 := R;
5205                else
5206                   Op2 := L;
5207                end if;
5208
5209                if B_Typ = Universal_Fixed
5210                   and then Nkind (Op2) = N_Real_Literal
5211                then
5212                   T2 := Universal_Real;
5213                else
5214                   T2 := B_Typ;
5215                end if;
5216
5217                Set_Analyzed (Op2, False);
5218                Resolve (Op2, T2);
5219             end;
5220
5221          else
5222             Resolve (N);
5223          end if;
5224       end Set_Mixed_Mode_Operand;
5225
5226       ----------------------
5227       -- Set_Operand_Type --
5228       ----------------------
5229
5230       procedure Set_Operand_Type (N : Node_Id) is
5231       begin
5232          if Etype (N) = Universal_Integer
5233            or else Etype (N) = Universal_Real
5234          then
5235             Set_Etype (N, T);
5236          end if;
5237       end Set_Operand_Type;
5238
5239    --  Start of processing for Resolve_Arithmetic_Op
5240
5241    begin
5242       if Comes_From_Source (N)
5243         and then Ekind (Entity (N)) = E_Function
5244         and then Is_Imported (Entity (N))
5245         and then Is_Intrinsic_Subprogram (Entity (N))
5246       then
5247          Resolve_Intrinsic_Operator (N, Typ);
5248          return;
5249
5250       --  Special-case for mixed-mode universal expressions or fixed point type
5251       --  operation: each argument is resolved separately. The same treatment
5252       --  is required if one of the operands of a fixed point operation is
5253       --  universal real, since in this case we don't do a conversion to a
5254       --  specific fixed-point type (instead the expander handles the case).
5255
5256       --  Set the type of the node to its universal interpretation because
5257       --  legality checks on an exponentiation operand need the context.
5258
5259       elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
5260         and then Present (Universal_Interpretation (L))
5261         and then Present (Universal_Interpretation (R))
5262       then
5263          Set_Etype (N, B_Typ);
5264          Resolve (L, Universal_Interpretation (L));
5265          Resolve (R, Universal_Interpretation (R));
5266
5267       elsif (B_Typ = Universal_Real
5268               or else Etype (N) = Universal_Fixed
5269               or else (Etype (N) = Any_Fixed
5270                         and then Is_Fixed_Point_Type (B_Typ))
5271               or else (Is_Fixed_Point_Type (B_Typ)
5272                         and then (Is_Integer_Or_Universal (L)
5273                                     or else
5274                                   Is_Integer_Or_Universal (R))))
5275         and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
5276       then
5277          if TL = Universal_Integer or else TR = Universal_Integer then
5278             Check_For_Visible_Operator (N, B_Typ);
5279          end if;
5280
5281          --  If context is a fixed type and one operand is integer, the other
5282          --  is resolved with the type of the context.
5283
5284          if Is_Fixed_Point_Type (B_Typ)
5285            and then (Base_Type (TL) = Base_Type (Standard_Integer)
5286                       or else TL = Universal_Integer)
5287          then
5288             Resolve (R, B_Typ);
5289             Resolve (L, TL);
5290
5291          elsif Is_Fixed_Point_Type (B_Typ)
5292            and then (Base_Type (TR) = Base_Type (Standard_Integer)
5293                       or else TR = Universal_Integer)
5294          then
5295             Resolve (L, B_Typ);
5296             Resolve (R, TR);
5297
5298          else
5299             Set_Mixed_Mode_Operand (L, TR);
5300             Set_Mixed_Mode_Operand (R, TL);
5301          end if;
5302
5303          --  Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed
5304          --  multiplying operators from being used when the expected type is
5305          --  also universal_fixed. Note that B_Typ will be Universal_Fixed in
5306          --  some cases where the expected type is actually Any_Real;
5307          --  Expected_Type_Is_Any_Real takes care of that case.
5308
5309          if Etype (N) = Universal_Fixed
5310            or else Etype (N) = Any_Fixed
5311          then
5312             if B_Typ = Universal_Fixed
5313               and then not Expected_Type_Is_Any_Real (N)
5314               and then not Nkind_In (Parent (N), N_Type_Conversion,
5315                                                  N_Unchecked_Type_Conversion)
5316             then
5317                Error_Msg_N ("type cannot be determined from context!", N);
5318                Error_Msg_N ("\explicit conversion to result type required", N);
5319
5320                Set_Etype (L, Any_Type);
5321                Set_Etype (R, Any_Type);
5322
5323             else
5324                if Ada_Version = Ada_83
5325                  and then Etype (N) = Universal_Fixed
5326                  and then not
5327                    Nkind_In (Parent (N), N_Type_Conversion,
5328                                          N_Unchecked_Type_Conversion)
5329                then
5330                   Error_Msg_N
5331                     ("(Ada 83) fixed-point operation needs explicit "
5332                      & "conversion", N);
5333                end if;
5334
5335                --  The expected type is "any real type" in contexts like
5336
5337                --    type T is delta <universal_fixed-expression> ...
5338
5339                --  in which case we need to set the type to Universal_Real
5340                --  so that static expression evaluation will work properly.
5341
5342                if Expected_Type_Is_Any_Real (N) then
5343                   Set_Etype (N, Universal_Real);
5344                else
5345                   Set_Etype (N, B_Typ);
5346                end if;
5347             end if;
5348
5349          elsif Is_Fixed_Point_Type (B_Typ)
5350            and then (Is_Integer_Or_Universal (L)
5351                        or else Nkind (L) = N_Real_Literal
5352                        or else Nkind (R) = N_Real_Literal
5353                        or else Is_Integer_Or_Universal (R))
5354          then
5355             Set_Etype (N, B_Typ);
5356
5357          elsif Etype (N) = Any_Fixed then
5358
5359             --  If no previous errors, this is only possible if one operand is
5360             --  overloaded and the context is universal. Resolve as such.
5361
5362             Set_Etype (N, B_Typ);
5363          end if;
5364
5365       else
5366          if (TL = Universal_Integer or else TL = Universal_Real)
5367                and then
5368             (TR = Universal_Integer or else TR = Universal_Real)
5369          then
5370             Check_For_Visible_Operator (N, B_Typ);
5371          end if;
5372
5373          --  If the context is Universal_Fixed and the operands are also
5374          --  universal fixed, this is an error, unless there is only one
5375          --  applicable fixed_point type (usually Duration).
5376
5377          if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then
5378             T := Unique_Fixed_Point_Type (N);
5379
5380             if T  = Any_Type then
5381                Set_Etype (N, T);
5382                return;
5383             else
5384                Resolve (L, T);
5385                Resolve (R, T);
5386             end if;
5387
5388          else
5389             Resolve (L, B_Typ);
5390             Resolve (R, B_Typ);
5391          end if;
5392
5393          --  If one of the arguments was resolved to a non-universal type.
5394          --  label the result of the operation itself with the same type.
5395          --  Do the same for the universal argument, if any.
5396
5397          T := Intersect_Types (L, R);
5398          Set_Etype (N, Base_Type (T));
5399          Set_Operand_Type (L);
5400          Set_Operand_Type (R);
5401       end if;
5402
5403       Generate_Operator_Reference (N, Typ);
5404       Analyze_Dimension (N);
5405       Eval_Arithmetic_Op (N);
5406
5407       --  In SPARK, a multiplication or division with operands of fixed point
5408       --  types must be qualified or explicitly converted to identify the
5409       --  result type.
5410
5411       if (Is_Fixed_Point_Type (Etype (L))
5412            or else Is_Fixed_Point_Type (Etype (R)))
5413         and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
5414         and then
5415           not Nkind_In (Parent (N), N_Qualified_Expression, N_Type_Conversion)
5416       then
5417          Check_SPARK_05_Restriction
5418            ("operation should be qualified or explicitly converted", N);
5419       end if;
5420
5421       --  Set overflow and division checking bit
5422
5423       if Nkind (N) in N_Op then
5424          if not Overflow_Checks_Suppressed (Etype (N)) then
5425             Enable_Overflow_Check (N);
5426          end if;
5427
5428          --  Give warning if explicit division by zero
5429
5430          if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod)
5431            and then not Division_Checks_Suppressed (Etype (N))
5432          then
5433             Rop := Right_Opnd (N);
5434
5435             if Compile_Time_Known_Value (Rop)
5436               and then ((Is_Integer_Type (Etype (Rop))
5437                           and then Expr_Value (Rop) = Uint_0)
5438                          or else
5439                            (Is_Real_Type (Etype (Rop))
5440                              and then Expr_Value_R (Rop) = Ureal_0))
5441             then
5442                --  Specialize the warning message according to the operation.
5443                --  The following warnings are for the case
5444
5445                case Nkind (N) is
5446                   when N_Op_Divide =>
5447
5448                      --  For division, we have two cases, for float division
5449                      --  of an unconstrained float type, on a machine where
5450                      --  Machine_Overflows is false, we don't get an exception
5451                      --  at run-time, but rather an infinity or Nan. The Nan
5452                      --  case is pretty obscure, so just warn about infinities.
5453
5454                      if Is_Floating_Point_Type (Typ)
5455                        and then not Is_Constrained (Typ)
5456                        and then not Machine_Overflows_On_Target
5457                      then
5458                         Error_Msg_N
5459                           ("float division by zero, may generate "
5460                            & "'+'/'- infinity??", Right_Opnd (N));
5461
5462                         --  For all other cases, we get a Constraint_Error
5463
5464                      else
5465                         Apply_Compile_Time_Constraint_Error
5466                           (N, "division by zero??", CE_Divide_By_Zero,
5467                            Loc => Sloc (Right_Opnd (N)));
5468                      end if;
5469
5470                   when N_Op_Rem =>
5471                      Apply_Compile_Time_Constraint_Error
5472                        (N, "rem with zero divisor??", CE_Divide_By_Zero,
5473                         Loc => Sloc (Right_Opnd (N)));
5474
5475                   when N_Op_Mod =>
5476                      Apply_Compile_Time_Constraint_Error
5477                        (N, "mod with zero divisor??", CE_Divide_By_Zero,
5478                         Loc => Sloc (Right_Opnd (N)));
5479
5480                   --  Division by zero can only happen with division, rem,
5481                   --  and mod operations.
5482
5483                   when others =>
5484                      raise Program_Error;
5485                end case;
5486
5487             --  Otherwise just set the flag to check at run time
5488
5489             else
5490                Activate_Division_Check (N);
5491             end if;
5492          end if;
5493
5494          --  If Restriction No_Implicit_Conditionals is active, then it is
5495          --  violated if either operand can be negative for mod, or for rem
5496          --  if both operands can be negative.
5497
5498          if Restriction_Check_Required (No_Implicit_Conditionals)
5499            and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
5500          then
5501             declare
5502                Lo : Uint;
5503                Hi : Uint;
5504                OK : Boolean;
5505
5506                LNeg : Boolean;
5507                RNeg : Boolean;
5508                --  Set if corresponding operand might be negative
5509
5510             begin
5511                Determine_Range
5512                  (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5513                LNeg := (not OK) or else Lo < 0;
5514
5515                Determine_Range
5516                  (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5517                RNeg := (not OK) or else Lo < 0;
5518
5519                --  Check if we will be generating conditionals. There are two
5520                --  cases where that can happen, first for REM, the only case
5521                --  is largest negative integer mod -1, where the division can
5522                --  overflow, but we still have to give the right result. The
5523                --  front end generates a test for this annoying case. Here we
5524                --  just test if both operands can be negative (that's what the
5525                --  expander does, so we match its logic here).
5526
5527                --  The second case is mod where either operand can be negative.
5528                --  In this case, the back end has to generate additional tests.
5529
5530                if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg))
5531                      or else
5532                   (Nkind (N) = N_Op_Mod and then (LNeg or RNeg))
5533                then
5534                   Check_Restriction (No_Implicit_Conditionals, N);
5535                end if;
5536             end;
5537          end if;
5538       end if;
5539
5540       Check_Unset_Reference (L);
5541       Check_Unset_Reference (R);
5542    end Resolve_Arithmetic_Op;
5543
5544    ------------------
5545    -- Resolve_Call --
5546    ------------------
5547
5548    procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
5549       function Same_Or_Aliased_Subprograms
5550         (S : Entity_Id;
5551          E : Entity_Id) return Boolean;
5552       --  Returns True if the subprogram entity S is the same as E or else
5553       --  S is an alias of E.
5554
5555       ---------------------------------
5556       -- Same_Or_Aliased_Subprograms --
5557       ---------------------------------
5558
5559       function Same_Or_Aliased_Subprograms
5560         (S : Entity_Id;
5561          E : Entity_Id) return Boolean
5562       is
5563          Subp_Alias : constant Entity_Id := Alias (S);
5564       begin
5565          return S = E or else (Present (Subp_Alias) and then Subp_Alias = E);
5566       end Same_Or_Aliased_Subprograms;
5567
5568       --  Local variables
5569
5570       Loc      : constant Source_Ptr := Sloc (N);
5571       Subp     : constant Node_Id    := Name (N);
5572       Body_Id  : Entity_Id;
5573       I        : Interp_Index;
5574       It       : Interp;
5575       Nam      : Entity_Id;
5576       Nam_Decl : Node_Id;
5577       Nam_UA   : Entity_Id;
5578       Norm_OK  : Boolean;
5579       Rtype    : Entity_Id;
5580       Scop     : Entity_Id;
5581
5582    --  Start of processing for Resolve_Call
5583
5584    begin
5585       --  The context imposes a unique interpretation with type Typ on a
5586       --  procedure or function call. Find the entity of the subprogram that
5587       --  yields the expected type, and propagate the corresponding formal
5588       --  constraints on the actuals. The caller has established that an
5589       --  interpretation exists, and emitted an error if not unique.
5590
5591       --  First deal with the case of a call to an access-to-subprogram,
5592       --  dereference made explicit in Analyze_Call.
5593
5594       if Ekind (Etype (Subp)) = E_Subprogram_Type then
5595          if not Is_Overloaded (Subp) then
5596             Nam := Etype (Subp);
5597
5598          else
5599             --  Find the interpretation whose type (a subprogram type) has a
5600             --  return type that is compatible with the context. Analysis of
5601             --  the node has established that one exists.
5602
5603             Nam := Empty;
5604
5605             Get_First_Interp (Subp,  I, It);
5606             while Present (It.Typ) loop
5607                if Covers (Typ, Etype (It.Typ)) then
5608                   Nam := It.Typ;
5609                   exit;
5610                end if;
5611
5612                Get_Next_Interp (I, It);
5613             end loop;
5614
5615             if No (Nam) then
5616                raise Program_Error;
5617             end if;
5618          end if;
5619
5620          --  If the prefix is not an entity, then resolve it
5621
5622          if not Is_Entity_Name (Subp) then
5623             Resolve (Subp, Nam);
5624          end if;
5625
5626          --  For an indirect call, we always invalidate checks, since we do not
5627          --  know whether the subprogram is local or global. Yes we could do
5628          --  better here, e.g. by knowing that there are no local subprograms,
5629          --  but it does not seem worth the effort. Similarly, we kill all
5630          --  knowledge of current constant values.
5631
5632          Kill_Current_Values;
5633
5634       --  If this is a procedure call which is really an entry call, do
5635       --  the conversion of the procedure call to an entry call. Protected
5636       --  operations use the same circuitry because the name in the call
5637       --  can be an arbitrary expression with special resolution rules.
5638
5639       elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
5640         or else (Is_Entity_Name (Subp)
5641                   and then Ekind (Entity (Subp)) = E_Entry)
5642       then
5643          Resolve_Entry_Call (N, Typ);
5644          Check_Elab_Call (N);
5645
5646          --  Kill checks and constant values, as above for indirect case
5647          --  Who knows what happens when another task is activated?
5648
5649          Kill_Current_Values;
5650          return;
5651
5652       --  Normal subprogram call with name established in Resolve
5653
5654       elsif not (Is_Type (Entity (Subp))) then
5655          Nam := Entity (Subp);
5656          Set_Entity_With_Checks (Subp, Nam);
5657
5658       --  Otherwise we must have the case of an overloaded call
5659
5660       else
5661          pragma Assert (Is_Overloaded (Subp));
5662
5663          --  Initialize Nam to prevent warning (we know it will be assigned
5664          --  in the loop below, but the compiler does not know that).
5665
5666          Nam := Empty;
5667
5668          Get_First_Interp (Subp,  I, It);
5669          while Present (It.Typ) loop
5670             if Covers (Typ, It.Typ) then
5671                Nam := It.Nam;
5672                Set_Entity_With_Checks (Subp, Nam);
5673                exit;
5674             end if;
5675
5676             Get_Next_Interp (I, It);
5677          end loop;
5678       end if;
5679
5680       if Is_Access_Subprogram_Type (Base_Type (Etype (Nam)))
5681         and then not Is_Access_Subprogram_Type (Base_Type (Typ))
5682         and then Nkind (Subp) /= N_Explicit_Dereference
5683         and then Present (Parameter_Associations (N))
5684       then
5685          --  The prefix is a parameterless function call that returns an access
5686          --  to subprogram. If parameters are present in the current call, add
5687          --  add an explicit dereference. We use the base type here because
5688          --  within an instance these may be subtypes.
5689
5690          --  The dereference is added either in Analyze_Call or here. Should
5691          --  be consolidated ???
5692
5693          Set_Is_Overloaded (Subp, False);
5694          Set_Etype (Subp, Etype (Nam));
5695          Insert_Explicit_Dereference (Subp);
5696          Nam := Designated_Type (Etype (Nam));
5697          Resolve (Subp, Nam);
5698       end if;
5699
5700       --  Check that a call to Current_Task does not occur in an entry body
5701
5702       if Is_RTE (Nam, RE_Current_Task) then
5703          declare
5704             P : Node_Id;
5705
5706          begin
5707             P := N;
5708             loop
5709                P := Parent (P);
5710
5711                --  Exclude calls that occur within the default of a formal
5712                --  parameter of the entry, since those are evaluated outside
5713                --  of the body.
5714
5715                exit when No (P) or else Nkind (P) = N_Parameter_Specification;
5716
5717                if Nkind (P) = N_Entry_Body
5718                  or else (Nkind (P) = N_Subprogram_Body
5719                            and then Is_Entry_Barrier_Function (P))
5720                then
5721                   Rtype := Etype (N);
5722                   Error_Msg_Warn := SPARK_Mode /= On;
5723                   Error_Msg_NE
5724                     ("& should not be used in entry body (RM C.7(17))<<",
5725                      N, Nam);
5726                   Error_Msg_NE ("\Program_Error [<<", N, Nam);
5727                   Rewrite (N,
5728                     Make_Raise_Program_Error (Loc,
5729                       Reason => PE_Current_Task_In_Entry_Body));
5730                   Set_Etype (N, Rtype);
5731                   return;
5732                end if;
5733             end loop;
5734          end;
5735       end if;
5736
5737       --  Check that a procedure call does not occur in the context of the
5738       --  entry call statement of a conditional or timed entry call. Note that
5739       --  the case of a call to a subprogram renaming of an entry will also be
5740       --  rejected. The test for N not being an N_Entry_Call_Statement is
5741       --  defensive, covering the possibility that the processing of entry
5742       --  calls might reach this point due to later modifications of the code
5743       --  above.
5744
5745       if Nkind (Parent (N)) = N_Entry_Call_Alternative
5746         and then Nkind (N) /= N_Entry_Call_Statement
5747         and then Entry_Call_Statement (Parent (N)) = N
5748       then
5749          if Ada_Version < Ada_2005 then
5750             Error_Msg_N ("entry call required in select statement", N);
5751
5752          --  Ada 2005 (AI-345): If a procedure_call_statement is used
5753          --  for a procedure_or_entry_call, the procedure_name or
5754          --  procedure_prefix of the procedure_call_statement shall denote
5755          --  an entry renamed by a procedure, or (a view of) a primitive
5756          --  subprogram of a limited interface whose first parameter is
5757          --  a controlling parameter.
5758
5759          elsif Nkind (N) = N_Procedure_Call_Statement
5760            and then not Is_Renamed_Entry (Nam)
5761            and then not Is_Controlling_Limited_Procedure (Nam)
5762          then
5763             Error_Msg_N
5764              ("entry call or dispatching primitive of interface required", N);
5765          end if;
5766       end if;
5767
5768       --  If the SPARK_05 restriction is active, we are not allowed
5769       --  to have a call to a subprogram before we see its completion.
5770
5771       if not Has_Completion (Nam)
5772         and then Restriction_Check_Required (SPARK_05)
5773
5774         --  Don't flag strange internal calls
5775
5776         and then Comes_From_Source (N)
5777         and then Comes_From_Source (Nam)
5778
5779         --  Only flag calls in extended main source
5780
5781         and then In_Extended_Main_Source_Unit (Nam)
5782         and then In_Extended_Main_Source_Unit (N)
5783
5784         --  Exclude enumeration literals from this processing
5785
5786         and then Ekind (Nam) /= E_Enumeration_Literal
5787       then
5788          Check_SPARK_05_Restriction
5789            ("call to subprogram cannot appear before its body", N);
5790       end if;
5791
5792       --  Check that this is not a call to a protected procedure or entry from
5793       --  within a protected function.
5794
5795       Check_Internal_Protected_Use (N, Nam);
5796
5797       --  Freeze the subprogram name if not in a spec-expression. Note that
5798       --  we freeze procedure calls as well as function calls. Procedure calls
5799       --  are not frozen according to the rules (RM 13.14(14)) because it is
5800       --  impossible to have a procedure call to a non-frozen procedure in
5801       --  pure Ada, but in the code that we generate in the expander, this
5802       --  rule needs extending because we can generate procedure calls that
5803       --  need freezing.
5804
5805       --  In Ada 2012, expression functions may be called within pre/post
5806       --  conditions of subsequent functions or expression functions. Such
5807       --  calls do not freeze when they appear within generated bodies,
5808       --  (including the body of another expression function) which would
5809       --  place the freeze node in the wrong scope. An expression function
5810       --  is frozen in the usual fashion, by the appearance of a real body,
5811       --  or at the end of a declarative part.
5812
5813       if Is_Entity_Name (Subp)
5814         and then not In_Spec_Expression
5815         and then not Is_Expression_Function_Or_Completion (Current_Scope)
5816         and then
5817           (not Is_Expression_Function_Or_Completion (Entity (Subp))
5818             or else Scope (Entity (Subp)) = Current_Scope)
5819       then
5820          Freeze_Expression (Subp);
5821       end if;
5822
5823       --  For a predefined operator, the type of the result is the type imposed
5824       --  by context, except for a predefined operation on universal fixed.
5825       --  Otherwise The type of the call is the type returned by the subprogram
5826       --  being called.
5827
5828       if Is_Predefined_Op (Nam) then
5829          if Etype (N) /= Universal_Fixed then
5830             Set_Etype (N, Typ);
5831          end if;
5832
5833       --  If the subprogram returns an array type, and the context requires the
5834       --  component type of that array type, the node is really an indexing of
5835       --  the parameterless call. Resolve as such. A pathological case occurs
5836       --  when the type of the component is an access to the array type. In
5837       --  this case the call is truly ambiguous.
5838
5839       elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam))
5840         and then
5841           ((Is_Array_Type (Etype (Nam))
5842              and then Covers (Typ, Component_Type (Etype (Nam))))
5843            or else
5844              (Is_Access_Type (Etype (Nam))
5845                and then Is_Array_Type (Designated_Type (Etype (Nam)))
5846                and then
5847                  Covers (Typ, Component_Type (Designated_Type (Etype (Nam))))))
5848       then
5849          declare
5850             Index_Node : Node_Id;
5851             New_Subp   : Node_Id;
5852             Ret_Type   : constant Entity_Id := Etype (Nam);
5853
5854          begin
5855             if Is_Access_Type (Ret_Type)
5856               and then Ret_Type = Component_Type (Designated_Type (Ret_Type))
5857             then
5858                Error_Msg_N
5859                  ("cannot disambiguate function call and indexing", N);
5860             else
5861                New_Subp := Relocate_Node (Subp);
5862
5863                --  The called entity may be an explicit dereference, in which
5864                --  case there is no entity to set.
5865
5866                if Nkind (New_Subp) /= N_Explicit_Dereference then
5867                   Set_Entity (Subp, Nam);
5868                end if;
5869
5870                if (Is_Array_Type (Ret_Type)
5871                     and then Component_Type (Ret_Type) /= Any_Type)
5872                  or else
5873                   (Is_Access_Type (Ret_Type)
5874                     and then
5875                       Component_Type (Designated_Type (Ret_Type)) /= Any_Type)
5876                then
5877                   if Needs_No_Actuals (Nam) then
5878
5879                      --  Indexed call to a parameterless function
5880
5881                      Index_Node :=
5882                        Make_Indexed_Component (Loc,
5883                          Prefix      =>
5884                            Make_Function_Call (Loc, Name => New_Subp),
5885                          Expressions => Parameter_Associations (N));
5886                   else
5887                      --  An Ada 2005 prefixed call to a primitive operation
5888                      --  whose first parameter is the prefix. This prefix was
5889                      --  prepended to the parameter list, which is actually a
5890                      --  list of indexes. Remove the prefix in order to build
5891                      --  the proper indexed component.
5892
5893                      Index_Node :=
5894                         Make_Indexed_Component (Loc,
5895                           Prefix       =>
5896                             Make_Function_Call (Loc,
5897                                Name                   => New_Subp,
5898                                Parameter_Associations =>
5899                                  New_List
5900                                    (Remove_Head (Parameter_Associations (N)))),
5901                            Expressions => Parameter_Associations (N));
5902                   end if;
5903
5904                   --  Preserve the parenthesis count of the node
5905
5906                   Set_Paren_Count (Index_Node, Paren_Count (N));
5907
5908                   --  Since we are correcting a node classification error made
5909                   --  by the parser, we call Replace rather than Rewrite.
5910
5911                   Replace (N, Index_Node);
5912
5913                   Set_Etype (Prefix (N), Ret_Type);
5914                   Set_Etype (N, Typ);
5915                   Resolve_Indexed_Component (N, Typ);
5916                   Check_Elab_Call (Prefix (N));
5917                end if;
5918             end if;
5919
5920             return;
5921          end;
5922
5923       else
5924          Set_Etype (N, Etype (Nam));
5925       end if;
5926
5927       --  In the case where the call is to an overloaded subprogram, Analyze
5928       --  calls Normalize_Actuals once per overloaded subprogram. Therefore in
5929       --  such a case Normalize_Actuals needs to be called once more to order
5930       --  the actuals correctly. Otherwise the call will have the ordering
5931       --  given by the last overloaded subprogram whether this is the correct
5932       --  one being called or not.
5933
5934       if Is_Overloaded (Subp) then
5935          Normalize_Actuals (N, Nam, False, Norm_OK);
5936          pragma Assert (Norm_OK);
5937       end if;
5938
5939       --  In any case, call is fully resolved now. Reset Overload flag, to
5940       --  prevent subsequent overload resolution if node is analyzed again
5941
5942       Set_Is_Overloaded (Subp, False);
5943       Set_Is_Overloaded (N, False);
5944
5945       --  A Ghost entity must appear in a specific context
5946
5947       if Is_Ghost_Entity (Nam) and then Comes_From_Source (N) then
5948          Check_Ghost_Context (Nam, N);
5949       end if;
5950
5951       --  If we are calling the current subprogram from immediately within its
5952       --  body, then that is the case where we can sometimes detect cases of
5953       --  infinite recursion statically. Do not try this in case restriction
5954       --  No_Recursion is in effect anyway, and do it only for source calls.
5955
5956       if Comes_From_Source (N) then
5957          Scop := Current_Scope;
5958
5959          --  Check violation of SPARK_05 restriction which does not permit
5960          --  a subprogram body to contain a call to the subprogram directly.
5961
5962          if Restriction_Check_Required (SPARK_05)
5963            and then Same_Or_Aliased_Subprograms (Nam, Scop)
5964          then
5965             Check_SPARK_05_Restriction
5966               ("subprogram may not contain direct call to itself", N);
5967          end if;
5968
5969          --  Issue warning for possible infinite recursion in the absence
5970          --  of the No_Recursion restriction.
5971
5972          if Same_Or_Aliased_Subprograms (Nam, Scop)
5973            and then not Restriction_Active (No_Recursion)
5974            and then Check_Infinite_Recursion (N)
5975          then
5976             --  Here we detected and flagged an infinite recursion, so we do
5977             --  not need to test the case below for further warnings. Also we
5978             --  are all done if we now have a raise SE node.
5979
5980             if Nkind (N) = N_Raise_Storage_Error then
5981                return;
5982             end if;
5983
5984          --  If call is to immediately containing subprogram, then check for
5985          --  the case of a possible run-time detectable infinite recursion.
5986
5987          else
5988             Scope_Loop : while Scop /= Standard_Standard loop
5989                if Same_Or_Aliased_Subprograms (Nam, Scop) then
5990
5991                   --  Although in general case, recursion is not statically
5992                   --  checkable, the case of calling an immediately containing
5993                   --  subprogram is easy to catch.
5994
5995                   Check_Restriction (No_Recursion, N);
5996
5997                   --  If the recursive call is to a parameterless subprogram,
5998                   --  then even if we can't statically detect infinite
5999                   --  recursion, this is pretty suspicious, and we output a
6000                   --  warning. Furthermore, we will try later to detect some
6001                   --  cases here at run time by expanding checking code (see
6002                   --  Detect_Infinite_Recursion in package Exp_Ch6).
6003
6004                   --  If the recursive call is within a handler, do not emit a
6005                   --  warning, because this is a common idiom: loop until input
6006                   --  is correct, catch illegal input in handler and restart.
6007
6008                   if No (First_Formal (Nam))
6009                     and then Etype (Nam) = Standard_Void_Type
6010                     and then not Error_Posted (N)
6011                     and then Nkind (Parent (N)) /= N_Exception_Handler
6012                   then
6013                      --  For the case of a procedure call. We give the message
6014                      --  only if the call is the first statement in a sequence
6015                      --  of statements, or if all previous statements are
6016                      --  simple assignments. This is simply a heuristic to
6017                      --  decrease false positives, without losing too many good
6018                      --  warnings. The idea is that these previous statements
6019                      --  may affect global variables the procedure depends on.
6020                      --  We also exclude raise statements, that may arise from
6021                      --  constraint checks and are probably unrelated to the
6022                      --  intended control flow.
6023
6024                      if Nkind (N) = N_Procedure_Call_Statement
6025                        and then Is_List_Member (N)
6026                      then
6027                         declare
6028                            P : Node_Id;
6029                         begin
6030                            P := Prev (N);
6031                            while Present (P) loop
6032                               if not Nkind_In (P, N_Assignment_Statement,
6033                                                   N_Raise_Constraint_Error)
6034                               then
6035                                  exit Scope_Loop;
6036                               end if;
6037
6038                               Prev (P);
6039                            end loop;
6040                         end;
6041                      end if;
6042
6043                      --  Do not give warning if we are in a conditional context
6044
6045                      declare
6046                         K : constant Node_Kind := Nkind (Parent (N));
6047                      begin
6048                         if (K = N_Loop_Statement
6049                              and then Present (Iteration_Scheme (Parent (N))))
6050                           or else K = N_If_Statement
6051                           or else K = N_Elsif_Part
6052                           or else K = N_Case_Statement_Alternative
6053                         then
6054                            exit Scope_Loop;
6055                         end if;
6056                      end;
6057
6058                      --  Here warning is to be issued
6059
6060                      Set_Has_Recursive_Call (Nam);
6061                      Error_Msg_Warn := SPARK_Mode /= On;
6062                      Error_Msg_N ("possible infinite recursion<<!", N);
6063                      Error_Msg_N ("\Storage_Error ]<<!", N);
6064                   end if;
6065
6066                   exit Scope_Loop;
6067                end if;
6068
6069                Scop := Scope (Scop);
6070             end loop Scope_Loop;
6071          end if;
6072       end if;
6073
6074       --  Check obsolescent reference to Ada.Characters.Handling subprogram
6075
6076       Check_Obsolescent_2005_Entity (Nam, Subp);
6077
6078       --  If subprogram name is a predefined operator, it was given in
6079       --  functional notation. Replace call node with operator node, so
6080       --  that actuals can be resolved appropriately.
6081
6082       if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
6083          Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
6084          return;
6085
6086       elsif Present (Alias (Nam))
6087         and then Is_Predefined_Op (Alias (Nam))
6088       then
6089          Resolve_Actuals (N, Nam);
6090          Make_Call_Into_Operator (N, Typ, Alias (Nam));
6091          return;
6092       end if;
6093
6094       --  Create a transient scope if the resulting type requires it
6095
6096       --  There are several notable exceptions:
6097
6098       --  a) In init procs, the transient scope overhead is not needed, and is
6099       --  even incorrect when the call is a nested initialization call for a
6100       --  component whose expansion may generate adjust calls. However, if the
6101       --  call is some other procedure call within an initialization procedure
6102       --  (for example a call to Create_Task in the init_proc of the task
6103       --  run-time record) a transient scope must be created around this call.
6104
6105       --  b) Enumeration literal pseudo-calls need no transient scope
6106
6107       --  c) Intrinsic subprograms (Unchecked_Conversion and source info
6108       --  functions) do not use the secondary stack even though the return
6109       --  type may be unconstrained.
6110
6111       --  d) Calls to a build-in-place function, since such functions may
6112       --  allocate their result directly in a target object, and cases where
6113       --  the result does get allocated in the secondary stack are checked for
6114       --  within the specialized Exp_Ch6 procedures for expanding those
6115       --  build-in-place calls.
6116
6117       --  e) If the subprogram is marked Inline_Always, then even if it returns
6118       --  an unconstrained type the call does not require use of the secondary
6119       --  stack. However, inlining will only take place if the body to inline
6120       --  is already present. It may not be available if e.g. the subprogram is
6121       --  declared in a child instance.
6122
6123       --  If this is an initialization call for a type whose construction
6124       --  uses the secondary stack, and it is not a nested call to initialize
6125       --  a component, we do need to create a transient scope for it. We
6126       --  check for this by traversing the type in Check_Initialization_Call.
6127
6128       if Is_Inlined (Nam)
6129         and then Has_Pragma_Inline (Nam)
6130         and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
6131         and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
6132       then
6133          null;
6134
6135       elsif Ekind (Nam) = E_Enumeration_Literal
6136         or else Is_Build_In_Place_Function (Nam)
6137         or else Is_Intrinsic_Subprogram (Nam)
6138       then
6139          null;
6140
6141       elsif Expander_Active
6142         and then Is_Type (Etype (Nam))
6143         and then Requires_Transient_Scope (Etype (Nam))
6144         and then
6145           (not Within_Init_Proc
6146             or else
6147               (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function))
6148       then
6149          Establish_Transient_Scope (N, Sec_Stack => True);
6150
6151          --  If the call appears within the bounds of a loop, it will
6152          --  be rewritten and reanalyzed, nothing left to do here.
6153
6154          if Nkind (N) /= N_Function_Call then
6155             return;
6156          end if;
6157
6158       elsif Is_Init_Proc (Nam)
6159         and then not Within_Init_Proc
6160       then
6161          Check_Initialization_Call (N, Nam);
6162       end if;
6163
6164       --  A protected function cannot be called within the definition of the
6165       --  enclosing protected type, unless it is part of a pre/postcondition
6166       --  on another protected operation.
6167
6168       if Is_Protected_Type (Scope (Nam))
6169         and then In_Open_Scopes (Scope (Nam))
6170         and then not Has_Completion (Scope (Nam))
6171         and then not In_Spec_Expression
6172       then
6173          Error_Msg_NE
6174            ("& cannot be called before end of protected definition", N, Nam);
6175       end if;
6176
6177       --  Propagate interpretation to actuals, and add default expressions
6178       --  where needed.
6179
6180       if Present (First_Formal (Nam)) then
6181          Resolve_Actuals (N, Nam);
6182
6183       --  Overloaded literals are rewritten as function calls, for purpose of
6184       --  resolution. After resolution, we can replace the call with the
6185       --  literal itself.
6186
6187       elsif Ekind (Nam) = E_Enumeration_Literal then
6188          Copy_Node (Subp, N);
6189          Resolve_Entity_Name (N, Typ);
6190
6191          --  Avoid validation, since it is a static function call
6192
6193          Generate_Reference (Nam, Subp);
6194          return;
6195       end if;
6196
6197       --  If the subprogram is not global, then kill all saved values and
6198       --  checks. This is a bit conservative, since in many cases we could do
6199       --  better, but it is not worth the effort. Similarly, we kill constant
6200       --  values. However we do not need to do this for internal entities
6201       --  (unless they are inherited user-defined subprograms), since they
6202       --  are not in the business of molesting local values.
6203
6204       --  If the flag Suppress_Value_Tracking_On_Calls is set, then we also
6205       --  kill all checks and values for calls to global subprograms. This
6206       --  takes care of the case where an access to a local subprogram is
6207       --  taken, and could be passed directly or indirectly and then called
6208       --  from almost any context.
6209
6210       --  Note: we do not do this step till after resolving the actuals. That
6211       --  way we still take advantage of the current value information while
6212       --  scanning the actuals.
6213
6214       --  We suppress killing values if we are processing the nodes associated
6215       --  with N_Freeze_Entity nodes. Otherwise the declaration of a tagged
6216       --  type kills all the values as part of analyzing the code that
6217       --  initializes the dispatch tables.
6218
6219       if Inside_Freezing_Actions = 0
6220         and then (not Is_Library_Level_Entity (Nam)
6221                    or else Suppress_Value_Tracking_On_Call
6222                              (Nearest_Dynamic_Scope (Current_Scope)))
6223         and then (Comes_From_Source (Nam)
6224                    or else (Present (Alias (Nam))
6225                              and then Comes_From_Source (Alias (Nam))))
6226       then
6227          Kill_Current_Values;
6228       end if;
6229
6230       --  If we are warning about unread OUT parameters, this is the place to
6231       --  set Last_Assignment for OUT and IN OUT parameters. We have to do this
6232       --  after the above call to Kill_Current_Values (since that call clears
6233       --  the Last_Assignment field of all local variables).
6234
6235       if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters)
6236         and then Comes_From_Source (N)
6237         and then In_Extended_Main_Source_Unit (N)
6238       then
6239          declare
6240             F : Entity_Id;
6241             A : Node_Id;
6242
6243          begin
6244             F := First_Formal (Nam);
6245             A := First_Actual (N);
6246             while Present (F) and then Present (A) loop
6247                if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter)
6248                  and then Warn_On_Modified_As_Out_Parameter (F)
6249                  and then Is_Entity_Name (A)
6250                  and then Present (Entity (A))
6251                  and then Comes_From_Source (N)
6252                  and then Safe_To_Capture_Value (N, Entity (A))
6253                then
6254                   Set_Last_Assignment (Entity (A), A);
6255                end if;
6256
6257                Next_Formal (F);
6258                Next_Actual (A);
6259             end loop;
6260          end;
6261       end if;
6262
6263       --  If the subprogram is a primitive operation, check whether or not
6264       --  it is a correct dispatching call.
6265
6266       if Is_Overloadable (Nam)
6267         and then Is_Dispatching_Operation (Nam)
6268       then
6269          Check_Dispatching_Call (N);
6270
6271       elsif Ekind (Nam) /= E_Subprogram_Type
6272         and then Is_Abstract_Subprogram (Nam)
6273         and then not In_Instance
6274       then
6275          Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
6276       end if;
6277
6278       --  If this is a dispatching call, generate the appropriate reference,
6279       --  for better source navigation in GPS.
6280
6281       if Is_Overloadable (Nam)
6282         and then Present (Controlling_Argument (N))
6283       then
6284          Generate_Reference (Nam, Subp, 'R');
6285
6286       --  Normal case, not a dispatching call: generate a call reference
6287
6288       else
6289          Generate_Reference (Nam, Subp, 's');
6290       end if;
6291
6292       if Is_Intrinsic_Subprogram (Nam) then
6293          Check_Intrinsic_Call (N);
6294       end if;
6295
6296       --  Check for violation of restriction No_Specific_Termination_Handlers
6297       --  and warn on a potentially blocking call to Abort_Task.
6298
6299       if Restriction_Check_Required (No_Specific_Termination_Handlers)
6300         and then (Is_RTE (Nam, RE_Set_Specific_Handler)
6301                     or else
6302                   Is_RTE (Nam, RE_Specific_Handler))
6303       then
6304          Check_Restriction (No_Specific_Termination_Handlers, N);
6305
6306       elsif Is_RTE (Nam, RE_Abort_Task) then
6307          Check_Potentially_Blocking_Operation (N);
6308       end if;
6309
6310       --  A call to Ada.Real_Time.Timing_Events.Set_Handler to set a relative
6311       --  timing event violates restriction No_Relative_Delay (AI-0211). We
6312       --  need to check the second argument to determine whether it is an
6313       --  absolute or relative timing event.
6314
6315       if Restriction_Check_Required (No_Relative_Delay)
6316         and then Is_RTE (Nam, RE_Set_Handler)
6317         and then Is_RTE (Etype (Next_Actual (First_Actual (N))), RE_Time_Span)
6318       then
6319          Check_Restriction (No_Relative_Delay, N);
6320       end if;
6321
6322       --  Issue an error for a call to an eliminated subprogram. This routine
6323       --  will not perform the check if the call appears within a default
6324       --  expression.
6325
6326       Check_For_Eliminated_Subprogram (Subp, Nam);
6327
6328       --  In formal mode, the primitive operations of a tagged type or type
6329       --  extension do not include functions that return the tagged type.
6330
6331       if Nkind (N) = N_Function_Call
6332         and then Is_Tagged_Type (Etype (N))
6333         and then Is_Entity_Name (Name (N))
6334         and then Is_Inherited_Operation_For_Type (Entity (Name (N)), Etype (N))
6335       then
6336          Check_SPARK_05_Restriction ("function not inherited", N);
6337       end if;
6338
6339       --  Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is
6340       --  class-wide and the call dispatches on result in a context that does
6341       --  not provide a tag, the call raises Program_Error.
6342
6343       if Nkind (N) = N_Function_Call
6344         and then In_Instance
6345         and then Is_Generic_Actual_Type (Typ)
6346         and then Is_Class_Wide_Type (Typ)
6347         and then Has_Controlling_Result (Nam)
6348         and then Nkind (Parent (N)) = N_Object_Declaration
6349       then
6350          --  Verify that none of the formals are controlling
6351
6352          declare
6353             Call_OK : Boolean := False;
6354             F       : Entity_Id;
6355
6356          begin
6357             F := First_Formal (Nam);
6358             while Present (F) loop
6359                if Is_Controlling_Formal (F) then
6360                   Call_OK := True;
6361                   exit;
6362                end if;
6363
6364                Next_Formal (F);
6365             end loop;
6366
6367             if not Call_OK then
6368                Error_Msg_Warn := SPARK_Mode /= On;
6369                Error_Msg_N ("!cannot determine tag of result<<", N);
6370                Error_Msg_N ("\Program_Error [<<!", N);
6371                Insert_Action (N,
6372                  Make_Raise_Program_Error (Sloc (N),
6373                     Reason => PE_Explicit_Raise));
6374             end if;
6375          end;
6376       end if;
6377
6378       --  Check for calling a function with OUT or IN OUT parameter when the
6379       --  calling context (us right now) is not Ada 2012, so does not allow
6380       --  OUT or IN OUT parameters in function calls. Functions declared in
6381       --  a predefined unit are OK, as they may be called indirectly from a
6382       --  user-declared instantiation.
6383
6384       if Ada_Version < Ada_2012
6385         and then Ekind (Nam) = E_Function
6386         and then Has_Out_Or_In_Out_Parameter (Nam)
6387         and then not In_Predefined_Unit (Nam)
6388       then
6389          Error_Msg_NE ("& has at least one OUT or `IN OUT` parameter", N, Nam);
6390          Error_Msg_N ("\call to this function only allowed in Ada 2012", N);
6391       end if;
6392
6393       --  Check the dimensions of the actuals in the call. For function calls,
6394       --  propagate the dimensions from the returned type to N.
6395
6396       Analyze_Dimension_Call (N, Nam);
6397
6398       --  All done, evaluate call and deal with elaboration issues
6399
6400       Eval_Call (N);
6401       Check_Elab_Call (N);
6402
6403       --  In GNATprove mode, expansion is disabled, but we want to inline some
6404       --  subprograms to facilitate formal verification. Indirect calls through
6405       --  a subprogram type or within a generic cannot be inlined. Inlining is
6406       --  performed only for calls subject to SPARK_Mode on.
6407
6408       if GNATprove_Mode
6409         and then SPARK_Mode = On
6410         and then Is_Overloadable (Nam)
6411         and then not Inside_A_Generic
6412       then
6413          Nam_UA   := Ultimate_Alias (Nam);
6414          Nam_Decl := Unit_Declaration_Node (Nam_UA);
6415
6416          if Nkind (Nam_Decl) = N_Subprogram_Declaration then
6417             Body_Id := Corresponding_Body (Nam_Decl);
6418
6419             --  Nothing to do if the subprogram is not eligible for inlining in
6420             --  GNATprove mode.
6421
6422             if not Is_Inlined_Always (Nam_UA)
6423               or else not Can_Be_Inlined_In_GNATprove_Mode (Nam_UA, Body_Id)
6424             then
6425                null;
6426
6427             --  Calls cannot be inlined inside assertions, as GNATprove treats
6428             --  assertions as logic expressions.
6429
6430             elsif In_Assertion_Expr /= 0 then
6431                Error_Msg_NE ("info: no contextual analysis of &?", N, Nam);
6432                Error_Msg_N ("\call appears in assertion expression", N);
6433                Set_Is_Inlined_Always (Nam_UA, False);
6434
6435             --  Calls cannot be inlined inside default expressions
6436
6437             elsif In_Default_Expr then
6438                Error_Msg_NE ("info: no contextual analysis of &?", N, Nam);
6439                Error_Msg_N ("\call appears in default expression", N);
6440                Set_Is_Inlined_Always (Nam_UA, False);
6441
6442             --  Inlining should not be performed during pre-analysis
6443
6444             elsif Full_Analysis then
6445
6446                --  With the one-pass inlining technique, a call cannot be
6447                --  inlined if the corresponding body has not been seen yet.
6448
6449                if No (Body_Id) then
6450                   Error_Msg_NE
6451                     ("info: no contextual analysis of & (body not seen yet)?",
6452                      N, Nam);
6453                   Set_Is_Inlined_Always (Nam_UA, False);
6454
6455                --  Nothing to do if there is no body to inline, indicating that
6456                --  the subprogram is not suitable for inlining in GNATprove
6457                --  mode.
6458
6459                elsif No (Body_To_Inline (Nam_Decl)) then
6460                   null;
6461
6462                --  Calls cannot be inlined inside potentially unevaluated
6463                --  expressions, as this would create complex actions inside
6464                --  expressions, that are not handled by GNATprove.
6465
6466                elsif Is_Potentially_Unevaluated (N) then
6467                   Error_Msg_NE ("info: no contextual analysis of &?", N, Nam);
6468                   Error_Msg_N
6469                     ("\call appears in potentially unevaluated context", N);
6470                   Set_Is_Inlined_Always (Nam_UA, False);
6471
6472                --  Otherwise, inline the call
6473
6474                else
6475                   Expand_Inlined_Call (N, Nam_UA, Nam);
6476                end if;
6477             end if;
6478          end if;
6479       end if;
6480
6481       Warn_On_Overlapping_Actuals (Nam, N);
6482    end Resolve_Call;
6483
6484    -----------------------------
6485    -- Resolve_Case_Expression --
6486    -----------------------------
6487
6488    procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is
6489       Alt    : Node_Id;
6490       Is_Dyn : Boolean;
6491
6492    begin
6493       Alt := First (Alternatives (N));
6494       while Present (Alt) loop
6495          Resolve (Expression (Alt), Typ);
6496          Next (Alt);
6497       end loop;
6498
6499       --  Apply RM 4.5.7 (17/3): whether the expression is statically or
6500       --  dynamically tagged must be known statically.
6501
6502       if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
6503          Alt := First (Alternatives (N));
6504          Is_Dyn := Is_Dynamically_Tagged (Expression (Alt));
6505
6506          while Present (Alt) loop
6507             if Is_Dynamically_Tagged (Expression (Alt)) /= Is_Dyn then
6508                Error_Msg_N ("all or none of the dependent expressions "
6509                             & "can be dynamically tagged", N);
6510             end if;
6511
6512             Next (Alt);
6513          end loop;
6514       end if;
6515
6516       Set_Etype (N, Typ);
6517       Eval_Case_Expression (N);
6518    end Resolve_Case_Expression;
6519
6520    -------------------------------
6521    -- Resolve_Character_Literal --
6522    -------------------------------
6523
6524    procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
6525       B_Typ : constant Entity_Id := Base_Type (Typ);
6526       C     : Entity_Id;
6527
6528    begin
6529       --  Verify that the character does belong to the type of the context
6530
6531       Set_Etype (N, B_Typ);
6532       Eval_Character_Literal (N);
6533
6534       --  Wide_Wide_Character literals must always be defined, since the set
6535       --  of wide wide character literals is complete, i.e. if a character
6536       --  literal is accepted by the parser, then it is OK for wide wide
6537       --  character (out of range character literals are rejected).
6538
6539       if Root_Type (B_Typ) = Standard_Wide_Wide_Character then
6540          return;
6541
6542       --  Always accept character literal for type Any_Character, which
6543       --  occurs in error situations and in comparisons of literals, both
6544       --  of which should accept all literals.
6545
6546       elsif B_Typ = Any_Character then
6547          return;
6548
6549       --  For Standard.Character or a type derived from it, check that the
6550       --  literal is in range.
6551
6552       elsif Root_Type (B_Typ) = Standard_Character then
6553          if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
6554             return;
6555          end if;
6556
6557       --  For Standard.Wide_Character or a type derived from it, check that the
6558       --  literal is in range.
6559
6560       elsif Root_Type (B_Typ) = Standard_Wide_Character then
6561          if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
6562             return;
6563          end if;
6564
6565       --  For Standard.Wide_Wide_Character or a type derived from it, we
6566       --  know the literal is in range, since the parser checked.
6567
6568       elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
6569          return;
6570
6571       --  If the entity is already set, this has already been resolved in a
6572       --  generic context, or comes from expansion. Nothing else to do.
6573
6574       elsif Present (Entity (N)) then
6575          return;
6576
6577       --  Otherwise we have a user defined character type, and we can use the
6578       --  standard visibility mechanisms to locate the referenced entity.
6579
6580       else
6581          C := Current_Entity (N);
6582          while Present (C) loop
6583             if Etype (C) = B_Typ then
6584                Set_Entity_With_Checks (N, C);
6585                Generate_Reference (C, N);
6586                return;
6587             end if;
6588
6589             C := Homonym (C);
6590          end loop;
6591       end if;
6592
6593       --  If we fall through, then the literal does not match any of the
6594       --  entries of the enumeration type. This isn't just a constraint error
6595       --  situation, it is an illegality (see RM 4.2).
6596
6597       Error_Msg_NE
6598         ("character not defined for }", N, First_Subtype (B_Typ));
6599    end Resolve_Character_Literal;
6600
6601    ---------------------------
6602    -- Resolve_Comparison_Op --
6603    ---------------------------
6604
6605    --  Context requires a boolean type, and plays no role in resolution.
6606    --  Processing identical to that for equality operators. The result type is
6607    --  the base type, which matters when pathological subtypes of booleans with
6608    --  limited ranges are used.
6609
6610    procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
6611       L : constant Node_Id := Left_Opnd (N);
6612       R : constant Node_Id := Right_Opnd (N);
6613       T : Entity_Id;
6614
6615    begin
6616       --  If this is an intrinsic operation which is not predefined, use the
6617       --  types of its declared arguments to resolve the possibly overloaded
6618       --  operands. Otherwise the operands are unambiguous and specify the
6619       --  expected type.
6620
6621       if Scope (Entity (N)) /= Standard_Standard then
6622          T := Etype (First_Entity (Entity (N)));
6623
6624       else
6625          T := Find_Unique_Type (L, R);
6626
6627          if T = Any_Fixed then
6628             T := Unique_Fixed_Point_Type (L);
6629          end if;
6630       end if;
6631
6632       Set_Etype (N, Base_Type (Typ));
6633       Generate_Reference (T, N, ' ');
6634
6635       --  Skip remaining processing if already set to Any_Type
6636
6637       if T = Any_Type then
6638          return;
6639       end if;
6640
6641       --  Deal with other error cases
6642
6643       if T = Any_String    or else
6644          T = Any_Composite or else
6645          T = Any_Character
6646       then
6647          if T = Any_Character then
6648             Ambiguous_Character (L);
6649          else
6650             Error_Msg_N ("ambiguous operands for comparison", N);
6651          end if;
6652
6653          Set_Etype (N, Any_Type);
6654          return;
6655       end if;
6656
6657       --  Resolve the operands if types OK
6658
6659       Resolve (L, T);
6660       Resolve (R, T);
6661       Check_Unset_Reference (L);
6662       Check_Unset_Reference (R);
6663       Generate_Operator_Reference (N, T);
6664       Check_Low_Bound_Tested (N);
6665
6666       --  In SPARK, ordering operators <, <=, >, >= are not defined for Boolean
6667       --  types or array types except String.
6668
6669       if Is_Boolean_Type (T) then
6670          Check_SPARK_05_Restriction
6671            ("comparison is not defined on Boolean type", N);
6672
6673       elsif Is_Array_Type (T)
6674         and then Base_Type (T) /= Standard_String
6675       then
6676          Check_SPARK_05_Restriction
6677            ("comparison is not defined on array types other than String", N);
6678       end if;
6679
6680       --  Check comparison on unordered enumeration
6681
6682       if Bad_Unordered_Enumeration_Reference (N, Etype (L)) then
6683          Error_Msg_Sloc := Sloc (Etype (L));
6684          Error_Msg_NE
6685            ("comparison on unordered enumeration type& declared#?U?",
6686             N, Etype (L));
6687       end if;
6688
6689       --  Evaluate the relation (note we do this after the above check since
6690       --  this Eval call may change N to True/False.
6691
6692       Analyze_Dimension (N);
6693       Eval_Relational_Op (N);
6694    end Resolve_Comparison_Op;
6695
6696    -----------------------------------------
6697    -- Resolve_Discrete_Subtype_Indication --
6698    -----------------------------------------
6699
6700    procedure Resolve_Discrete_Subtype_Indication
6701      (N   : Node_Id;
6702       Typ : Entity_Id)
6703    is
6704       R : Node_Id;
6705       S : Entity_Id;
6706
6707    begin
6708       Analyze (Subtype_Mark (N));
6709       S := Entity (Subtype_Mark (N));
6710
6711       if Nkind (Constraint (N)) /= N_Range_Constraint then
6712          Error_Msg_N ("expect range constraint for discrete type", N);
6713          Set_Etype (N, Any_Type);
6714
6715       else
6716          R := Range_Expression (Constraint (N));
6717
6718          if R = Error then
6719             return;
6720          end if;
6721
6722          Analyze (R);
6723
6724          if Base_Type (S) /= Base_Type (Typ) then
6725             Error_Msg_NE
6726               ("expect subtype of }", N, First_Subtype (Typ));
6727
6728             --  Rewrite the constraint as a range of Typ
6729             --  to allow compilation to proceed further.
6730
6731             Set_Etype (N, Typ);
6732             Rewrite (Low_Bound (R),
6733               Make_Attribute_Reference (Sloc (Low_Bound (R)),
6734                 Prefix         => New_Occurrence_Of (Typ, Sloc (R)),
6735                 Attribute_Name => Name_First));
6736             Rewrite (High_Bound (R),
6737               Make_Attribute_Reference (Sloc (High_Bound (R)),
6738                 Prefix         => New_Occurrence_Of (Typ, Sloc (R)),
6739                 Attribute_Name => Name_First));
6740
6741          else
6742             Resolve (R, Typ);
6743             Set_Etype (N, Etype (R));
6744
6745             --  Additionally, we must check that the bounds are compatible
6746             --  with the given subtype, which might be different from the
6747             --  type of the context.
6748
6749             Apply_Range_Check (R, S);
6750
6751             --  ??? If the above check statically detects a Constraint_Error
6752             --  it replaces the offending bound(s) of the range R with a
6753             --  Constraint_Error node. When the itype which uses these bounds
6754             --  is frozen the resulting call to Duplicate_Subexpr generates
6755             --  a new temporary for the bounds.
6756
6757             --  Unfortunately there are other itypes that are also made depend
6758             --  on these bounds, so when Duplicate_Subexpr is called they get
6759             --  a forward reference to the newly created temporaries and Gigi
6760             --  aborts on such forward references. This is probably sign of a
6761             --  more fundamental problem somewhere else in either the order of
6762             --  itype freezing or the way certain itypes are constructed.
6763
6764             --  To get around this problem we call Remove_Side_Effects right
6765             --  away if either bounds of R are a Constraint_Error.
6766
6767             declare
6768                L : constant Node_Id := Low_Bound (R);
6769                H : constant Node_Id := High_Bound (R);
6770
6771             begin
6772                if Nkind (L) = N_Raise_Constraint_Error then
6773                   Remove_Side_Effects (L);
6774                end if;
6775
6776                if Nkind (H) = N_Raise_Constraint_Error then
6777                   Remove_Side_Effects (H);
6778                end if;
6779             end;
6780
6781             Check_Unset_Reference (Low_Bound  (R));
6782             Check_Unset_Reference (High_Bound (R));
6783          end if;
6784       end if;
6785    end Resolve_Discrete_Subtype_Indication;
6786
6787    -------------------------
6788    -- Resolve_Entity_Name --
6789    -------------------------
6790
6791    --  Used to resolve identifiers and expanded names
6792
6793    procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
6794       function Is_Assignment_Or_Object_Expression
6795         (Context : Node_Id;
6796          Expr    : Node_Id) return Boolean;
6797       --  Determine whether node Context denotes an assignment statement or an
6798       --  object declaration whose expression is node Expr.
6799
6800       function Is_OK_Volatile_Context
6801         (Context : Node_Id;
6802          Obj_Ref : Node_Id) return Boolean;
6803       --  Determine whether node Context denotes a "non-interfering context"
6804       --  (as defined in SPARK RM 7.1.3(12)) where volatile reference Obj_Ref
6805       --  can safely reside.
6806
6807       ----------------------------------------
6808       -- Is_Assignment_Or_Object_Expression --
6809       ----------------------------------------
6810
6811       function Is_Assignment_Or_Object_Expression
6812         (Context : Node_Id;
6813          Expr    : Node_Id) return Boolean
6814       is
6815       begin
6816          if Nkind_In (Context, N_Assignment_Statement,
6817                                N_Object_Declaration)
6818            and then Expression (Context) = Expr
6819          then
6820             return True;
6821
6822          --  Check whether a construct that yields a name is the expression of
6823          --  an assignment statement or an object declaration.
6824
6825          elsif (Nkind_In (Context, N_Attribute_Reference,
6826                                    N_Explicit_Dereference,
6827                                    N_Indexed_Component,
6828                                    N_Selected_Component,
6829                                    N_Slice)
6830                   and then Prefix (Context) = Expr)
6831            or else
6832                (Nkind_In (Context, N_Type_Conversion,
6833                                    N_Unchecked_Type_Conversion)
6834                   and then Expression (Context) = Expr)
6835          then
6836             return
6837               Is_Assignment_Or_Object_Expression
6838                 (Context => Parent (Context),
6839                  Expr    => Context);
6840
6841          --  Otherwise the context is not an assignment statement or an object
6842          --  declaration.
6843
6844          else
6845             return False;
6846          end if;
6847       end Is_Assignment_Or_Object_Expression;
6848
6849       ----------------------------
6850       -- Is_OK_Volatile_Context --
6851       ----------------------------
6852
6853       function Is_OK_Volatile_Context
6854         (Context : Node_Id;
6855          Obj_Ref : Node_Id) return Boolean
6856       is
6857          function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean;
6858          --  Determine whether an arbitrary node denotes a call to a protected
6859          --  entry, function or procedure in prefixed form where the prefix is
6860          --  Obj_Ref.
6861
6862          function Within_Check (Nod : Node_Id) return Boolean;
6863          --  Determine whether an arbitrary node appears in a check node
6864
6865          function Within_Subprogram_Call (Nod : Node_Id) return Boolean;
6866          --  Determine whether an arbitrary node appears in a procedure call
6867
6868          function Within_Volatile_Function (Id : Entity_Id) return Boolean;
6869          --  Determine whether an arbitrary entity appears in a volatile
6870          --  function.
6871
6872          ---------------------------------
6873          -- Is_Protected_Operation_Call --
6874          ---------------------------------
6875
6876          function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is
6877             Pref : Node_Id;
6878             Subp : Node_Id;
6879
6880          begin
6881             --  A call to a protected operations retains its selected component
6882             --  form as opposed to other prefixed calls that are transformed in
6883             --  expanded names.
6884
6885             if Nkind (Nod) = N_Selected_Component then
6886                Pref := Prefix (Nod);
6887                Subp := Selector_Name (Nod);
6888
6889                return
6890                  Pref = Obj_Ref
6891                    and then Is_Protected_Type (Etype (Pref))
6892                    and then Is_Entity_Name (Subp)
6893                    and then Ekind_In (Entity (Subp), E_Entry,
6894                                                      E_Entry_Family,
6895                                                      E_Function,
6896                                                      E_Procedure);
6897             else
6898                return False;
6899             end if;
6900          end Is_Protected_Operation_Call;
6901
6902          ------------------
6903          -- Within_Check --
6904          ------------------
6905
6906          function Within_Check (Nod : Node_Id) return Boolean is
6907             Par : Node_Id;
6908
6909          begin
6910             --  Climb the parent chain looking for a check node
6911
6912             Par := Nod;
6913             while Present (Par) loop
6914                if Nkind (Par) in N_Raise_xxx_Error then
6915                   return True;
6916
6917                --  Prevent the search from going too far
6918
6919                elsif Is_Body_Or_Package_Declaration (Par) then
6920                   exit;
6921                end if;
6922
6923                Par := Parent (Par);
6924             end loop;
6925
6926             return False;
6927          end Within_Check;
6928
6929          ----------------------------
6930          -- Within_Subprogram_Call --
6931          ----------------------------
6932
6933          function Within_Subprogram_Call (Nod : Node_Id) return Boolean is
6934             Par : Node_Id;
6935
6936          begin
6937             --  Climb the parent chain looking for a function or procedure call
6938
6939             Par := Nod;
6940             while Present (Par) loop
6941                if Nkind_In (Par, N_Function_Call,
6942                                  N_Procedure_Call_Statement)
6943                then
6944                   return True;
6945
6946                --  Prevent the search from going too far
6947
6948                elsif Is_Body_Or_Package_Declaration (Par) then
6949                   exit;
6950                end if;
6951
6952                Par := Parent (Par);
6953             end loop;
6954
6955             return False;
6956          end Within_Subprogram_Call;
6957
6958          ------------------------------
6959          -- Within_Volatile_Function --
6960          ------------------------------
6961
6962          function Within_Volatile_Function (Id : Entity_Id) return Boolean is
6963             Func_Id : Entity_Id;
6964
6965          begin
6966             --  Traverse the scope stack looking for a [generic] function
6967
6968             Func_Id := Id;
6969             while Present (Func_Id) and then Func_Id /= Standard_Standard loop
6970                if Ekind_In (Func_Id, E_Function, E_Generic_Function) then
6971                   return Is_Volatile_Function (Func_Id);
6972                end if;
6973
6974                Func_Id := Scope (Func_Id);
6975             end loop;
6976
6977             return False;
6978          end Within_Volatile_Function;
6979
6980          --  Local variables
6981
6982          Obj_Id : Entity_Id;
6983
6984       --  Start of processing for Is_OK_Volatile_Context
6985
6986       begin
6987          --  The volatile object appears on either side of an assignment
6988
6989          if Nkind (Context) = N_Assignment_Statement then
6990             return True;
6991
6992          --  The volatile object is part of the initialization expression of
6993          --  another object.
6994
6995          elsif Nkind (Context) = N_Object_Declaration
6996            and then Present (Expression (Context))
6997            and then Expression (Context) = Obj_Ref
6998          then
6999             Obj_Id := Defining_Entity (Context);
7000
7001             --  The volatile object acts as the initialization expression of an
7002             --  extended return statement. This is valid context as long as the
7003             --  function is volatile.
7004
7005             if Is_Return_Object (Obj_Id) then
7006                return Within_Volatile_Function (Obj_Id);
7007
7008             --  Otherwise this is a normal object initialization
7009
7010             else
7011                return True;
7012             end if;
7013
7014          --  The volatile object acts as the name of a renaming declaration
7015
7016          elsif Nkind (Context) = N_Object_Renaming_Declaration
7017            and then Name (Context) = Obj_Ref
7018          then
7019             return True;
7020
7021          --  The volatile object appears as an actual parameter in a call to an
7022          --  instance of Unchecked_Conversion whose result is renamed.
7023
7024          elsif Nkind (Context) = N_Function_Call
7025            and then Is_Entity_Name (Name (Context))
7026            and then Is_Unchecked_Conversion_Instance (Entity (Name (Context)))
7027            and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration
7028          then
7029             return True;
7030
7031          --  The volatile object is actually the prefix in a protected entry,
7032          --  function, or procedure call.
7033
7034          elsif Is_Protected_Operation_Call (Context) then
7035             return True;
7036
7037          --  The volatile object appears as the expression of a simple return
7038          --  statement that applies to a volatile function.
7039
7040          elsif Nkind (Context) = N_Simple_Return_Statement
7041            and then Expression (Context) = Obj_Ref
7042          then
7043             return
7044               Within_Volatile_Function (Return_Statement_Entity (Context));
7045
7046          --  The volatile object appears as the prefix of a name occurring
7047          --  in a non-interfering context.
7048
7049          elsif Nkind_In (Context, N_Attribute_Reference,
7050                                   N_Explicit_Dereference,
7051                                   N_Indexed_Component,
7052                                   N_Selected_Component,
7053                                   N_Slice)
7054            and then Prefix (Context) = Obj_Ref
7055            and then Is_OK_Volatile_Context
7056                       (Context => Parent (Context),
7057                        Obj_Ref => Context)
7058          then
7059             return True;
7060
7061          --  The volatile object appears as the expression of a type conversion
7062          --  occurring in a non-interfering context.
7063
7064          elsif Nkind_In (Context, N_Type_Conversion,
7065                                   N_Unchecked_Type_Conversion)
7066            and then Expression (Context) = Obj_Ref
7067            and then Is_OK_Volatile_Context
7068                       (Context => Parent (Context),
7069                        Obj_Ref => Context)
7070          then
7071             return True;
7072
7073          --  Allow references to volatile objects in various checks. This is
7074          --  not a direct SPARK 2014 requirement.
7075
7076          elsif Within_Check (Context) then
7077             return True;
7078
7079          --  Assume that references to effectively volatile objects that appear
7080          --  as actual parameters in a subprogram call are always legal. A full
7081          --  legality check is done when the actuals are resolved.
7082
7083          elsif Within_Subprogram_Call (Context) then
7084             return True;
7085
7086          --  Otherwise the context is not suitable for an effectively volatile
7087          --  object.
7088
7089          else
7090             return False;
7091          end if;
7092       end Is_OK_Volatile_Context;
7093
7094       --  Local variables
7095
7096       E   : constant Entity_Id := Entity (N);
7097       Par : Node_Id;
7098
7099    --  Start of processing for Resolve_Entity_Name
7100
7101    begin
7102       --  If garbage from errors, set to Any_Type and return
7103
7104       if No (E) and then Total_Errors_Detected /= 0 then
7105          Set_Etype (N, Any_Type);
7106          return;
7107       end if;
7108
7109       --  Replace named numbers by corresponding literals. Note that this is
7110       --  the one case where Resolve_Entity_Name must reset the Etype, since
7111       --  it is currently marked as universal.
7112
7113       if Ekind (E) = E_Named_Integer then
7114          Set_Etype (N, Typ);
7115          Eval_Named_Integer (N);
7116
7117       elsif Ekind (E) = E_Named_Real then
7118          Set_Etype (N, Typ);
7119          Eval_Named_Real (N);
7120
7121       --  For enumeration literals, we need to make sure that a proper style
7122       --  check is done, since such literals are overloaded, and thus we did
7123       --  not do a style check during the first phase of analysis.
7124
7125       elsif Ekind (E) = E_Enumeration_Literal then
7126          Set_Entity_With_Checks (N, E);
7127          Eval_Entity_Name (N);
7128
7129       --  Case of (sub)type name appearing in a context where an expression
7130       --  is expected. This is legal if occurrence is a current instance.
7131       --  See RM 8.6 (17/3).
7132
7133       elsif Is_Type (E) then
7134          if Is_Current_Instance (N) then
7135             null;
7136
7137          --  Any other use is an error
7138
7139          else
7140             Error_Msg_N
7141                ("invalid use of subtype mark in expression or call", N);
7142          end if;
7143
7144       --  Check discriminant use if entity is discriminant in current scope,
7145       --  i.e. discriminant of record or concurrent type currently being
7146       --  analyzed. Uses in corresponding body are unrestricted.
7147
7148       elsif Ekind (E) = E_Discriminant
7149         and then Scope (E) = Current_Scope
7150         and then not Has_Completion (Current_Scope)
7151       then
7152          Check_Discriminant_Use (N);
7153
7154       --  A parameterless generic function cannot appear in a context that
7155       --  requires resolution.
7156
7157       elsif Ekind (E) = E_Generic_Function then
7158          Error_Msg_N ("illegal use of generic function", N);
7159
7160       --  In Ada 83 an OUT parameter cannot be read
7161
7162       elsif Ekind (E) = E_Out_Parameter
7163         and then (Nkind (Parent (N)) in N_Op
7164                    or else Nkind (Parent (N)) = N_Explicit_Dereference
7165                    or else Is_Assignment_Or_Object_Expression
7166                              (Context => Parent (N),
7167                               Expr    => N))
7168       then
7169          if Ada_Version = Ada_83 then
7170             Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
7171          end if;
7172
7173       --  In all other cases, just do the possible static evaluation
7174
7175       else
7176          --  A deferred constant that appears in an expression must have a
7177          --  completion, unless it has been removed by in-place expansion of
7178          --  an aggregate. A constant that is a renaming does not need
7179          --  initialization.
7180
7181          if Ekind (E) = E_Constant
7182            and then Comes_From_Source (E)
7183            and then No (Constant_Value (E))
7184            and then Is_Frozen (Etype (E))
7185            and then not In_Spec_Expression
7186            and then not Is_Imported (E)
7187            and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration
7188          then
7189             if No_Initialization (Parent (E))
7190               or else (Present (Full_View (E))
7191                         and then No_Initialization (Parent (Full_View (E))))
7192             then
7193                null;
7194             else
7195                Error_Msg_N (
7196                  "deferred constant is frozen before completion", N);
7197             end if;
7198          end if;
7199
7200          Eval_Entity_Name (N);
7201       end if;
7202
7203       Par := Parent (N);
7204
7205       --  When the entity appears in a parameter association, retrieve the
7206       --  related subprogram call.
7207
7208       if Nkind (Par) = N_Parameter_Association then
7209          Par := Parent (Par);
7210       end if;
7211
7212       if Comes_From_Source (N) then
7213
7214          --  The following checks are only relevant when SPARK_Mode is on as
7215          --  they are not standard Ada legality rules.
7216
7217          if SPARK_Mode = On then
7218
7219             --  An effectively volatile object subject to enabled properties
7220             --  Async_Writers or Effective_Reads must appear in non-interfering
7221             --  context (SPARK RM 7.1.3(12)).
7222
7223             if Is_Object (E)
7224               and then Is_Effectively_Volatile (E)
7225               and then (Async_Writers_Enabled (E)
7226                          or else Effective_Reads_Enabled (E))
7227               and then not Is_OK_Volatile_Context (Par, N)
7228             then
7229                SPARK_Msg_N
7230                  ("volatile object cannot appear in this context "
7231                   & "(SPARK RM 7.1.3(12))", N);
7232             end if;
7233
7234             --  Check for possible elaboration issues with respect to reads of
7235             --  variables. The act of renaming the variable is not considered a
7236             --  read as it simply establishes an alias.
7237
7238             if Ekind (E) = E_Variable
7239               and then Nkind (Par) /= N_Object_Renaming_Declaration
7240             then
7241                Check_Elab_Call (N);
7242             end if;
7243          end if;
7244
7245          --  A Ghost entity must appear in a specific context
7246
7247          if Is_Ghost_Entity (E) then
7248             Check_Ghost_Context (E, N);
7249          end if;
7250       end if;
7251    end Resolve_Entity_Name;
7252
7253    -------------------
7254    -- Resolve_Entry --
7255    -------------------
7256
7257    procedure Resolve_Entry (Entry_Name : Node_Id) is
7258       Loc    : constant Source_Ptr := Sloc (Entry_Name);
7259       Nam    : Entity_Id;
7260       New_N  : Node_Id;
7261       S      : Entity_Id;
7262       Tsk    : Entity_Id;
7263       E_Name : Node_Id;
7264       Index  : Node_Id;
7265
7266       function Actual_Index_Type (E : Entity_Id) return Entity_Id;
7267       --  If the bounds of the entry family being called depend on task
7268       --  discriminants, build a new index subtype where a discriminant is
7269       --  replaced with the value of the discriminant of the target task.
7270       --  The target task is the prefix of the entry name in the call.
7271
7272       -----------------------
7273       -- Actual_Index_Type --
7274       -----------------------
7275
7276       function Actual_Index_Type (E : Entity_Id) return Entity_Id is
7277          Typ   : constant Entity_Id := Entry_Index_Type (E);
7278          Tsk   : constant Entity_Id := Scope (E);
7279          Lo    : constant Node_Id   := Type_Low_Bound  (Typ);
7280          Hi    : constant Node_Id   := Type_High_Bound (Typ);
7281          New_T : Entity_Id;
7282
7283          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
7284          --  If the bound is given by a discriminant, replace with a reference
7285          --  to the discriminant of the same name in the target task. If the
7286          --  entry name is the target of a requeue statement and the entry is
7287          --  in the current protected object, the bound to be used is the
7288          --  discriminal of the object (see Apply_Range_Checks for details of
7289          --  the transformation).
7290
7291          -----------------------------
7292          -- Actual_Discriminant_Ref --
7293          -----------------------------
7294
7295          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
7296             Typ : constant Entity_Id := Etype (Bound);
7297             Ref : Node_Id;
7298
7299          begin
7300             Remove_Side_Effects (Bound);
7301
7302             if not Is_Entity_Name (Bound)
7303               or else Ekind (Entity (Bound)) /= E_Discriminant
7304             then
7305                return Bound;
7306
7307             elsif Is_Protected_Type (Tsk)
7308               and then In_Open_Scopes (Tsk)
7309               and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
7310             then
7311                --  Note: here Bound denotes a discriminant of the corresponding
7312                --  record type tskV, whose discriminal is a formal of the
7313                --  init-proc tskVIP. What we want is the body discriminal,
7314                --  which is associated to the discriminant of the original
7315                --  concurrent type tsk.
7316
7317                return New_Occurrence_Of
7318                         (Find_Body_Discriminal (Entity (Bound)), Loc);
7319
7320             else
7321                Ref :=
7322                  Make_Selected_Component (Loc,
7323                    Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
7324                    Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
7325                Analyze (Ref);
7326                Resolve (Ref, Typ);
7327                return Ref;
7328             end if;
7329          end Actual_Discriminant_Ref;
7330
7331       --  Start of processing for Actual_Index_Type
7332
7333       begin
7334          if not Has_Discriminants (Tsk)
7335            or else (not Is_Entity_Name (Lo) and then not Is_Entity_Name (Hi))
7336          then
7337             return Entry_Index_Type (E);
7338
7339          else
7340             New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
7341             Set_Etype        (New_T, Base_Type (Typ));
7342             Set_Size_Info    (New_T, Typ);
7343             Set_RM_Size      (New_T, RM_Size (Typ));
7344             Set_Scalar_Range (New_T,
7345               Make_Range (Sloc (Entry_Name),
7346                 Low_Bound  => Actual_Discriminant_Ref (Lo),
7347                 High_Bound => Actual_Discriminant_Ref (Hi)));
7348
7349             return New_T;
7350          end if;
7351       end Actual_Index_Type;
7352
7353    --  Start of processing for Resolve_Entry
7354
7355    begin
7356       --  Find name of entry being called, and resolve prefix of name with its
7357       --  own type. The prefix can be overloaded, and the name and signature of
7358       --  the entry must be taken into account.
7359
7360       if Nkind (Entry_Name) = N_Indexed_Component then
7361
7362          --  Case of dealing with entry family within the current tasks
7363
7364          E_Name := Prefix (Entry_Name);
7365
7366       else
7367          E_Name := Entry_Name;
7368       end if;
7369
7370       if Is_Entity_Name (E_Name) then
7371
7372          --  Entry call to an entry (or entry family) in the current task. This
7373          --  is legal even though the task will deadlock. Rewrite as call to
7374          --  current task.
7375
7376          --  This can also be a call to an entry in an enclosing task. If this
7377          --  is a single task, we have to retrieve its name, because the scope
7378          --  of the entry is the task type, not the object. If the enclosing
7379          --  task is a task type, the identity of the task is given by its own
7380          --  self variable.
7381
7382          --  Finally this can be a requeue on an entry of the same task or
7383          --  protected object.
7384
7385          S := Scope (Entity (E_Name));
7386
7387          for J in reverse 0 .. Scope_Stack.Last loop
7388             if Is_Task_Type (Scope_Stack.Table (J).Entity)
7389               and then not Comes_From_Source (S)
7390             then
7391                --  S is an enclosing task or protected object. The concurrent
7392                --  declaration has been converted into a type declaration, and
7393                --  the object itself has an object declaration that follows
7394                --  the type in the same declarative part.
7395
7396                Tsk := Next_Entity (S);
7397                while Etype (Tsk) /= S loop
7398                   Next_Entity (Tsk);
7399                end loop;
7400
7401                S := Tsk;
7402                exit;
7403
7404             elsif S = Scope_Stack.Table (J).Entity then
7405
7406                --  Call to current task. Will be transformed into call to Self
7407
7408                exit;
7409
7410             end if;
7411          end loop;
7412
7413          New_N :=
7414            Make_Selected_Component (Loc,
7415              Prefix => New_Occurrence_Of (S, Loc),
7416              Selector_Name =>
7417                New_Occurrence_Of (Entity (E_Name), Loc));
7418          Rewrite (E_Name, New_N);
7419          Analyze (E_Name);
7420
7421       elsif Nkind (Entry_Name) = N_Selected_Component
7422         and then Is_Overloaded (Prefix (Entry_Name))
7423       then
7424          --  Use the entry name (which must be unique at this point) to find
7425          --  the prefix that returns the corresponding task/protected type.
7426
7427          declare
7428             Pref : constant Node_Id := Prefix (Entry_Name);
7429             Ent  : constant Entity_Id := Entity (Selector_Name (Entry_Name));
7430             I    : Interp_Index;
7431             It   : Interp;
7432
7433          begin
7434             Get_First_Interp (Pref, I, It);
7435             while Present (It.Typ) loop
7436                if Scope (Ent) = It.Typ then
7437                   Set_Etype (Pref, It.Typ);
7438                   exit;
7439                end if;
7440
7441                Get_Next_Interp (I, It);
7442             end loop;
7443          end;
7444       end if;
7445
7446       if Nkind (Entry_Name) = N_Selected_Component then
7447          Resolve (Prefix (Entry_Name));
7448
7449       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
7450          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
7451          Resolve (Prefix (Prefix (Entry_Name)));
7452          Index := First (Expressions (Entry_Name));
7453          Resolve (Index, Entry_Index_Type (Nam));
7454
7455          --  Up to this point the expression could have been the actual in a
7456          --  simple entry call, and be given by a named association.
7457
7458          if Nkind (Index) = N_Parameter_Association then
7459             Error_Msg_N ("expect expression for entry index", Index);
7460          else
7461             Apply_Range_Check (Index, Actual_Index_Type (Nam));
7462          end if;
7463       end if;
7464    end Resolve_Entry;
7465
7466    ------------------------
7467    -- Resolve_Entry_Call --
7468    ------------------------
7469
7470    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
7471       Entry_Name  : constant Node_Id    := Name (N);
7472       Loc         : constant Source_Ptr := Sloc (Entry_Name);
7473       Actuals     : List_Id;
7474       First_Named : Node_Id;
7475       Nam         : Entity_Id;
7476       Norm_OK     : Boolean;
7477       Obj         : Node_Id;
7478       Was_Over    : Boolean;
7479
7480    begin
7481       --  We kill all checks here, because it does not seem worth the effort to
7482       --  do anything better, an entry call is a big operation.
7483
7484       Kill_All_Checks;
7485
7486       --  Processing of the name is similar for entry calls and protected
7487       --  operation calls. Once the entity is determined, we can complete
7488       --  the resolution of the actuals.
7489
7490       --  The selector may be overloaded, in the case of a protected object
7491       --  with overloaded functions. The type of the context is used for
7492       --  resolution.
7493
7494       if Nkind (Entry_Name) = N_Selected_Component
7495         and then Is_Overloaded (Selector_Name (Entry_Name))
7496         and then Typ /= Standard_Void_Type
7497       then
7498          declare
7499             I  : Interp_Index;
7500             It : Interp;
7501
7502          begin
7503             Get_First_Interp (Selector_Name (Entry_Name), I, It);
7504             while Present (It.Typ) loop
7505                if Covers (Typ, It.Typ) then
7506                   Set_Entity (Selector_Name (Entry_Name), It.Nam);
7507                   Set_Etype  (Entry_Name, It.Typ);
7508
7509                   Generate_Reference (It.Typ, N, ' ');
7510                end if;
7511
7512                Get_Next_Interp (I, It);
7513             end loop;
7514          end;
7515       end if;
7516
7517       Resolve_Entry (Entry_Name);
7518
7519       if Nkind (Entry_Name) = N_Selected_Component then
7520
7521          --  Simple entry call
7522
7523          Nam := Entity (Selector_Name (Entry_Name));
7524          Obj := Prefix (Entry_Name);
7525          Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
7526
7527       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
7528
7529          --  Call to member of entry family
7530
7531          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
7532          Obj := Prefix (Prefix (Entry_Name));
7533          Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
7534       end if;
7535
7536       --  We cannot in general check the maximum depth of protected entry calls
7537       --  at compile time. But we can tell that any protected entry call at all
7538       --  violates a specified nesting depth of zero.
7539
7540       if Is_Protected_Type (Scope (Nam)) then
7541          Check_Restriction (Max_Entry_Queue_Length, N);
7542       end if;
7543
7544       --  Use context type to disambiguate a protected function that can be
7545       --  called without actuals and that returns an array type, and where the
7546       --  argument list may be an indexing of the returned value.
7547
7548       if Ekind (Nam) = E_Function
7549         and then Needs_No_Actuals (Nam)
7550         and then Present (Parameter_Associations (N))
7551         and then
7552           ((Is_Array_Type (Etype (Nam))
7553              and then Covers (Typ, Component_Type (Etype (Nam))))
7554
7555             or else (Is_Access_Type (Etype (Nam))
7556                       and then Is_Array_Type (Designated_Type (Etype (Nam)))
7557                       and then
7558                         Covers
7559                          (Typ,
7560                           Component_Type (Designated_Type (Etype (Nam))))))
7561       then
7562          declare
7563             Index_Node : Node_Id;
7564
7565          begin
7566             Index_Node :=
7567               Make_Indexed_Component (Loc,
7568                 Prefix =>
7569                   Make_Function_Call (Loc, Name => Relocate_Node (Entry_Name)),
7570                 Expressions => Parameter_Associations (N));
7571
7572             --  Since we are correcting a node classification error made by the
7573             --  parser, we call Replace rather than Rewrite.
7574
7575             Replace (N, Index_Node);
7576             Set_Etype (Prefix (N), Etype (Nam));
7577             Set_Etype (N, Typ);
7578             Resolve_Indexed_Component (N, Typ);
7579             return;
7580          end;
7581       end if;
7582
7583       if Ekind_In (Nam, E_Entry, E_Entry_Family)
7584         and then Present (Contract_Wrapper (Nam))
7585         and then Current_Scope /= Contract_Wrapper (Nam)
7586       then
7587          --  Rewrite as call to the precondition wrapper, adding the task
7588          --  object to the list of actuals. If the call is to a member of an
7589          --  entry family, include the index as well.
7590
7591          declare
7592             New_Call    : Node_Id;
7593             New_Actuals : List_Id;
7594
7595          begin
7596             New_Actuals := New_List (Obj);
7597
7598             if Nkind (Entry_Name) = N_Indexed_Component then
7599                Append_To (New_Actuals,
7600                  New_Copy_Tree (First (Expressions (Entry_Name))));
7601             end if;
7602
7603             Append_List (Parameter_Associations (N), New_Actuals);
7604             New_Call :=
7605               Make_Procedure_Call_Statement (Loc,
7606                 Name                   =>
7607                   New_Occurrence_Of (Contract_Wrapper (Nam), Loc),
7608                 Parameter_Associations => New_Actuals);
7609             Rewrite (N, New_Call);
7610
7611             --  Preanalyze and resolve new call. Current procedure is called
7612             --  from Resolve_Call, after which expansion will take place.
7613
7614             Preanalyze_And_Resolve (N);
7615             return;
7616          end;
7617       end if;
7618
7619       --  The operation name may have been overloaded. Order the actuals
7620       --  according to the formals of the resolved entity, and set the return
7621       --  type to that of the operation.
7622
7623       if Was_Over then
7624          Normalize_Actuals (N, Nam, False, Norm_OK);
7625          pragma Assert (Norm_OK);
7626          Set_Etype (N, Etype (Nam));
7627       end if;
7628
7629       Resolve_Actuals (N, Nam);
7630       Check_Internal_Protected_Use (N, Nam);
7631
7632       --  Create a call reference to the entry
7633
7634       Generate_Reference (Nam, Entry_Name, 's');
7635
7636       if Ekind_In (Nam, E_Entry, E_Entry_Family) then
7637          Check_Potentially_Blocking_Operation (N);
7638       end if;
7639
7640       --  Verify that a procedure call cannot masquerade as an entry
7641       --  call where an entry call is expected.
7642
7643       if Ekind (Nam) = E_Procedure then
7644          if Nkind (Parent (N)) = N_Entry_Call_Alternative
7645            and then N = Entry_Call_Statement (Parent (N))
7646          then
7647             Error_Msg_N ("entry call required in select statement", N);
7648
7649          elsif Nkind (Parent (N)) = N_Triggering_Alternative
7650            and then N = Triggering_Statement (Parent (N))
7651          then
7652             Error_Msg_N ("triggering statement cannot be procedure call", N);
7653
7654          elsif Ekind (Scope (Nam)) = E_Task_Type
7655            and then not In_Open_Scopes (Scope (Nam))
7656          then
7657             Error_Msg_N ("task has no entry with this name", Entry_Name);
7658          end if;
7659       end if;
7660
7661       --  After resolution, entry calls and protected procedure calls are
7662       --  changed into entry calls, for expansion. The structure of the node
7663       --  does not change, so it can safely be done in place. Protected
7664       --  function calls must keep their structure because they are
7665       --  subexpressions.
7666
7667       if Ekind (Nam) /= E_Function then
7668
7669          --  A protected operation that is not a function may modify the
7670          --  corresponding object, and cannot apply to a constant. If this
7671          --  is an internal call, the prefix is the type itself.
7672
7673          if Is_Protected_Type (Scope (Nam))
7674            and then not Is_Variable (Obj)
7675            and then (not Is_Entity_Name (Obj)
7676                        or else not Is_Type (Entity (Obj)))
7677          then
7678             Error_Msg_N
7679               ("prefix of protected procedure or entry call must be variable",
7680                Entry_Name);
7681          end if;
7682
7683          Actuals := Parameter_Associations (N);
7684          First_Named := First_Named_Actual (N);
7685
7686          Rewrite (N,
7687            Make_Entry_Call_Statement (Loc,
7688              Name                   => Entry_Name,
7689              Parameter_Associations => Actuals));
7690
7691          Set_First_Named_Actual (N, First_Named);
7692          Set_Analyzed (N, True);
7693
7694       --  Protected functions can return on the secondary stack, in which
7695       --  case we must trigger the transient scope mechanism.
7696
7697       elsif Expander_Active
7698         and then Requires_Transient_Scope (Etype (Nam))
7699       then
7700          Establish_Transient_Scope (N, Sec_Stack => True);
7701       end if;
7702    end Resolve_Entry_Call;
7703
7704    -------------------------
7705    -- Resolve_Equality_Op --
7706    -------------------------
7707
7708    --  Both arguments must have the same type, and the boolean context does
7709    --  not participate in the resolution. The first pass verifies that the
7710    --  interpretation is not ambiguous, and the type of the left argument is
7711    --  correctly set, or is Any_Type in case of ambiguity. If both arguments
7712    --  are strings or aggregates, allocators, or Null, they are ambiguous even
7713    --  though they carry a single (universal) type. Diagnose this case here.
7714
7715    procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
7716       L : constant Node_Id   := Left_Opnd (N);
7717       R : constant Node_Id   := Right_Opnd (N);
7718       T : Entity_Id := Find_Unique_Type (L, R);
7719
7720       procedure Check_If_Expression (Cond : Node_Id);
7721       --  The resolution rule for if expressions requires that each such must
7722       --  have a unique type. This means that if several dependent expressions
7723       --  are of a non-null anonymous access type, and the context does not
7724       --  impose an expected type (as can be the case in an equality operation)
7725       --  the expression must be rejected.
7726
7727       procedure Explain_Redundancy (N : Node_Id);
7728       --  Attempt to explain the nature of a redundant comparison with True. If
7729       --  the expression N is too complex, this routine issues a general error
7730       --  message.
7731
7732       function Find_Unique_Access_Type return Entity_Id;
7733       --  In the case of allocators and access attributes, the context must
7734       --  provide an indication of the specific access type to be used. If
7735       --  one operand is of such a "generic" access type, check whether there
7736       --  is a specific visible access type that has the same designated type.
7737       --  This is semantically dubious, and of no interest to any real code,
7738       --  but c48008a makes it all worthwhile.
7739
7740       -------------------------
7741       -- Check_If_Expression --
7742       -------------------------
7743
7744       procedure Check_If_Expression (Cond : Node_Id) is
7745          Then_Expr : Node_Id;
7746          Else_Expr : Node_Id;
7747
7748       begin
7749          if Nkind (Cond) = N_If_Expression then
7750             Then_Expr := Next (First (Expressions (Cond)));
7751             Else_Expr := Next (Then_Expr);
7752
7753             if Nkind (Then_Expr) /= N_Null
7754               and then Nkind (Else_Expr) /= N_Null
7755             then
7756                Error_Msg_N ("cannot determine type of if expression", Cond);
7757             end if;
7758          end if;
7759       end Check_If_Expression;
7760
7761       ------------------------
7762       -- Explain_Redundancy --
7763       ------------------------
7764
7765       procedure Explain_Redundancy (N : Node_Id) is
7766          Error  : Name_Id;
7767          Val    : Node_Id;
7768          Val_Id : Entity_Id;
7769
7770       begin
7771          Val := N;
7772
7773          --  Strip the operand down to an entity
7774
7775          loop
7776             if Nkind (Val) = N_Selected_Component then
7777                Val := Selector_Name (Val);
7778             else
7779                exit;
7780             end if;
7781          end loop;
7782
7783          --  The construct denotes an entity
7784
7785          if Is_Entity_Name (Val) and then Present (Entity (Val)) then
7786             Val_Id := Entity (Val);
7787
7788             --  Do not generate an error message when the comparison is done
7789             --  against the enumeration literal Standard.True.
7790
7791             if Ekind (Val_Id) /= E_Enumeration_Literal then
7792
7793                --  Build a customized error message
7794
7795                Name_Len := 0;
7796                Add_Str_To_Name_Buffer ("?r?");
7797
7798                if Ekind (Val_Id) = E_Component then
7799                   Add_Str_To_Name_Buffer ("component ");
7800
7801                elsif Ekind (Val_Id) = E_Constant then
7802                   Add_Str_To_Name_Buffer ("constant ");
7803
7804                elsif Ekind (Val_Id) = E_Discriminant then
7805                   Add_Str_To_Name_Buffer ("discriminant ");
7806
7807                elsif Is_Formal (Val_Id) then
7808                   Add_Str_To_Name_Buffer ("parameter ");
7809
7810                elsif Ekind (Val_Id) = E_Variable then
7811                   Add_Str_To_Name_Buffer ("variable ");
7812                end if;
7813
7814                Add_Str_To_Name_Buffer ("& is always True!");
7815                Error := Name_Find;
7816
7817                Error_Msg_NE (Get_Name_String (Error), Val, Val_Id);
7818             end if;
7819
7820          --  The construct is too complex to disect, issue a general message
7821
7822          else
7823             Error_Msg_N ("?r?expression is always True!", Val);
7824          end if;
7825       end Explain_Redundancy;
7826
7827       -----------------------------
7828       -- Find_Unique_Access_Type --
7829       -----------------------------
7830
7831       function Find_Unique_Access_Type return Entity_Id is
7832          Acc : Entity_Id;
7833          E   : Entity_Id;
7834          S   : Entity_Id;
7835
7836       begin
7837          if Ekind_In (Etype (R), E_Allocator_Type,
7838                                  E_Access_Attribute_Type)
7839          then
7840             Acc := Designated_Type (Etype (R));
7841
7842          elsif Ekind_In (Etype (L), E_Allocator_Type,
7843                                     E_Access_Attribute_Type)
7844          then
7845             Acc := Designated_Type (Etype (L));
7846          else
7847             return Empty;
7848          end if;
7849
7850          S := Current_Scope;
7851          while S /= Standard_Standard loop
7852             E := First_Entity (S);
7853             while Present (E) loop
7854                if Is_Type (E)
7855                  and then Is_Access_Type (E)
7856                  and then Ekind (E) /= E_Allocator_Type
7857                  and then Designated_Type (E) = Base_Type (Acc)
7858                then
7859                   return E;
7860                end if;
7861
7862                Next_Entity (E);
7863             end loop;
7864
7865             S := Scope (S);
7866          end loop;
7867
7868          return Empty;
7869       end Find_Unique_Access_Type;
7870
7871    --  Start of processing for Resolve_Equality_Op
7872
7873    begin
7874       Set_Etype (N, Base_Type (Typ));
7875       Generate_Reference (T, N, ' ');
7876
7877       if T = Any_Fixed then
7878          T := Unique_Fixed_Point_Type (L);
7879       end if;
7880
7881       if T /= Any_Type then
7882          if T = Any_String    or else
7883             T = Any_Composite or else
7884             T = Any_Character
7885          then
7886             if T = Any_Character then
7887                Ambiguous_Character (L);
7888             else
7889                Error_Msg_N ("ambiguous operands for equality", N);
7890             end if;
7891
7892             Set_Etype (N, Any_Type);
7893             return;
7894
7895          elsif T = Any_Access
7896            or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type)
7897          then
7898             T := Find_Unique_Access_Type;
7899
7900             if No (T) then
7901                Error_Msg_N ("ambiguous operands for equality", N);
7902                Set_Etype (N, Any_Type);
7903                return;
7904             end if;
7905
7906          --  If expressions must have a single type, and if the context does
7907          --  not impose one the dependent expressions cannot be anonymous
7908          --  access types.
7909
7910          --  Why no similar processing for case expressions???
7911
7912          elsif Ada_Version >= Ada_2012
7913            and then Ekind_In (Etype (L), E_Anonymous_Access_Type,
7914                                          E_Anonymous_Access_Subprogram_Type)
7915            and then Ekind_In (Etype (R), E_Anonymous_Access_Type,
7916                                          E_Anonymous_Access_Subprogram_Type)
7917          then
7918             Check_If_Expression (L);
7919             Check_If_Expression (R);
7920          end if;
7921
7922          Resolve (L, T);
7923          Resolve (R, T);
7924
7925          --  In SPARK, equality operators = and /= for array types other than
7926          --  String are only defined when, for each index position, the
7927          --  operands have equal static bounds.
7928
7929          if Is_Array_Type (T) then
7930
7931             --  Protect call to Matching_Static_Array_Bounds to avoid costly
7932             --  operation if not needed.
7933
7934             if Restriction_Check_Required (SPARK_05)
7935               and then Base_Type (T) /= Standard_String
7936               and then Base_Type (Etype (L)) = Base_Type (Etype (R))
7937               and then Etype (L) /= Any_Composite  --  or else L in error
7938               and then Etype (R) /= Any_Composite  --  or else R in error
7939               and then not Matching_Static_Array_Bounds (Etype (L), Etype (R))
7940             then
7941                Check_SPARK_05_Restriction
7942                  ("array types should have matching static bounds", N);
7943             end if;
7944          end if;
7945
7946          --  If the unique type is a class-wide type then it will be expanded
7947          --  into a dispatching call to the predefined primitive. Therefore we
7948          --  check here for potential violation of such restriction.
7949
7950          if Is_Class_Wide_Type (T) then
7951             Check_Restriction (No_Dispatching_Calls, N);
7952          end if;
7953
7954          if Warn_On_Redundant_Constructs
7955            and then Comes_From_Source (N)
7956            and then Comes_From_Source (R)
7957            and then Is_Entity_Name (R)
7958            and then Entity (R) = Standard_True
7959          then
7960             Error_Msg_N -- CODEFIX
7961               ("?r?comparison with True is redundant!", N);
7962             Explain_Redundancy (Original_Node (R));
7963          end if;
7964
7965          Check_Unset_Reference (L);
7966          Check_Unset_Reference (R);
7967          Generate_Operator_Reference (N, T);
7968          Check_Low_Bound_Tested (N);
7969
7970          --  If this is an inequality, it may be the implicit inequality
7971          --  created for a user-defined operation, in which case the corres-
7972          --  ponding equality operation is not intrinsic, and the operation
7973          --  cannot be constant-folded. Else fold.
7974
7975          if Nkind (N) = N_Op_Eq
7976            or else Comes_From_Source (Entity (N))
7977            or else Ekind (Entity (N)) = E_Operator
7978            or else Is_Intrinsic_Subprogram
7979                      (Corresponding_Equality (Entity (N)))
7980          then
7981             Analyze_Dimension (N);
7982             Eval_Relational_Op (N);
7983
7984          elsif Nkind (N) = N_Op_Ne
7985            and then Is_Abstract_Subprogram (Entity (N))
7986          then
7987             Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
7988          end if;
7989
7990          --  Ada 2005: If one operand is an anonymous access type, convert the
7991          --  other operand to it, to ensure that the underlying types match in
7992          --  the back-end. Same for access_to_subprogram, and the conversion
7993          --  verifies that the types are subtype conformant.
7994
7995          --  We apply the same conversion in the case one of the operands is a
7996          --  private subtype of the type of the other.
7997
7998          --  Why the Expander_Active test here ???
7999
8000          if Expander_Active
8001            and then
8002              (Ekind_In (T, E_Anonymous_Access_Type,
8003                            E_Anonymous_Access_Subprogram_Type)
8004                or else Is_Private_Type (T))
8005          then
8006             if Etype (L) /= T then
8007                Rewrite (L,
8008                  Make_Unchecked_Type_Conversion (Sloc (L),
8009                    Subtype_Mark => New_Occurrence_Of (T, Sloc (L)),
8010                    Expression   => Relocate_Node (L)));
8011                Analyze_And_Resolve (L, T);
8012             end if;
8013
8014             if (Etype (R)) /= T then
8015                Rewrite (R,
8016                   Make_Unchecked_Type_Conversion (Sloc (R),
8017                     Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)),
8018                     Expression   => Relocate_Node (R)));
8019                Analyze_And_Resolve (R, T);
8020             end if;
8021          end if;
8022       end if;
8023    end Resolve_Equality_Op;
8024
8025    ----------------------------------
8026    -- Resolve_Explicit_Dereference --
8027    ----------------------------------
8028
8029    procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
8030       Loc   : constant Source_Ptr := Sloc (N);
8031       New_N : Node_Id;
8032       P     : constant Node_Id := Prefix (N);
8033
8034       P_Typ : Entity_Id;
8035       --  The candidate prefix type, if overloaded
8036
8037       I     : Interp_Index;
8038       It    : Interp;
8039
8040    begin
8041       Check_Fully_Declared_Prefix (Typ, P);
8042       P_Typ := Empty;
8043
8044       --  A useful optimization:  check whether the dereference denotes an
8045       --  element of a container, and if so rewrite it as a call to the
8046       --  corresponding Element function.
8047
8048       --  Disabled for now, on advice of ARG. A more restricted form of the
8049       --  predicate might be acceptable ???
8050
8051       --  if Is_Container_Element (N) then
8052       --     return;
8053       --  end if;
8054
8055       if Is_Overloaded (P) then
8056
8057          --  Use the context type to select the prefix that has the correct
8058          --  designated type. Keep the first match, which will be the inner-
8059          --  most.
8060
8061          Get_First_Interp (P, I, It);
8062
8063          while Present (It.Typ) loop
8064             if Is_Access_Type (It.Typ)
8065               and then Covers (Typ, Designated_Type (It.Typ))
8066             then
8067                if No (P_Typ) then
8068                   P_Typ := It.Typ;
8069                end if;
8070
8071             --  Remove access types that do not match, but preserve access
8072             --  to subprogram interpretations, in case a further dereference
8073             --  is needed (see below).
8074
8075             elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then
8076                Remove_Interp (I);
8077             end if;
8078
8079             Get_Next_Interp (I, It);
8080          end loop;
8081
8082          if Present (P_Typ) then
8083             Resolve (P, P_Typ);
8084             Set_Etype (N, Designated_Type (P_Typ));
8085
8086          else
8087             --  If no interpretation covers the designated type of the prefix,
8088             --  this is the pathological case where not all implementations of
8089             --  the prefix allow the interpretation of the node as a call. Now
8090             --  that the expected type is known, Remove other interpretations
8091             --  from prefix, rewrite it as a call, and resolve again, so that
8092             --  the proper call node is generated.
8093
8094             Get_First_Interp (P, I, It);
8095             while Present (It.Typ) loop
8096                if Ekind (It.Typ) /= E_Access_Subprogram_Type then
8097                   Remove_Interp (I);
8098                end if;
8099
8100                Get_Next_Interp (I, It);
8101             end loop;
8102
8103             New_N :=
8104               Make_Function_Call (Loc,
8105                 Name =>
8106                   Make_Explicit_Dereference (Loc,
8107                     Prefix => P),
8108                 Parameter_Associations => New_List);
8109
8110             Save_Interps (N, New_N);
8111             Rewrite (N, New_N);
8112             Analyze_And_Resolve (N, Typ);
8113             return;
8114          end if;
8115
8116       --  If not overloaded, resolve P with its own type
8117
8118       else
8119          Resolve (P);
8120       end if;
8121
8122       --  If the prefix might be null, add an access check
8123
8124       if Is_Access_Type (Etype (P))
8125         and then not Can_Never_Be_Null (Etype (P))
8126       then
8127          Apply_Access_Check (N);
8128       end if;
8129
8130       --  If the designated type is a packed unconstrained array type, and the
8131       --  explicit dereference is not in the context of an attribute reference,
8132       --  then we must compute and set the actual subtype, since it is needed
8133       --  by Gigi. The reason we exclude the attribute case is that this is
8134       --  handled fine by Gigi, and in fact we use such attributes to build the
8135       --  actual subtype. We also exclude generated code (which builds actual
8136       --  subtypes directly if they are needed).
8137
8138       if Is_Array_Type (Etype (N))
8139         and then Is_Packed (Etype (N))
8140         and then not Is_Constrained (Etype (N))
8141         and then Nkind (Parent (N)) /= N_Attribute_Reference
8142         and then Comes_From_Source (N)
8143       then
8144          Set_Etype (N, Get_Actual_Subtype (N));
8145       end if;
8146
8147       Analyze_Dimension (N);
8148
8149       --  Note: No Eval processing is required for an explicit dereference,
8150       --  because such a name can never be static.
8151
8152    end Resolve_Explicit_Dereference;
8153
8154    -------------------------------------
8155    -- Resolve_Expression_With_Actions --
8156    -------------------------------------
8157
8158    procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is
8159    begin
8160       Set_Etype (N, Typ);
8161
8162       --  If N has no actions, and its expression has been constant folded,
8163       --  then rewrite N as just its expression. Note, we can't do this in
8164       --  the general case of Is_Empty_List (Actions (N)) as this would cause
8165       --  Expression (N) to be expanded again.
8166
8167       if Is_Empty_List (Actions (N))
8168         and then Compile_Time_Known_Value (Expression (N))
8169       then
8170          Rewrite (N, Expression (N));
8171       end if;
8172    end Resolve_Expression_With_Actions;
8173
8174    ----------------------------------
8175    -- Resolve_Generalized_Indexing --
8176    ----------------------------------
8177
8178    procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id) is
8179       Indexing : constant Node_Id := Generalized_Indexing (N);
8180       Call     : Node_Id;
8181       Indexes  : List_Id;
8182       Pref     : Node_Id;
8183
8184    begin
8185       --  In ASIS mode, propagate the information about the indexes back to
8186       --  to the original indexing node. The generalized indexing is either
8187       --  a function call, or a dereference of one. The actuals include the
8188       --  prefix of the original node, which is the container expression.
8189
8190       if ASIS_Mode then
8191          Resolve (Indexing, Typ);
8192          Set_Etype  (N, Etype (Indexing));
8193          Set_Is_Overloaded (N, False);
8194
8195          Call := Indexing;
8196          while Nkind_In (Call, N_Explicit_Dereference, N_Selected_Component)
8197          loop
8198             Call := Prefix (Call);
8199          end loop;
8200
8201          if Nkind (Call) = N_Function_Call then
8202             Indexes := Parameter_Associations (Call);
8203             Pref := Remove_Head (Indexes);
8204             Set_Expressions (N, Indexes);
8205
8206             --  If expression is to be reanalyzed, reset Generalized_Indexing
8207             --  to recreate call node, as is the case when the expression is
8208             --  part of an expression function.
8209
8210             if In_Spec_Expression then
8211                Set_Generalized_Indexing (N, Empty);
8212             end if;
8213
8214             Set_Prefix (N, Pref);
8215          end if;
8216
8217       else
8218          Rewrite (N, Indexing);
8219          Resolve (N, Typ);
8220       end if;
8221    end Resolve_Generalized_Indexing;
8222
8223    ---------------------------
8224    -- Resolve_If_Expression --
8225    ---------------------------
8226
8227    procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id) is
8228       Condition : constant Node_Id := First (Expressions (N));
8229       Then_Expr : constant Node_Id := Next (Condition);
8230       Else_Expr : Node_Id          := Next (Then_Expr);
8231       Else_Typ  : Entity_Id;
8232       Then_Typ  : Entity_Id;
8233
8234    begin
8235       Resolve (Condition, Any_Boolean);
8236       Resolve (Then_Expr, Typ);
8237       Then_Typ := Etype (Then_Expr);
8238
8239       --  When the "then" expression is of a scalar subtype different from the
8240       --  result subtype, then insert a conversion to ensure the generation of
8241       --  a constraint check. The same is done for the else part below, again
8242       --  comparing subtypes rather than base types.
8243
8244       if Is_Scalar_Type (Then_Typ)
8245         and then Then_Typ /= Typ
8246       then
8247          Rewrite (Then_Expr, Convert_To (Typ, Then_Expr));
8248          Analyze_And_Resolve (Then_Expr, Typ);
8249       end if;
8250
8251       --  If ELSE expression present, just resolve using the determined type
8252
8253       if Present (Else_Expr) then
8254          Resolve (Else_Expr, Typ);
8255          Else_Typ := Etype (Else_Expr);
8256
8257          if Is_Scalar_Type (Else_Typ) and then Else_Typ /= Typ then
8258             Rewrite (Else_Expr, Convert_To (Typ, Else_Expr));
8259             Analyze_And_Resolve (Else_Expr, Typ);
8260
8261          --  Apply RM 4.5.7 (17/3): whether the expression is statically or
8262          --  dynamically tagged must be known statically.
8263
8264          elsif Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
8265             if Is_Dynamically_Tagged (Then_Expr) /=
8266                Is_Dynamically_Tagged (Else_Expr)
8267             then
8268                Error_Msg_N ("all or none of the dependent expressions "
8269                             & "can be dynamically tagged", N);
8270             end if;
8271          end if;
8272
8273       --  If no ELSE expression is present, root type must be Standard.Boolean
8274       --  and we provide a Standard.True result converted to the appropriate
8275       --  Boolean type (in case it is a derived boolean type).
8276
8277       elsif Root_Type (Typ) = Standard_Boolean then
8278          Else_Expr :=
8279            Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N)));
8280          Analyze_And_Resolve (Else_Expr, Typ);
8281          Append_To (Expressions (N), Else_Expr);
8282
8283       else
8284          Error_Msg_N ("can only omit ELSE expression in Boolean case", N);
8285          Append_To (Expressions (N), Error);
8286       end if;
8287
8288       Set_Etype (N, Typ);
8289       Eval_If_Expression (N);
8290    end Resolve_If_Expression;
8291
8292    -------------------------------
8293    -- Resolve_Indexed_Component --
8294    -------------------------------
8295
8296    procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
8297       Name       : constant Node_Id := Prefix  (N);
8298       Expr       : Node_Id;
8299       Array_Type : Entity_Id := Empty; -- to prevent junk warning
8300       Index      : Node_Id;
8301
8302    begin
8303       if Present (Generalized_Indexing (N)) then
8304          Resolve_Generalized_Indexing (N, Typ);
8305          return;
8306       end if;
8307
8308       if Is_Overloaded (Name) then
8309
8310          --  Use the context type to select the prefix that yields the correct
8311          --  component type.
8312
8313          declare
8314             I     : Interp_Index;
8315             It    : Interp;
8316             I1    : Interp_Index := 0;
8317             P     : constant Node_Id := Prefix (N);
8318             Found : Boolean := False;
8319
8320          begin
8321             Get_First_Interp (P, I, It);
8322             while Present (It.Typ) loop
8323                if (Is_Array_Type (It.Typ)
8324                      and then Covers (Typ, Component_Type (It.Typ)))
8325                  or else (Is_Access_Type (It.Typ)
8326                             and then Is_Array_Type (Designated_Type (It.Typ))
8327                             and then
8328                               Covers
8329                                 (Typ,
8330                                  Component_Type (Designated_Type (It.Typ))))
8331                then
8332                   if Found then
8333                      It := Disambiguate (P, I1, I, Any_Type);
8334
8335                      if It = No_Interp then
8336                         Error_Msg_N ("ambiguous prefix for indexing",  N);
8337                         Set_Etype (N, Typ);
8338                         return;
8339
8340                      else
8341                         Found := True;
8342                         Array_Type := It.Typ;
8343                         I1 := I;
8344                      end if;
8345
8346                   else
8347                      Found := True;
8348                      Array_Type := It.Typ;
8349                      I1 := I;
8350                   end if;
8351                end if;
8352
8353                Get_Next_Interp (I, It);
8354             end loop;
8355          end;
8356
8357       else
8358          Array_Type := Etype (Name);
8359       end if;
8360
8361       Resolve (Name, Array_Type);
8362       Array_Type := Get_Actual_Subtype_If_Available (Name);
8363
8364       --  If prefix is access type, dereference to get real array type.
8365       --  Note: we do not apply an access check because the expander always
8366       --  introduces an explicit dereference, and the check will happen there.
8367
8368       if Is_Access_Type (Array_Type) then
8369          Array_Type := Designated_Type (Array_Type);
8370       end if;
8371
8372       --  If name was overloaded, set component type correctly now
8373       --  If a misplaced call to an entry family (which has no index types)
8374       --  return. Error will be diagnosed from calling context.
8375
8376       if Is_Array_Type (Array_Type) then
8377          Set_Etype (N, Component_Type (Array_Type));
8378       else
8379          return;
8380       end if;
8381
8382       Index := First_Index (Array_Type);
8383       Expr  := First (Expressions (N));
8384
8385       --  The prefix may have resolved to a string literal, in which case its
8386       --  etype has a special representation. This is only possible currently
8387       --  if the prefix is a static concatenation, written in functional
8388       --  notation.
8389
8390       if Ekind (Array_Type) = E_String_Literal_Subtype then
8391          Resolve (Expr, Standard_Positive);
8392
8393       else
8394          while Present (Index) and Present (Expr) loop
8395             Resolve (Expr, Etype (Index));
8396             Check_Unset_Reference (Expr);
8397
8398             if Is_Scalar_Type (Etype (Expr)) then
8399                Apply_Scalar_Range_Check (Expr, Etype (Index));
8400             else
8401                Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
8402             end if;
8403
8404             Next_Index (Index);
8405             Next (Expr);
8406          end loop;
8407       end if;
8408
8409       Analyze_Dimension (N);
8410
8411       --  Do not generate the warning on suspicious index if we are analyzing
8412       --  package Ada.Tags; otherwise we will report the warning with the
8413       --  Prims_Ptr field of the dispatch table.
8414
8415       if Scope (Etype (Prefix (N))) = Standard_Standard
8416         or else not
8417           Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))),
8418                   Ada_Tags)
8419       then
8420          Warn_On_Suspicious_Index (Name, First (Expressions (N)));
8421          Eval_Indexed_Component (N);
8422       end if;
8423
8424       --  If the array type is atomic, and the component is not atomic, then
8425       --  this is worth a warning, since we have a situation where the access
8426       --  to the component may cause extra read/writes of the atomic array
8427       --  object, or partial word accesses, which could be unexpected.
8428
8429       if Nkind (N) = N_Indexed_Component
8430         and then Is_Atomic_Ref_With_Address (N)
8431         and then not (Has_Atomic_Components (Array_Type)
8432                        or else (Is_Entity_Name (Prefix (N))
8433                                  and then Has_Atomic_Components
8434                                             (Entity (Prefix (N)))))
8435         and then not Is_Atomic (Component_Type (Array_Type))
8436       then
8437          Error_Msg_N
8438            ("??access to non-atomic component of atomic array", Prefix (N));
8439          Error_Msg_N
8440            ("??\may cause unexpected accesses to atomic object", Prefix (N));
8441       end if;
8442    end Resolve_Indexed_Component;
8443
8444    -----------------------------
8445    -- Resolve_Integer_Literal --
8446    -----------------------------
8447
8448    procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
8449    begin
8450       Set_Etype (N, Typ);
8451       Eval_Integer_Literal (N);
8452    end Resolve_Integer_Literal;
8453
8454    --------------------------------
8455    -- Resolve_Intrinsic_Operator --
8456    --------------------------------
8457
8458    procedure Resolve_Intrinsic_Operator  (N : Node_Id; Typ : Entity_Id) is
8459       Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
8460       Op   : Entity_Id;
8461       Arg1 : Node_Id;
8462       Arg2 : Node_Id;
8463
8464       function Convert_Operand (Opnd : Node_Id) return Node_Id;
8465       --  If the operand is a literal, it cannot be the expression in a
8466       --  conversion. Use a qualified expression instead.
8467
8468       ---------------------
8469       -- Convert_Operand --
8470       ---------------------
8471
8472       function Convert_Operand (Opnd : Node_Id) return Node_Id is
8473          Loc : constant Source_Ptr := Sloc (Opnd);
8474          Res : Node_Id;
8475
8476       begin
8477          if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then
8478             Res :=
8479               Make_Qualified_Expression (Loc,
8480                 Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
8481                 Expression   => Relocate_Node (Opnd));
8482             Analyze (Res);
8483
8484          else
8485             Res := Unchecked_Convert_To (Btyp, Opnd);
8486          end if;
8487
8488          return Res;
8489       end Convert_Operand;
8490
8491    --  Start of processing for Resolve_Intrinsic_Operator
8492
8493    begin
8494       --  We must preserve the original entity in a generic setting, so that
8495       --  the legality of the operation can be verified in an instance.
8496
8497       if not Expander_Active then
8498          return;
8499       end if;
8500
8501       Op := Entity (N);
8502       while Scope (Op) /= Standard_Standard loop
8503          Op := Homonym (Op);
8504          pragma Assert (Present (Op));
8505       end loop;
8506
8507       Set_Entity (N, Op);
8508       Set_Is_Overloaded (N, False);
8509
8510       --  If the result or operand types are private, rewrite with unchecked
8511       --  conversions on the operands and the result, to expose the proper
8512       --  underlying numeric type.
8513
8514       if Is_Private_Type (Typ)
8515         or else Is_Private_Type (Etype (Left_Opnd (N)))
8516         or else Is_Private_Type (Etype (Right_Opnd (N)))
8517       then
8518          Arg1 := Convert_Operand (Left_Opnd (N));
8519
8520          if Nkind (N) = N_Op_Expon then
8521             Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
8522          else
8523             Arg2 := Convert_Operand (Right_Opnd (N));
8524          end if;
8525
8526          if Nkind (Arg1) = N_Type_Conversion then
8527             Save_Interps (Left_Opnd (N),  Expression (Arg1));
8528          end if;
8529
8530          if Nkind (Arg2) = N_Type_Conversion then
8531             Save_Interps (Right_Opnd (N), Expression (Arg2));
8532          end if;
8533
8534          Set_Left_Opnd  (N, Arg1);
8535          Set_Right_Opnd (N, Arg2);
8536
8537          Set_Etype (N, Btyp);
8538          Rewrite (N, Unchecked_Convert_To (Typ, N));
8539          Resolve (N, Typ);
8540
8541       elsif Typ /= Etype (Left_Opnd (N))
8542         or else Typ /= Etype (Right_Opnd (N))
8543       then
8544          --  Add explicit conversion where needed, and save interpretations in
8545          --  case operands are overloaded.
8546
8547          Arg1 := Convert_To (Typ, Left_Opnd  (N));
8548          Arg2 := Convert_To (Typ, Right_Opnd (N));
8549
8550          if Nkind (Arg1) = N_Type_Conversion then
8551             Save_Interps (Left_Opnd (N), Expression (Arg1));
8552          else
8553             Save_Interps (Left_Opnd (N), Arg1);
8554          end if;
8555
8556          if Nkind (Arg2) = N_Type_Conversion then
8557             Save_Interps (Right_Opnd (N), Expression (Arg2));
8558          else
8559             Save_Interps (Right_Opnd (N), Arg2);
8560          end if;
8561
8562          Rewrite (Left_Opnd  (N), Arg1);
8563          Rewrite (Right_Opnd (N), Arg2);
8564          Analyze (Arg1);
8565          Analyze (Arg2);
8566          Resolve_Arithmetic_Op (N, Typ);
8567
8568       else
8569          Resolve_Arithmetic_Op (N, Typ);
8570       end if;
8571    end Resolve_Intrinsic_Operator;
8572
8573    --------------------------------------
8574    -- Resolve_Intrinsic_Unary_Operator --
8575    --------------------------------------
8576
8577    procedure Resolve_Intrinsic_Unary_Operator
8578      (N   : Node_Id;
8579       Typ : Entity_Id)
8580    is
8581       Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
8582       Op   : Entity_Id;
8583       Arg2 : Node_Id;
8584
8585    begin
8586       Op := Entity (N);
8587       while Scope (Op) /= Standard_Standard loop
8588          Op := Homonym (Op);
8589          pragma Assert (Present (Op));
8590       end loop;
8591
8592       Set_Entity (N, Op);
8593
8594       if Is_Private_Type (Typ) then
8595          Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
8596          Save_Interps (Right_Opnd (N), Expression (Arg2));
8597
8598          Set_Right_Opnd (N, Arg2);
8599
8600          Set_Etype (N, Btyp);
8601          Rewrite (N, Unchecked_Convert_To (Typ, N));
8602          Resolve (N, Typ);
8603
8604       else
8605          Resolve_Unary_Op (N, Typ);
8606       end if;
8607    end Resolve_Intrinsic_Unary_Operator;
8608
8609    ------------------------
8610    -- Resolve_Logical_Op --
8611    ------------------------
8612
8613    procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
8614       B_Typ : Entity_Id;
8615
8616    begin
8617       Check_No_Direct_Boolean_Operators (N);
8618
8619       --  Predefined operations on scalar types yield the base type. On the
8620       --  other hand, logical operations on arrays yield the type of the
8621       --  arguments (and the context).
8622
8623       if Is_Array_Type (Typ) then
8624          B_Typ := Typ;
8625       else
8626          B_Typ := Base_Type (Typ);
8627       end if;
8628
8629       --  The following test is required because the operands of the operation
8630       --  may be literals, in which case the resulting type appears to be
8631       --  compatible with a signed integer type, when in fact it is compatible
8632       --  only with modular types. If the context itself is universal, the
8633       --  operation is illegal.
8634
8635       if not Valid_Boolean_Arg (Typ) then
8636          Error_Msg_N ("invalid context for logical operation", N);
8637          Set_Etype (N, Any_Type);
8638          return;
8639
8640       elsif Typ = Any_Modular then
8641          Error_Msg_N
8642            ("no modular type available in this context", N);
8643          Set_Etype (N, Any_Type);
8644          return;
8645
8646       elsif Is_Modular_Integer_Type (Typ)
8647         and then Etype (Left_Opnd (N)) = Universal_Integer
8648         and then Etype (Right_Opnd (N)) = Universal_Integer
8649       then
8650          Check_For_Visible_Operator (N, B_Typ);
8651       end if;
8652
8653       --  Replace AND by AND THEN, or OR by OR ELSE, if Short_Circuit_And_Or
8654       --  is active and the result type is standard Boolean (do not mess with
8655       --  ops that return a nonstandard Boolean type, because something strange
8656       --  is going on).
8657
8658       --  Note: you might expect this replacement to be done during expansion,
8659       --  but that doesn't work, because when the pragma Short_Circuit_And_Or
8660       --  is used, no part of the right operand of an "and" or "or" operator
8661       --  should be executed if the left operand would short-circuit the
8662       --  evaluation of the corresponding "and then" or "or else". If we left
8663       --  the replacement to expansion time, then run-time checks associated
8664       --  with such operands would be evaluated unconditionally, due to being
8665       --  before the condition prior to the rewriting as short-circuit forms
8666       --  during expansion.
8667
8668       if Short_Circuit_And_Or
8669         and then B_Typ = Standard_Boolean
8670         and then Nkind_In (N, N_Op_And, N_Op_Or)
8671       then
8672          --  Mark the corresponding putative SCO operator as truly a logical
8673          --  (and short-circuit) operator.
8674
8675          if Generate_SCO and then Comes_From_Source (N) then
8676             Set_SCO_Logical_Operator (N);
8677          end if;
8678
8679          if Nkind (N) = N_Op_And then
8680             Rewrite (N,
8681               Make_And_Then (Sloc (N),
8682                 Left_Opnd  => Relocate_Node (Left_Opnd (N)),
8683                 Right_Opnd => Relocate_Node (Right_Opnd (N))));
8684             Analyze_And_Resolve (N, B_Typ);
8685
8686          --  Case of OR changed to OR ELSE
8687
8688          else
8689             Rewrite (N,
8690               Make_Or_Else (Sloc (N),
8691                 Left_Opnd  => Relocate_Node (Left_Opnd (N)),
8692                 Right_Opnd => Relocate_Node (Right_Opnd (N))));
8693             Analyze_And_Resolve (N, B_Typ);
8694          end if;
8695
8696          --  Return now, since analysis of the rewritten ops will take care of
8697          --  other reference bookkeeping and expression folding.
8698
8699          return;
8700       end if;
8701
8702       Resolve (Left_Opnd (N), B_Typ);
8703       Resolve (Right_Opnd (N), B_Typ);
8704
8705       Check_Unset_Reference (Left_Opnd  (N));
8706       Check_Unset_Reference (Right_Opnd (N));
8707
8708       Set_Etype (N, B_Typ);
8709       Generate_Operator_Reference (N, B_Typ);
8710       Eval_Logical_Op (N);
8711
8712       --  In SPARK, logical operations AND, OR and XOR for arrays are defined
8713       --  only when both operands have same static lower and higher bounds. Of
8714       --  course the types have to match, so only check if operands are
8715       --  compatible and the node itself has no errors.
8716
8717       if Is_Array_Type (B_Typ)
8718         and then Nkind (N) in N_Binary_Op
8719       then
8720          declare
8721             Left_Typ  : constant Node_Id := Etype (Left_Opnd (N));
8722             Right_Typ : constant Node_Id := Etype (Right_Opnd (N));
8723
8724          begin
8725             --  Protect call to Matching_Static_Array_Bounds to avoid costly
8726             --  operation if not needed.
8727
8728             if Restriction_Check_Required (SPARK_05)
8729               and then Base_Type (Left_Typ) = Base_Type (Right_Typ)
8730               and then Left_Typ /= Any_Composite  --  or Left_Opnd in error
8731               and then Right_Typ /= Any_Composite  --  or Right_Opnd in error
8732               and then not Matching_Static_Array_Bounds (Left_Typ, Right_Typ)
8733             then
8734                Check_SPARK_05_Restriction
8735                  ("array types should have matching static bounds", N);
8736             end if;
8737          end;
8738       end if;
8739    end Resolve_Logical_Op;
8740
8741    ---------------------------
8742    -- Resolve_Membership_Op --
8743    ---------------------------
8744
8745    --  The context can only be a boolean type, and does not determine the
8746    --  arguments. Arguments should be unambiguous, but the preference rule for
8747    --  universal types applies.
8748
8749    procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
8750       pragma Warnings (Off, Typ);
8751
8752       L : constant Node_Id := Left_Opnd  (N);
8753       R : constant Node_Id := Right_Opnd (N);
8754       T : Entity_Id;
8755
8756       procedure Resolve_Set_Membership;
8757       --  Analysis has determined a unique type for the left operand. Use it to
8758       --  resolve the disjuncts.
8759
8760       ----------------------------
8761       -- Resolve_Set_Membership --
8762       ----------------------------
8763
8764       procedure Resolve_Set_Membership is
8765          Alt  : Node_Id;
8766          Ltyp : Entity_Id;
8767
8768       begin
8769          --  If the left operand is overloaded, find type compatible with not
8770          --  overloaded alternative of the right operand.
8771
8772          if Is_Overloaded (L) then
8773             Ltyp := Empty;
8774             Alt := First (Alternatives (N));
8775             while Present (Alt) loop
8776                if not Is_Overloaded (Alt) then
8777                   Ltyp := Intersect_Types (L, Alt);
8778                   exit;
8779                else
8780                   Next (Alt);
8781                end if;
8782             end loop;
8783
8784             --  Unclear how to resolve expression if all alternatives are also
8785             --  overloaded.
8786
8787             if No (Ltyp) then
8788                Error_Msg_N ("ambiguous expression", N);
8789             end if;
8790
8791          else
8792             Ltyp := Etype (L);
8793          end if;
8794
8795          Resolve (L, Ltyp);
8796
8797          Alt := First (Alternatives (N));
8798          while Present (Alt) loop
8799
8800             --  Alternative is an expression, a range
8801             --  or a subtype mark.
8802
8803             if not Is_Entity_Name (Alt)
8804               or else not Is_Type (Entity (Alt))
8805             then
8806                Resolve (Alt, Ltyp);
8807             end if;
8808
8809             Next (Alt);
8810          end loop;
8811
8812          --  Check for duplicates for discrete case
8813
8814          if Is_Discrete_Type (Ltyp) then
8815             declare
8816                type Ent is record
8817                   Alt : Node_Id;
8818                   Val : Uint;
8819                end record;
8820
8821                Alts  : array (0 .. List_Length (Alternatives (N))) of Ent;
8822                Nalts : Nat;
8823
8824             begin
8825                --  Loop checking duplicates. This is quadratic, but giant sets
8826                --  are unlikely in this context so it's a reasonable choice.
8827
8828                Nalts := 0;
8829                Alt := First (Alternatives (N));
8830                while Present (Alt) loop
8831                   if Is_OK_Static_Expression (Alt)
8832                     and then (Nkind_In (Alt, N_Integer_Literal,
8833                                              N_Character_Literal)
8834                                or else Nkind (Alt) in N_Has_Entity)
8835                   then
8836                      Nalts := Nalts + 1;
8837                      Alts (Nalts) := (Alt, Expr_Value (Alt));
8838
8839                      for J in 1 .. Nalts - 1 loop
8840                         if Alts (J).Val = Alts (Nalts).Val then
8841                            Error_Msg_Sloc := Sloc (Alts (J).Alt);
8842                            Error_Msg_N ("duplicate of value given#??", Alt);
8843                         end if;
8844                      end loop;
8845                   end if;
8846
8847                   Alt := Next (Alt);
8848                end loop;
8849             end;
8850          end if;
8851       end Resolve_Set_Membership;
8852
8853    --  Start of processing for Resolve_Membership_Op
8854
8855    begin
8856       if L = Error or else R = Error then
8857          return;
8858       end if;
8859
8860       if Present (Alternatives (N)) then
8861          Resolve_Set_Membership;
8862          goto SM_Exit;
8863
8864       elsif not Is_Overloaded (R)
8865         and then
8866           (Etype (R) = Universal_Integer
8867              or else
8868            Etype (R) = Universal_Real)
8869         and then Is_Overloaded (L)
8870       then
8871          T := Etype (R);
8872
8873       --  Ada 2005 (AI-251): Support the following case:
8874
8875       --      type I is interface;
8876       --      type T is tagged ...
8877
8878       --      function Test (O : I'Class) is
8879       --      begin
8880       --         return O in T'Class.
8881       --      end Test;
8882
8883       --  In this case we have nothing else to do. The membership test will be
8884       --  done at run time.
8885
8886       elsif Ada_Version >= Ada_2005
8887         and then Is_Class_Wide_Type (Etype (L))
8888         and then Is_Interface (Etype (L))
8889         and then Is_Class_Wide_Type (Etype (R))
8890         and then not Is_Interface (Etype (R))
8891       then
8892          return;
8893       else
8894          T := Intersect_Types (L, R);
8895       end if;
8896
8897       --  If mixed-mode operations are present and operands are all literal,
8898       --  the only interpretation involves Duration, which is probably not
8899       --  the intention of the programmer.
8900
8901       if T = Any_Fixed then
8902          T := Unique_Fixed_Point_Type (N);
8903
8904          if T = Any_Type then
8905             return;
8906          end if;
8907       end if;
8908
8909       Resolve (L, T);
8910       Check_Unset_Reference (L);
8911
8912       if Nkind (R) = N_Range
8913         and then not Is_Scalar_Type (T)
8914       then
8915          Error_Msg_N ("scalar type required for range", R);
8916       end if;
8917
8918       if Is_Entity_Name (R) then
8919          Freeze_Expression (R);
8920       else
8921          Resolve (R, T);
8922          Check_Unset_Reference (R);
8923       end if;
8924
8925       --  Here after resolving membership operation
8926
8927       <<SM_Exit>>
8928
8929       Eval_Membership_Op (N);
8930    end Resolve_Membership_Op;
8931
8932    ------------------
8933    -- Resolve_Null --
8934    ------------------
8935
8936    procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
8937       Loc : constant Source_Ptr := Sloc (N);
8938
8939    begin
8940       --  Handle restriction against anonymous null access values This
8941       --  restriction can be turned off using -gnatdj.
8942
8943       --  Ada 2005 (AI-231): Remove restriction
8944
8945       if Ada_Version < Ada_2005
8946         and then not Debug_Flag_J
8947         and then Ekind (Typ) = E_Anonymous_Access_Type
8948         and then Comes_From_Source (N)
8949       then
8950          --  In the common case of a call which uses an explicitly null value
8951          --  for an access parameter, give specialized error message.
8952
8953          if Nkind (Parent (N)) in N_Subprogram_Call then
8954             Error_Msg_N
8955               ("null is not allowed as argument for an access parameter", N);
8956
8957          --  Standard message for all other cases (are there any?)
8958
8959          else
8960             Error_Msg_N
8961               ("null cannot be of an anonymous access type", N);
8962          end if;
8963       end if;
8964
8965       --  Ada 2005 (AI-231): Generate the null-excluding check in case of
8966       --  assignment to a null-excluding object
8967
8968       if Ada_Version >= Ada_2005
8969         and then Can_Never_Be_Null (Typ)
8970         and then Nkind (Parent (N)) = N_Assignment_Statement
8971       then
8972          if not Inside_Init_Proc then
8973             Insert_Action
8974               (Compile_Time_Constraint_Error (N,
8975                  "(Ada 2005) null not allowed in null-excluding objects??"),
8976                Make_Raise_Constraint_Error (Loc,
8977                  Reason => CE_Access_Check_Failed));
8978          else
8979             Insert_Action (N,
8980               Make_Raise_Constraint_Error (Loc,
8981                 Reason => CE_Access_Check_Failed));
8982          end if;
8983       end if;
8984
8985       --  In a distributed context, null for a remote access to subprogram may
8986       --  need to be replaced with a special record aggregate. In this case,
8987       --  return after having done the transformation.
8988
8989       if (Ekind (Typ) = E_Record_Type
8990            or else Is_Remote_Access_To_Subprogram_Type (Typ))
8991         and then Remote_AST_Null_Value (N, Typ)
8992       then
8993          return;
8994       end if;
8995
8996       --  The null literal takes its type from the context
8997
8998       Set_Etype (N, Typ);
8999    end Resolve_Null;
9000
9001    -----------------------
9002    -- Resolve_Op_Concat --
9003    -----------------------
9004
9005    procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
9006
9007       --  We wish to avoid deep recursion, because concatenations are often
9008       --  deeply nested, as in A&B&...&Z. Therefore, we walk down the left
9009       --  operands nonrecursively until we find something that is not a simple
9010       --  concatenation (A in this case). We resolve that, and then walk back
9011       --  up the tree following Parent pointers, calling Resolve_Op_Concat_Rest
9012       --  to do the rest of the work at each level. The Parent pointers allow
9013       --  us to avoid recursion, and thus avoid running out of memory. See also
9014       --  Sem_Ch4.Analyze_Concatenation, where a similar approach is used.
9015
9016       NN  : Node_Id := N;
9017       Op1 : Node_Id;
9018
9019    begin
9020       --  The following code is equivalent to:
9021
9022       --    Resolve_Op_Concat_First (NN, Typ);
9023       --    Resolve_Op_Concat_Arg (N, ...);
9024       --    Resolve_Op_Concat_Rest (N, Typ);
9025
9026       --  where the Resolve_Op_Concat_Arg call recurses back here if the left
9027       --  operand is a concatenation.
9028
9029       --  Walk down left operands
9030
9031       loop
9032          Resolve_Op_Concat_First (NN, Typ);
9033          Op1 := Left_Opnd (NN);
9034          exit when not (Nkind (Op1) = N_Op_Concat
9035                          and then not Is_Array_Type (Component_Type (Typ))
9036                          and then Entity (Op1) = Entity (NN));
9037          NN := Op1;
9038       end loop;
9039
9040       --  Now (given the above example) NN is A&B and Op1 is A
9041
9042       --  First resolve Op1 ...
9043
9044       Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd  (NN));
9045
9046       --  ... then walk NN back up until we reach N (where we started), calling
9047       --  Resolve_Op_Concat_Rest along the way.
9048
9049       loop
9050          Resolve_Op_Concat_Rest (NN, Typ);
9051          exit when NN = N;
9052          NN := Parent (NN);
9053       end loop;
9054
9055       if Base_Type (Etype (N)) /= Standard_String then
9056          Check_SPARK_05_Restriction
9057            ("result of concatenation should have type String", N);
9058       end if;
9059    end Resolve_Op_Concat;
9060
9061    ---------------------------
9062    -- Resolve_Op_Concat_Arg --
9063    ---------------------------
9064
9065    procedure Resolve_Op_Concat_Arg
9066      (N       : Node_Id;
9067       Arg     : Node_Id;
9068       Typ     : Entity_Id;
9069       Is_Comp : Boolean)
9070    is
9071       Btyp : constant Entity_Id := Base_Type (Typ);
9072       Ctyp : constant Entity_Id := Component_Type (Typ);
9073
9074    begin
9075       if In_Instance then
9076          if Is_Comp
9077            or else (not Is_Overloaded (Arg)
9078                      and then Etype (Arg) /= Any_Composite
9079                      and then Covers (Ctyp, Etype (Arg)))
9080          then
9081             Resolve (Arg, Ctyp);
9082          else
9083             Resolve (Arg, Btyp);
9084          end if;
9085
9086       --  If both Array & Array and Array & Component are visible, there is a
9087       --  potential ambiguity that must be reported.
9088
9089       elsif Has_Compatible_Type (Arg, Ctyp) then
9090          if Nkind (Arg) = N_Aggregate
9091            and then Is_Composite_Type (Ctyp)
9092          then
9093             if Is_Private_Type (Ctyp) then
9094                Resolve (Arg, Btyp);
9095
9096             --  If the operation is user-defined and not overloaded use its
9097             --  profile. The operation may be a renaming, in which case it has
9098             --  been rewritten, and we want the original profile.
9099
9100             elsif not Is_Overloaded (N)
9101               and then Comes_From_Source (Entity (Original_Node (N)))
9102               and then Ekind (Entity (Original_Node (N))) = E_Function
9103             then
9104                Resolve (Arg,
9105                  Etype
9106                    (Next_Formal (First_Formal (Entity (Original_Node (N))))));
9107                return;
9108
9109             --  Otherwise an aggregate may match both the array type and the
9110             --  component type.
9111
9112             else
9113                Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
9114                Set_Etype (Arg, Any_Type);
9115             end if;
9116
9117          else
9118             if Is_Overloaded (Arg)
9119               and then Has_Compatible_Type (Arg, Typ)
9120               and then Etype (Arg) /= Any_Type
9121             then
9122                declare
9123                   I    : Interp_Index;
9124                   It   : Interp;
9125                   Func : Entity_Id;
9126
9127                begin
9128                   Get_First_Interp (Arg, I, It);
9129                   Func := It.Nam;
9130                   Get_Next_Interp (I, It);
9131
9132                   --  Special-case the error message when the overloading is
9133                   --  caused by a function that yields an array and can be
9134                   --  called without parameters.
9135
9136                   if It.Nam = Func then
9137                      Error_Msg_Sloc := Sloc (Func);
9138                      Error_Msg_N ("ambiguous call to function#", Arg);
9139                      Error_Msg_NE
9140                        ("\\interpretation as call yields&", Arg, Typ);
9141                      Error_Msg_NE
9142                        ("\\interpretation as indexing of call yields&",
9143                          Arg, Component_Type (Typ));
9144
9145                   else
9146                      Error_Msg_N ("ambiguous operand for concatenation!", Arg);
9147
9148                      Get_First_Interp (Arg, I, It);
9149                      while Present (It.Nam) loop
9150                         Error_Msg_Sloc := Sloc (It.Nam);
9151
9152                         if Base_Type (It.Typ) = Btyp
9153                              or else
9154                            Base_Type (It.Typ) = Base_Type (Ctyp)
9155                         then
9156                            Error_Msg_N -- CODEFIX
9157                              ("\\possible interpretation#", Arg);
9158                         end if;
9159
9160                         Get_Next_Interp (I, It);
9161                      end loop;
9162                   end if;
9163                end;
9164             end if;
9165
9166             Resolve (Arg, Component_Type (Typ));
9167
9168             if Nkind (Arg) = N_String_Literal then
9169                Set_Etype (Arg, Component_Type (Typ));
9170             end if;
9171
9172             if Arg = Left_Opnd (N) then
9173                Set_Is_Component_Left_Opnd (N);
9174             else
9175                Set_Is_Component_Right_Opnd (N);
9176             end if;
9177          end if;
9178
9179       else
9180          Resolve (Arg, Btyp);
9181       end if;
9182
9183       --  Concatenation is restricted in SPARK: each operand must be either a
9184       --  string literal, the name of a string constant, a static character or
9185       --  string expression, or another concatenation. Arg cannot be a
9186       --  concatenation here as callers of Resolve_Op_Concat_Arg call it
9187       --  separately on each final operand, past concatenation operations.
9188
9189       if Is_Character_Type (Etype (Arg)) then
9190          if not Is_OK_Static_Expression (Arg) then
9191             Check_SPARK_05_Restriction
9192               ("character operand for concatenation should be static", Arg);
9193          end if;
9194
9195       elsif Is_String_Type (Etype (Arg)) then
9196          if not (Nkind_In (Arg, N_Identifier, N_Expanded_Name)
9197                   and then Is_Constant_Object (Entity (Arg)))
9198            and then not Is_OK_Static_Expression (Arg)
9199          then
9200             Check_SPARK_05_Restriction
9201               ("string operand for concatenation should be static", Arg);
9202          end if;
9203
9204       --  Do not issue error on an operand that is neither a character nor a
9205       --  string, as the error is issued in Resolve_Op_Concat.
9206
9207       else
9208          null;
9209       end if;
9210
9211       Check_Unset_Reference (Arg);
9212    end Resolve_Op_Concat_Arg;
9213
9214    -----------------------------
9215    -- Resolve_Op_Concat_First --
9216    -----------------------------
9217
9218    procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is
9219       Btyp : constant Entity_Id := Base_Type (Typ);
9220       Op1  : constant Node_Id := Left_Opnd (N);
9221       Op2  : constant Node_Id := Right_Opnd (N);
9222
9223    begin
9224       --  The parser folds an enormous sequence of concatenations of string
9225       --  literals into "" & "...", where the Is_Folded_In_Parser flag is set
9226       --  in the right operand. If the expression resolves to a predefined "&"
9227       --  operator, all is well. Otherwise, the parser's folding is wrong, so
9228       --  we give an error. See P_Simple_Expression in Par.Ch4.
9229
9230       if Nkind (Op2) = N_String_Literal
9231         and then Is_Folded_In_Parser (Op2)
9232         and then Ekind (Entity (N)) = E_Function
9233       then
9234          pragma Assert (Nkind (Op1) = N_String_Literal  --  should be ""
9235                and then String_Length (Strval (Op1)) = 0);
9236          Error_Msg_N ("too many user-defined concatenations", N);
9237          return;
9238       end if;
9239
9240       Set_Etype (N, Btyp);
9241
9242       if Is_Limited_Composite (Btyp) then
9243          Error_Msg_N ("concatenation not available for limited array", N);
9244          Explain_Limited_Type (Btyp, N);
9245       end if;
9246    end Resolve_Op_Concat_First;
9247
9248    ----------------------------
9249    -- Resolve_Op_Concat_Rest --
9250    ----------------------------
9251
9252    procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is
9253       Op1  : constant Node_Id := Left_Opnd (N);
9254       Op2  : constant Node_Id := Right_Opnd (N);
9255
9256    begin
9257       Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd  (N));
9258
9259       Generate_Operator_Reference (N, Typ);
9260
9261       if Is_String_Type (Typ) then
9262          Eval_Concatenation (N);
9263       end if;
9264
9265       --  If this is not a static concatenation, but the result is a string
9266       --  type (and not an array of strings) ensure that static string operands
9267       --  have their subtypes properly constructed.
9268
9269       if Nkind (N) /= N_String_Literal
9270         and then Is_Character_Type (Component_Type (Typ))
9271       then
9272          Set_String_Literal_Subtype (Op1, Typ);
9273          Set_String_Literal_Subtype (Op2, Typ);
9274       end if;
9275    end Resolve_Op_Concat_Rest;
9276
9277    ----------------------
9278    -- Resolve_Op_Expon --
9279    ----------------------
9280
9281    procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
9282       B_Typ : constant Entity_Id := Base_Type (Typ);
9283
9284    begin
9285       --  Catch attempts to do fixed-point exponentiation with universal
9286       --  operands, which is a case where the illegality is not caught during
9287       --  normal operator analysis. This is not done in preanalysis mode
9288       --  since the tree is not fully decorated during preanalysis.
9289
9290       if Full_Analysis then
9291          if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
9292             Error_Msg_N ("exponentiation not available for fixed point", N);
9293             return;
9294
9295          elsif Nkind (Parent (N)) in N_Op
9296            and then Is_Fixed_Point_Type (Etype (Parent (N)))
9297            and then Etype (N) = Universal_Real
9298            and then Comes_From_Source (N)
9299          then
9300             Error_Msg_N ("exponentiation not available for fixed point", N);
9301             return;
9302          end if;
9303       end if;
9304
9305       if Comes_From_Source (N)
9306         and then Ekind (Entity (N)) = E_Function
9307         and then Is_Imported (Entity (N))
9308         and then Is_Intrinsic_Subprogram (Entity (N))
9309       then
9310          Resolve_Intrinsic_Operator (N, Typ);
9311          return;
9312       end if;
9313
9314       if Etype (Left_Opnd (N)) = Universal_Integer
9315         or else Etype (Left_Opnd (N)) = Universal_Real
9316       then
9317          Check_For_Visible_Operator (N, B_Typ);
9318       end if;
9319
9320       --  We do the resolution using the base type, because intermediate values
9321       --  in expressions are always of the base type, not a subtype of it.
9322
9323       Resolve (Left_Opnd (N), B_Typ);
9324       Resolve (Right_Opnd (N), Standard_Integer);
9325
9326       --  For integer types, right argument must be in Natural range
9327
9328       if Is_Integer_Type (Typ) then
9329          Apply_Scalar_Range_Check (Right_Opnd (N), Standard_Natural);
9330       end if;
9331
9332       Check_Unset_Reference (Left_Opnd  (N));
9333       Check_Unset_Reference (Right_Opnd (N));
9334
9335       Set_Etype (N, B_Typ);
9336       Generate_Operator_Reference (N, B_Typ);
9337
9338       Analyze_Dimension (N);
9339
9340       if Ada_Version >= Ada_2012 and then Has_Dimension_System (B_Typ) then
9341          --  Evaluate the exponentiation operator for dimensioned type
9342
9343          Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ);
9344       else
9345          Eval_Op_Expon (N);
9346       end if;
9347
9348       --  Set overflow checking bit. Much cleverer code needed here eventually
9349       --  and perhaps the Resolve routines should be separated for the various
9350       --  arithmetic operations, since they will need different processing. ???
9351
9352       if Nkind (N) in N_Op then
9353          if not Overflow_Checks_Suppressed (Etype (N)) then
9354             Enable_Overflow_Check (N);
9355          end if;
9356       end if;
9357    end Resolve_Op_Expon;
9358
9359    --------------------
9360    -- Resolve_Op_Not --
9361    --------------------
9362
9363    procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
9364       B_Typ : Entity_Id;
9365
9366       function Parent_Is_Boolean return Boolean;
9367       --  This function determines if the parent node is a boolean operator or
9368       --  operation (comparison op, membership test, or short circuit form) and
9369       --  the not in question is the left operand of this operation. Note that
9370       --  if the not is in parens, then false is returned.
9371
9372       -----------------------
9373       -- Parent_Is_Boolean --
9374       -----------------------
9375
9376       function Parent_Is_Boolean return Boolean is
9377       begin
9378          if Paren_Count (N) /= 0 then
9379             return False;
9380
9381          else
9382             case Nkind (Parent (N)) is
9383                when N_Op_And   |
9384                     N_Op_Eq    |
9385                     N_Op_Ge    |
9386                     N_Op_Gt    |
9387                     N_Op_Le    |
9388                     N_Op_Lt    |
9389                     N_Op_Ne    |
9390                     N_Op_Or    |
9391                     N_Op_Xor   |
9392                     N_In       |
9393                     N_Not_In   |
9394                     N_And_Then |
9395                     N_Or_Else  =>
9396
9397                   return Left_Opnd (Parent (N)) = N;
9398
9399                when others =>
9400                   return False;
9401             end case;
9402          end if;
9403       end Parent_Is_Boolean;
9404
9405    --  Start of processing for Resolve_Op_Not
9406
9407    begin
9408       --  Predefined operations on scalar types yield the base type. On the
9409       --  other hand, logical operations on arrays yield the type of the
9410       --  arguments (and the context).
9411
9412       if Is_Array_Type (Typ) then
9413          B_Typ := Typ;
9414       else
9415          B_Typ := Base_Type (Typ);
9416       end if;
9417
9418       --  Straightforward case of incorrect arguments
9419
9420       if not Valid_Boolean_Arg (Typ) then
9421          Error_Msg_N ("invalid operand type for operator&", N);
9422          Set_Etype (N, Any_Type);
9423          return;
9424
9425       --  Special case of probable missing parens
9426
9427       elsif Typ = Universal_Integer or else Typ = Any_Modular then
9428          if Parent_Is_Boolean then
9429             Error_Msg_N
9430               ("operand of not must be enclosed in parentheses",
9431                Right_Opnd (N));
9432          else
9433             Error_Msg_N
9434               ("no modular type available in this context", N);
9435          end if;
9436
9437          Set_Etype (N, Any_Type);
9438          return;
9439
9440       --  OK resolution of NOT
9441
9442       else
9443          --  Warn if non-boolean types involved. This is a case like not a < b
9444          --  where a and b are modular, where we will get (not a) < b and most
9445          --  likely not (a < b) was intended.
9446
9447          if Warn_On_Questionable_Missing_Parens
9448            and then not Is_Boolean_Type (Typ)
9449            and then Parent_Is_Boolean
9450          then
9451             Error_Msg_N ("?q?not expression should be parenthesized here!", N);
9452          end if;
9453
9454          --  Warn on double negation if checking redundant constructs
9455
9456          if Warn_On_Redundant_Constructs
9457            and then Comes_From_Source (N)
9458            and then Comes_From_Source (Right_Opnd (N))
9459            and then Root_Type (Typ) = Standard_Boolean
9460            and then Nkind (Right_Opnd (N)) = N_Op_Not
9461          then
9462             Error_Msg_N ("redundant double negation?r?", N);
9463          end if;
9464
9465          --  Complete resolution and evaluation of NOT
9466
9467          Resolve (Right_Opnd (N), B_Typ);
9468          Check_Unset_Reference (Right_Opnd (N));
9469          Set_Etype (N, B_Typ);
9470          Generate_Operator_Reference (N, B_Typ);
9471          Eval_Op_Not (N);
9472       end if;
9473    end Resolve_Op_Not;
9474
9475    -----------------------------
9476    -- Resolve_Operator_Symbol --
9477    -----------------------------
9478
9479    --  Nothing to be done, all resolved already
9480
9481    procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
9482       pragma Warnings (Off, N);
9483       pragma Warnings (Off, Typ);
9484
9485    begin
9486       null;
9487    end Resolve_Operator_Symbol;
9488
9489    ----------------------------------
9490    -- Resolve_Qualified_Expression --
9491    ----------------------------------
9492
9493    procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
9494       pragma Warnings (Off, Typ);
9495
9496       Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
9497       Expr       : constant Node_Id   := Expression (N);
9498
9499    begin
9500       Resolve (Expr, Target_Typ);
9501
9502       --  Protect call to Matching_Static_Array_Bounds to avoid costly
9503       --  operation if not needed.
9504
9505       if Restriction_Check_Required (SPARK_05)
9506         and then Is_Array_Type (Target_Typ)
9507         and then Is_Array_Type (Etype (Expr))
9508         and then Etype (Expr) /= Any_Composite  --  or else Expr in error
9509         and then not Matching_Static_Array_Bounds (Target_Typ, Etype (Expr))
9510       then
9511          Check_SPARK_05_Restriction
9512            ("array types should have matching static bounds", N);
9513       end if;
9514
9515       --  A qualified expression requires an exact match of the type, class-
9516       --  wide matching is not allowed. However, if the qualifying type is
9517       --  specific and the expression has a class-wide type, it may still be
9518       --  okay, since it can be the result of the expansion of a call to a
9519       --  dispatching function, so we also have to check class-wideness of the
9520       --  type of the expression's original node.
9521
9522       if (Is_Class_Wide_Type (Target_Typ)
9523            or else
9524              (Is_Class_Wide_Type (Etype (Expr))
9525                and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
9526         and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
9527       then
9528          Wrong_Type (Expr, Target_Typ);
9529       end if;
9530
9531       --  If the target type is unconstrained, then we reset the type of the
9532       --  result from the type of the expression. For other cases, the actual
9533       --  subtype of the expression is the target type.
9534
9535       if Is_Composite_Type (Target_Typ)
9536         and then not Is_Constrained (Target_Typ)
9537       then
9538          Set_Etype (N, Etype (Expr));
9539       end if;
9540
9541       Analyze_Dimension (N);
9542       Eval_Qualified_Expression (N);
9543
9544       --  If we still have a qualified expression after the static evaluation,
9545       --  then apply a scalar range check if needed. The reason that we do this
9546       --  after the Eval call is that otherwise, the application of the range
9547       --  check may convert an illegal static expression and result in warning
9548       --  rather than giving an error (e.g Integer'(Integer'Last + 1)).
9549
9550       if Nkind (N) = N_Qualified_Expression and then Is_Scalar_Type (Typ) then
9551          Apply_Scalar_Range_Check (Expr, Typ);
9552       end if;
9553    end Resolve_Qualified_Expression;
9554
9555    ------------------------------
9556    -- Resolve_Raise_Expression --
9557    ------------------------------
9558
9559    procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id) is
9560    begin
9561       if Typ = Raise_Type then
9562          Error_Msg_N ("cannot find unique type for raise expression", N);
9563          Set_Etype (N, Any_Type);
9564       else
9565          Set_Etype (N, Typ);
9566       end if;
9567    end Resolve_Raise_Expression;
9568
9569    -------------------
9570    -- Resolve_Range --
9571    -------------------
9572
9573    procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
9574       L : constant Node_Id := Low_Bound (N);
9575       H : constant Node_Id := High_Bound (N);
9576
9577       function First_Last_Ref return Boolean;
9578       --  Returns True if N is of the form X'First .. X'Last where X is the
9579       --  same entity for both attributes.
9580
9581       --------------------
9582       -- First_Last_Ref --
9583       --------------------
9584
9585       function First_Last_Ref return Boolean is
9586          Lorig : constant Node_Id := Original_Node (L);
9587          Horig : constant Node_Id := Original_Node (H);
9588
9589       begin
9590          if Nkind (Lorig) = N_Attribute_Reference
9591            and then Nkind (Horig) = N_Attribute_Reference
9592            and then Attribute_Name (Lorig) = Name_First
9593            and then Attribute_Name (Horig) = Name_Last
9594          then
9595             declare
9596                PL : constant Node_Id := Prefix (Lorig);
9597                PH : constant Node_Id := Prefix (Horig);
9598             begin
9599                if Is_Entity_Name (PL)
9600                  and then Is_Entity_Name (PH)
9601                  and then Entity (PL) = Entity (PH)
9602                then
9603                   return True;
9604                end if;
9605             end;
9606          end if;
9607
9608          return False;
9609       end First_Last_Ref;
9610
9611    --  Start of processing for Resolve_Range
9612
9613    begin
9614       Set_Etype (N, Typ);
9615       Resolve (L, Typ);
9616       Resolve (H, Typ);
9617
9618       --  Check for inappropriate range on unordered enumeration type
9619
9620       if Bad_Unordered_Enumeration_Reference (N, Typ)
9621
9622         --  Exclude X'First .. X'Last if X is the same entity for both
9623
9624         and then not First_Last_Ref
9625       then
9626          Error_Msg_Sloc := Sloc (Typ);
9627          Error_Msg_NE
9628            ("subrange of unordered enumeration type& declared#?U?", N, Typ);
9629       end if;
9630
9631       Check_Unset_Reference (L);
9632       Check_Unset_Reference (H);
9633
9634       --  We have to check the bounds for being within the base range as
9635       --  required for a non-static context. Normally this is automatic and
9636       --  done as part of evaluating expressions, but the N_Range node is an
9637       --  exception, since in GNAT we consider this node to be a subexpression,
9638       --  even though in Ada it is not. The circuit in Sem_Eval could check for
9639       --  this, but that would put the test on the main evaluation path for
9640       --  expressions.
9641
9642       Check_Non_Static_Context (L);
9643       Check_Non_Static_Context (H);
9644
9645       --  Check for an ambiguous range over character literals. This will
9646       --  happen with a membership test involving only literals.
9647
9648       if Typ = Any_Character then
9649          Ambiguous_Character (L);
9650          Set_Etype (N, Any_Type);
9651          return;
9652       end if;
9653
9654       --  If bounds are static, constant-fold them, so size computations are
9655       --  identical between front-end and back-end. Do not perform this
9656       --  transformation while analyzing generic units, as type information
9657       --  would be lost when reanalyzing the constant node in the instance.
9658
9659       if Is_Discrete_Type (Typ) and then Expander_Active then
9660          if Is_OK_Static_Expression (L) then
9661             Fold_Uint (L, Expr_Value (L), Is_OK_Static_Expression (L));
9662          end if;
9663
9664          if Is_OK_Static_Expression (H) then
9665             Fold_Uint (H, Expr_Value (H), Is_OK_Static_Expression (H));
9666          end if;
9667       end if;
9668    end Resolve_Range;
9669
9670    --------------------------
9671    -- Resolve_Real_Literal --
9672    --------------------------
9673
9674    procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
9675       Actual_Typ : constant Entity_Id := Etype (N);
9676
9677    begin
9678       --  Special processing for fixed-point literals to make sure that the
9679       --  value is an exact multiple of small where this is required. We skip
9680       --  this for the universal real case, and also for generic types.
9681
9682       if Is_Fixed_Point_Type (Typ)
9683         and then Typ /= Universal_Fixed
9684         and then Typ /= Any_Fixed
9685         and then not Is_Generic_Type (Typ)
9686       then
9687          declare
9688             Val   : constant Ureal := Realval (N);
9689             Cintr : constant Ureal := Val / Small_Value (Typ);
9690             Cint  : constant Uint  := UR_Trunc (Cintr);
9691             Den   : constant Uint  := Norm_Den (Cintr);
9692             Stat  : Boolean;
9693
9694          begin
9695             --  Case of literal is not an exact multiple of the Small
9696
9697             if Den /= 1 then
9698
9699                --  For a source program literal for a decimal fixed-point type,
9700                --  this is statically illegal (RM 4.9(36)).
9701
9702                if Is_Decimal_Fixed_Point_Type (Typ)
9703                  and then Actual_Typ = Universal_Real
9704                  and then Comes_From_Source (N)
9705                then
9706                   Error_Msg_N ("value has extraneous low order digits", N);
9707                end if;
9708
9709                --  Generate a warning if literal from source
9710
9711                if Is_OK_Static_Expression (N)
9712                  and then Warn_On_Bad_Fixed_Value
9713                then
9714                   Error_Msg_N
9715                     ("?b?static fixed-point value is not a multiple of Small!",
9716                      N);
9717                end if;
9718
9719                --  Replace literal by a value that is the exact representation
9720                --  of a value of the type, i.e. a multiple of the small value,
9721                --  by truncation, since Machine_Rounds is false for all GNAT
9722                --  fixed-point types (RM 4.9(38)).
9723
9724                Stat := Is_OK_Static_Expression (N);
9725                Rewrite (N,
9726                  Make_Real_Literal (Sloc (N),
9727                    Realval => Small_Value (Typ) * Cint));
9728
9729                Set_Is_Static_Expression (N, Stat);
9730             end if;
9731
9732             --  In all cases, set the corresponding integer field
9733
9734             Set_Corresponding_Integer_Value (N, Cint);
9735          end;
9736       end if;
9737
9738       --  Now replace the actual type by the expected type as usual
9739
9740       Set_Etype (N, Typ);
9741       Eval_Real_Literal (N);
9742    end Resolve_Real_Literal;
9743
9744    -----------------------
9745    -- Resolve_Reference --
9746    -----------------------
9747
9748    procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
9749       P : constant Node_Id := Prefix (N);
9750
9751    begin
9752       --  Replace general access with specific type
9753
9754       if Ekind (Etype (N)) = E_Allocator_Type then
9755          Set_Etype (N, Base_Type (Typ));
9756       end if;
9757
9758       Resolve (P, Designated_Type (Etype (N)));
9759
9760       --  If we are taking the reference of a volatile entity, then treat it as
9761       --  a potential modification of this entity. This is too conservative,
9762       --  but necessary because remove side effects can cause transformations
9763       --  of normal assignments into reference sequences that otherwise fail to
9764       --  notice the modification.
9765
9766       if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
9767          Note_Possible_Modification (P, Sure => False);
9768       end if;
9769    end Resolve_Reference;
9770
9771    --------------------------------
9772    -- Resolve_Selected_Component --
9773    --------------------------------
9774
9775    procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
9776       Comp  : Entity_Id;
9777       Comp1 : Entity_Id        := Empty; -- prevent junk warning
9778       P     : constant Node_Id := Prefix (N);
9779       S     : constant Node_Id := Selector_Name (N);
9780       T     : Entity_Id        := Etype (P);
9781       I     : Interp_Index;
9782       I1    : Interp_Index := 0; -- prevent junk warning
9783       It    : Interp;
9784       It1   : Interp;
9785       Found : Boolean;
9786
9787       function Init_Component return Boolean;
9788       --  Check whether this is the initialization of a component within an
9789       --  init proc (by assignment or call to another init proc). If true,
9790       --  there is no need for a discriminant check.
9791
9792       --------------------
9793       -- Init_Component --
9794       --------------------
9795
9796       function Init_Component return Boolean is
9797       begin
9798          return Inside_Init_Proc
9799            and then Nkind (Prefix (N)) = N_Identifier
9800            and then Chars (Prefix (N)) = Name_uInit
9801            and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
9802       end Init_Component;
9803
9804    --  Start of processing for Resolve_Selected_Component
9805
9806    begin
9807       if Is_Overloaded (P) then
9808
9809          --  Use the context type to select the prefix that has a selector
9810          --  of the correct name and type.
9811
9812          Found := False;
9813          Get_First_Interp (P, I, It);
9814
9815          Search : while Present (It.Typ) loop
9816             if Is_Access_Type (It.Typ) then
9817                T := Designated_Type (It.Typ);
9818             else
9819                T := It.Typ;
9820             end if;
9821
9822             --  Locate selected component. For a private prefix the selector
9823             --  can denote a discriminant.
9824
9825             if Is_Record_Type (T) or else Is_Private_Type (T) then
9826
9827                --  The visible components of a class-wide type are those of
9828                --  the root type.
9829
9830                if Is_Class_Wide_Type (T) then
9831                   T := Etype (T);
9832                end if;
9833
9834                Comp := First_Entity (T);
9835                while Present (Comp) loop
9836                   if Chars (Comp) = Chars (S)
9837                     and then Covers (Typ, Etype (Comp))
9838                   then
9839                      if not Found then
9840                         Found := True;
9841                         I1  := I;
9842                         It1 := It;
9843                         Comp1 := Comp;
9844
9845                      else
9846                         It := Disambiguate (P, I1, I, Any_Type);
9847
9848                         if It = No_Interp then
9849                            Error_Msg_N
9850                              ("ambiguous prefix for selected component",  N);
9851                            Set_Etype (N, Typ);
9852                            return;
9853
9854                         else
9855                            It1 := It;
9856
9857                            --  There may be an implicit dereference. Retrieve
9858                            --  designated record type.
9859
9860                            if Is_Access_Type (It1.Typ) then
9861                               T := Designated_Type (It1.Typ);
9862                            else
9863                               T := It1.Typ;
9864                            end if;
9865
9866                            if Scope (Comp1) /= T then
9867
9868                               --  Resolution chooses the new interpretation.
9869                               --  Find the component with the right name.
9870
9871                               Comp1 := First_Entity (T);
9872                               while Present (Comp1)
9873                                 and then Chars (Comp1) /= Chars (S)
9874                               loop
9875                                  Comp1 := Next_Entity (Comp1);
9876                               end loop;
9877                            end if;
9878
9879                            exit Search;
9880                         end if;
9881                      end if;
9882                   end if;
9883
9884                   Comp := Next_Entity (Comp);
9885                end loop;
9886             end if;
9887
9888             Get_Next_Interp (I, It);
9889          end loop Search;
9890
9891          --  There must be a legal interpretation at this point
9892
9893          pragma Assert (Found);
9894          Resolve (P, It1.Typ);
9895          Set_Etype (N, Typ);
9896          Set_Entity_With_Checks (S, Comp1);
9897
9898       else
9899          --  Resolve prefix with its type
9900
9901          Resolve (P, T);
9902       end if;
9903
9904       --  Generate cross-reference. We needed to wait until full overloading
9905       --  resolution was complete to do this, since otherwise we can't tell if
9906       --  we are an lvalue or not.
9907
9908       if May_Be_Lvalue (N) then
9909          Generate_Reference (Entity (S), S, 'm');
9910       else
9911          Generate_Reference (Entity (S), S, 'r');
9912       end if;
9913
9914       --  If prefix is an access type, the node will be transformed into an
9915       --  explicit dereference during expansion. The type of the node is the
9916       --  designated type of that of the prefix.
9917
9918       if Is_Access_Type (Etype (P)) then
9919          T := Designated_Type (Etype (P));
9920          Check_Fully_Declared_Prefix (T, P);
9921       else
9922          T := Etype (P);
9923       end if;
9924
9925       --  Set flag for expander if discriminant check required on a component
9926       --  appearing within a variant.
9927
9928       if Has_Discriminants (T)
9929         and then Ekind (Entity (S)) = E_Component
9930         and then Present (Original_Record_Component (Entity (S)))
9931         and then Ekind (Original_Record_Component (Entity (S))) = E_Component
9932         and then
9933           Is_Declared_Within_Variant (Original_Record_Component (Entity (S)))
9934         and then not Discriminant_Checks_Suppressed (T)
9935         and then not Init_Component
9936       then
9937          Set_Do_Discriminant_Check (N);
9938       end if;
9939
9940       if Ekind (Entity (S)) = E_Void then
9941          Error_Msg_N ("premature use of component", S);
9942       end if;
9943
9944       --  If the prefix is a record conversion, this may be a renamed
9945       --  discriminant whose bounds differ from those of the original
9946       --  one, so we must ensure that a range check is performed.
9947
9948       if Nkind (P) = N_Type_Conversion
9949         and then Ekind (Entity (S)) = E_Discriminant
9950         and then Is_Discrete_Type (Typ)
9951       then
9952          Set_Etype (N, Base_Type (Typ));
9953       end if;
9954
9955       --  Note: No Eval processing is required, because the prefix is of a
9956       --  record type, or protected type, and neither can possibly be static.
9957
9958       --  If the record type is atomic, and the component is non-atomic, then
9959       --  this is worth a warning, since we have a situation where the access
9960       --  to the component may cause extra read/writes of the atomic array
9961       --  object, or partial word accesses, both of which may be unexpected.
9962
9963       if Nkind (N) = N_Selected_Component
9964         and then Is_Atomic_Ref_With_Address (N)
9965         and then not Is_Atomic (Entity (S))
9966         and then not Is_Atomic (Etype (Entity (S)))
9967       then
9968          Error_Msg_N
9969            ("??access to non-atomic component of atomic record",
9970             Prefix (N));
9971          Error_Msg_N
9972            ("\??may cause unexpected accesses to atomic object",
9973             Prefix (N));
9974       end if;
9975
9976       Analyze_Dimension (N);
9977    end Resolve_Selected_Component;
9978
9979    -------------------
9980    -- Resolve_Shift --
9981    -------------------
9982
9983    procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
9984       B_Typ : constant Entity_Id := Base_Type (Typ);
9985       L     : constant Node_Id   := Left_Opnd  (N);
9986       R     : constant Node_Id   := Right_Opnd (N);
9987
9988    begin
9989       --  We do the resolution using the base type, because intermediate values
9990       --  in expressions always are of the base type, not a subtype of it.
9991
9992       Resolve (L, B_Typ);
9993       Resolve (R, Standard_Natural);
9994
9995       Check_Unset_Reference (L);
9996       Check_Unset_Reference (R);
9997
9998       Set_Etype (N, B_Typ);
9999       Generate_Operator_Reference (N, B_Typ);
10000       Eval_Shift (N);
10001    end Resolve_Shift;
10002
10003    ---------------------------
10004    -- Resolve_Short_Circuit --
10005    ---------------------------
10006
10007    procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
10008       B_Typ : constant Entity_Id := Base_Type (Typ);
10009       L     : constant Node_Id   := Left_Opnd  (N);
10010       R     : constant Node_Id   := Right_Opnd (N);
10011
10012    begin
10013       --  Ensure all actions associated with the left operand (e.g.
10014       --  finalization of transient controlled objects) are fully evaluated
10015       --  locally within an expression with actions. This is particularly
10016       --  helpful for coverage analysis. However this should not happen in
10017       --  generics.
10018
10019       if Expander_Active then
10020          declare
10021             Reloc_L : constant Node_Id := Relocate_Node (L);
10022          begin
10023             Save_Interps (Old_N => L, New_N => Reloc_L);
10024
10025             Rewrite (L,
10026               Make_Expression_With_Actions (Sloc (L),
10027                 Actions    => New_List,
10028                 Expression => Reloc_L));
10029
10030             --  Set Comes_From_Source on L to preserve warnings for unset
10031             --  reference.
10032
10033             Set_Comes_From_Source (L, Comes_From_Source (Reloc_L));
10034          end;
10035       end if;
10036
10037       Resolve (L, B_Typ);
10038       Resolve (R, B_Typ);
10039
10040       --  Check for issuing warning for always False assert/check, this happens
10041       --  when assertions are turned off, in which case the pragma Assert/Check
10042       --  was transformed into:
10043
10044       --     if False and then <condition> then ...
10045
10046       --  and we detect this pattern
10047
10048       if Warn_On_Assertion_Failure
10049         and then Is_Entity_Name (R)
10050         and then Entity (R) = Standard_False
10051         and then Nkind (Parent (N)) = N_If_Statement
10052         and then Nkind (N) = N_And_Then
10053         and then Is_Entity_Name (L)
10054         and then Entity (L) = Standard_False
10055       then
10056          declare
10057             Orig : constant Node_Id := Original_Node (Parent (N));
10058
10059          begin
10060             --  Special handling of Asssert pragma
10061
10062             if Nkind (Orig) = N_Pragma
10063               and then Pragma_Name (Orig) = Name_Assert
10064             then
10065                declare
10066                   Expr : constant Node_Id :=
10067                            Original_Node
10068                              (Expression
10069                                (First (Pragma_Argument_Associations (Orig))));
10070
10071                begin
10072                   --  Don't warn if original condition is explicit False,
10073                   --  since obviously the failure is expected in this case.
10074
10075                   if Is_Entity_Name (Expr)
10076                     and then Entity (Expr) = Standard_False
10077                   then
10078                      null;
10079
10080                   --  Issue warning. We do not want the deletion of the
10081                   --  IF/AND-THEN to take this message with it. We achieve this
10082                   --  by making sure that the expanded code points to the Sloc
10083                   --  of the expression, not the original pragma.
10084
10085                   else
10086                      --  Note: Use Error_Msg_F here rather than Error_Msg_N.
10087                      --  The source location of the expression is not usually
10088                      --  the best choice here. For example, it gets located on
10089                      --  the last AND keyword in a chain of boolean expressiond
10090                      --  AND'ed together. It is best to put the message on the
10091                      --  first character of the assertion, which is the effect
10092                      --  of the First_Node call here.
10093
10094                      Error_Msg_F
10095                        ("?A?assertion would fail at run time!",
10096                         Expression
10097                           (First (Pragma_Argument_Associations (Orig))));
10098                   end if;
10099                end;
10100
10101             --  Similar processing for Check pragma
10102
10103             elsif Nkind (Orig) = N_Pragma
10104               and then Pragma_Name (Orig) = Name_Check
10105             then
10106                --  Don't want to warn if original condition is explicit False
10107
10108                declare
10109                   Expr : constant Node_Id :=
10110                     Original_Node
10111                       (Expression
10112                         (Next (First (Pragma_Argument_Associations (Orig)))));
10113                begin
10114                   if Is_Entity_Name (Expr)
10115                     and then Entity (Expr) = Standard_False
10116                   then
10117                      null;
10118
10119                   --  Post warning
10120
10121                   else
10122                      --  Again use Error_Msg_F rather than Error_Msg_N, see
10123                      --  comment above for an explanation of why we do this.
10124
10125                      Error_Msg_F
10126                        ("?A?check would fail at run time!",
10127                         Expression
10128                           (Last (Pragma_Argument_Associations (Orig))));
10129                   end if;
10130                end;
10131             end if;
10132          end;
10133       end if;
10134
10135       --  Continue with processing of short circuit
10136
10137       Check_Unset_Reference (L);
10138       Check_Unset_Reference (R);
10139
10140       Set_Etype (N, B_Typ);
10141       Eval_Short_Circuit (N);
10142    end Resolve_Short_Circuit;
10143
10144    -------------------
10145    -- Resolve_Slice --
10146    -------------------
10147
10148    procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
10149       Drange     : constant Node_Id := Discrete_Range (N);
10150       Name       : constant Node_Id := Prefix (N);
10151       Array_Type : Entity_Id        := Empty;
10152       Dexpr      : Node_Id          := Empty;
10153       Index_Type : Entity_Id;
10154
10155    begin
10156       if Is_Overloaded (Name) then
10157
10158          --  Use the context type to select the prefix that yields the correct
10159          --  array type.
10160
10161          declare
10162             I      : Interp_Index;
10163             I1     : Interp_Index := 0;
10164             It     : Interp;
10165             P      : constant Node_Id := Prefix (N);
10166             Found  : Boolean := False;
10167
10168          begin
10169             Get_First_Interp (P, I,  It);
10170             while Present (It.Typ) loop
10171                if (Is_Array_Type (It.Typ)
10172                     and then Covers (Typ,  It.Typ))
10173                  or else (Is_Access_Type (It.Typ)
10174                            and then Is_Array_Type (Designated_Type (It.Typ))
10175                            and then Covers (Typ, Designated_Type (It.Typ)))
10176                then
10177                   if Found then
10178                      It := Disambiguate (P, I1, I, Any_Type);
10179
10180                      if It = No_Interp then
10181                         Error_Msg_N ("ambiguous prefix for slicing",  N);
10182                         Set_Etype (N, Typ);
10183                         return;
10184                      else
10185                         Found := True;
10186                         Array_Type := It.Typ;
10187                         I1 := I;
10188                      end if;
10189                   else
10190                      Found := True;
10191                      Array_Type := It.Typ;
10192                      I1 := I;
10193                   end if;
10194                end if;
10195
10196                Get_Next_Interp (I, It);
10197             end loop;
10198          end;
10199
10200       else
10201          Array_Type := Etype (Name);
10202       end if;
10203
10204       Resolve (Name, Array_Type);
10205
10206       if Is_Access_Type (Array_Type) then
10207          Apply_Access_Check (N);
10208          Array_Type := Designated_Type (Array_Type);
10209
10210          --  If the prefix is an access to an unconstrained array, we must use
10211          --  the actual subtype of the object to perform the index checks. The
10212          --  object denoted by the prefix is implicit in the node, so we build
10213          --  an explicit representation for it in order to compute the actual
10214          --  subtype.
10215
10216          if not Is_Constrained (Array_Type) then
10217             Remove_Side_Effects (Prefix (N));
10218
10219             declare
10220                Obj : constant Node_Id :=
10221                        Make_Explicit_Dereference (Sloc (N),
10222                          Prefix => New_Copy_Tree (Prefix (N)));
10223             begin
10224                Set_Etype (Obj, Array_Type);
10225                Set_Parent (Obj, Parent (N));
10226                Array_Type := Get_Actual_Subtype (Obj);
10227             end;
10228          end if;
10229
10230       elsif Is_Entity_Name (Name)
10231         or else Nkind (Name) = N_Explicit_Dereference
10232         or else (Nkind (Name) = N_Function_Call
10233                   and then not Is_Constrained (Etype (Name)))
10234       then
10235          Array_Type := Get_Actual_Subtype (Name);
10236
10237       --  If the name is a selected component that depends on discriminants,
10238       --  build an actual subtype for it. This can happen only when the name
10239       --  itself is overloaded; otherwise the actual subtype is created when
10240       --  the selected component is analyzed.
10241
10242       elsif Nkind (Name) = N_Selected_Component
10243         and then Full_Analysis
10244         and then Depends_On_Discriminant (First_Index (Array_Type))
10245       then
10246          declare
10247             Act_Decl : constant Node_Id :=
10248                          Build_Actual_Subtype_Of_Component (Array_Type, Name);
10249          begin
10250             Insert_Action (N, Act_Decl);
10251             Array_Type := Defining_Identifier (Act_Decl);
10252          end;
10253
10254       --  Maybe this should just be "else", instead of checking for the
10255       --  specific case of slice??? This is needed for the case where the
10256       --  prefix is an Image attribute, which gets expanded to a slice, and so
10257       --  has a constrained subtype which we want to use for the slice range
10258       --  check applied below (the range check won't get done if the
10259       --  unconstrained subtype of the 'Image is used).
10260
10261       elsif Nkind (Name) = N_Slice then
10262          Array_Type := Etype (Name);
10263       end if;
10264
10265       --  Obtain the type of the array index
10266
10267       if Ekind (Array_Type) = E_String_Literal_Subtype then
10268          Index_Type := Etype (String_Literal_Low_Bound (Array_Type));
10269       else
10270          Index_Type := Etype (First_Index (Array_Type));
10271       end if;
10272
10273       --  If name was overloaded, set slice type correctly now
10274
10275       Set_Etype (N, Array_Type);
10276
10277       --  Handle the generation of a range check that compares the array index
10278       --  against the discrete_range. The check is not applied to internally
10279       --  built nodes associated with the expansion of dispatch tables. Check
10280       --  that Ada.Tags has already been loaded to avoid extra dependencies on
10281       --  the unit.
10282
10283       if Tagged_Type_Expansion
10284         and then RTU_Loaded (Ada_Tags)
10285         and then Nkind (Prefix (N)) = N_Selected_Component
10286         and then Present (Entity (Selector_Name (Prefix (N))))
10287         and then Entity (Selector_Name (Prefix (N))) =
10288                    RTE_Record_Component (RE_Prims_Ptr)
10289       then
10290          null;
10291
10292       --  The discrete_range is specified by a subtype indication. Create a
10293       --  shallow copy and inherit the type, parent and source location from
10294       --  the discrete_range. This ensures that the range check is inserted
10295       --  relative to the slice and that the runtime exception points to the
10296       --  proper construct.
10297
10298       elsif Is_Entity_Name (Drange) then
10299          Dexpr := New_Copy (Scalar_Range (Entity (Drange)));
10300
10301          Set_Etype  (Dexpr, Etype  (Drange));
10302          Set_Parent (Dexpr, Parent (Drange));
10303          Set_Sloc   (Dexpr, Sloc   (Drange));
10304
10305       --  The discrete_range is a regular range. Resolve the bounds and remove
10306       --  their side effects.
10307
10308       else
10309          Resolve (Drange, Base_Type (Index_Type));
10310
10311          if Nkind (Drange) = N_Range then
10312             Force_Evaluation (Low_Bound  (Drange));
10313             Force_Evaluation (High_Bound (Drange));
10314
10315             Dexpr := Drange;
10316          end if;
10317       end if;
10318
10319       if Present (Dexpr) then
10320          Apply_Range_Check (Dexpr, Index_Type);
10321       end if;
10322
10323       Set_Slice_Subtype (N);
10324
10325       --  Check bad use of type with predicates
10326
10327       declare
10328          Subt : Entity_Id;
10329
10330       begin
10331          if Nkind (Drange) = N_Subtype_Indication
10332            and then Has_Predicates (Entity (Subtype_Mark (Drange)))
10333          then
10334             Subt := Entity (Subtype_Mark (Drange));
10335          else
10336             Subt := Etype (Drange);
10337          end if;
10338
10339          if Has_Predicates (Subt) then
10340             Bad_Predicated_Subtype_Use
10341               ("subtype& has predicate, not allowed in slice", Drange, Subt);
10342          end if;
10343       end;
10344
10345       --  Otherwise here is where we check suspicious indexes
10346
10347       if Nkind (Drange) = N_Range then
10348          Warn_On_Suspicious_Index (Name, Low_Bound  (Drange));
10349          Warn_On_Suspicious_Index (Name, High_Bound (Drange));
10350       end if;
10351
10352       Analyze_Dimension (N);
10353       Eval_Slice (N);
10354    end Resolve_Slice;
10355
10356    ----------------------------
10357    -- Resolve_String_Literal --
10358    ----------------------------
10359
10360    procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
10361       C_Typ      : constant Entity_Id  := Component_Type (Typ);
10362       R_Typ      : constant Entity_Id  := Root_Type (C_Typ);
10363       Loc        : constant Source_Ptr := Sloc (N);
10364       Str        : constant String_Id  := Strval (N);
10365       Strlen     : constant Nat        := String_Length (Str);
10366       Subtype_Id : Entity_Id;
10367       Need_Check : Boolean;
10368
10369    begin
10370       --  For a string appearing in a concatenation, defer creation of the
10371       --  string_literal_subtype until the end of the resolution of the
10372       --  concatenation, because the literal may be constant-folded away. This
10373       --  is a useful optimization for long concatenation expressions.
10374
10375       --  If the string is an aggregate built for a single character (which
10376       --  happens in a non-static context) or a is null string to which special
10377       --  checks may apply, we build the subtype. Wide strings must also get a
10378       --  string subtype if they come from a one character aggregate. Strings
10379       --  generated by attributes might be static, but it is often hard to
10380       --  determine whether the enclosing context is static, so we generate
10381       --  subtypes for them as well, thus losing some rarer optimizations ???
10382       --  Same for strings that come from a static conversion.
10383
10384       Need_Check :=
10385         (Strlen = 0 and then Typ /= Standard_String)
10386           or else Nkind (Parent (N)) /= N_Op_Concat
10387           or else (N /= Left_Opnd (Parent (N))
10388                     and then N /= Right_Opnd (Parent (N)))
10389           or else ((Typ = Standard_Wide_String
10390                       or else Typ = Standard_Wide_Wide_String)
10391                     and then Nkind (Original_Node (N)) /= N_String_Literal);
10392
10393       --  If the resolving type is itself a string literal subtype, we can just
10394       --  reuse it, since there is no point in creating another.
10395
10396       if Ekind (Typ) = E_String_Literal_Subtype then
10397          Subtype_Id := Typ;
10398
10399       elsif Nkind (Parent (N)) = N_Op_Concat
10400         and then not Need_Check
10401         and then not Nkind_In (Original_Node (N), N_Character_Literal,
10402                                                   N_Attribute_Reference,
10403                                                   N_Qualified_Expression,
10404                                                   N_Type_Conversion)
10405       then
10406          Subtype_Id := Typ;
10407
10408       --  Do not generate a string literal subtype for the default expression
10409       --  of a formal parameter in GNATprove mode. This is because the string
10410       --  subtype is associated with the freezing actions of the subprogram,
10411       --  however freezing is disabled in GNATprove mode and as a result the
10412       --  subtype is unavailable.
10413
10414       elsif GNATprove_Mode
10415         and then Nkind (Parent (N)) = N_Parameter_Specification
10416       then
10417          Subtype_Id := Typ;
10418
10419       --  Otherwise we must create a string literal subtype. Note that the
10420       --  whole idea of string literal subtypes is simply to avoid the need
10421       --  for building a full fledged array subtype for each literal.
10422
10423       else
10424          Set_String_Literal_Subtype (N, Typ);
10425          Subtype_Id := Etype (N);
10426       end if;
10427
10428       if Nkind (Parent (N)) /= N_Op_Concat
10429         or else Need_Check
10430       then
10431          Set_Etype (N, Subtype_Id);
10432          Eval_String_Literal (N);
10433       end if;
10434
10435       if Is_Limited_Composite (Typ)
10436         or else Is_Private_Composite (Typ)
10437       then
10438          Error_Msg_N ("string literal not available for private array", N);
10439          Set_Etype (N, Any_Type);
10440          return;
10441       end if;
10442
10443       --  The validity of a null string has been checked in the call to
10444       --  Eval_String_Literal.
10445
10446       if Strlen = 0 then
10447          return;
10448
10449       --  Always accept string literal with component type Any_Character, which
10450       --  occurs in error situations and in comparisons of literals, both of
10451       --  which should accept all literals.
10452
10453       elsif R_Typ = Any_Character then
10454          return;
10455
10456       --  If the type is bit-packed, then we always transform the string
10457       --  literal into a full fledged aggregate.
10458
10459       elsif Is_Bit_Packed_Array (Typ) then
10460          null;
10461
10462       --  Deal with cases of Wide_Wide_String, Wide_String, and String
10463
10464       else
10465          --  For Standard.Wide_Wide_String, or any other type whose component
10466          --  type is Standard.Wide_Wide_Character, we know that all the
10467          --  characters in the string must be acceptable, since the parser
10468          --  accepted the characters as valid character literals.
10469
10470          if R_Typ = Standard_Wide_Wide_Character then
10471             null;
10472
10473          --  For the case of Standard.String, or any other type whose component
10474          --  type is Standard.Character, we must make sure that there are no
10475          --  wide characters in the string, i.e. that it is entirely composed
10476          --  of characters in range of type Character.
10477
10478          --  If the string literal is the result of a static concatenation, the
10479          --  test has already been performed on the components, and need not be
10480          --  repeated.
10481
10482          elsif R_Typ = Standard_Character
10483            and then Nkind (Original_Node (N)) /= N_Op_Concat
10484          then
10485             for J in 1 .. Strlen loop
10486                if not In_Character_Range (Get_String_Char (Str, J)) then
10487
10488                   --  If we are out of range, post error. This is one of the
10489                   --  very few places that we place the flag in the middle of
10490                   --  a token, right under the offending wide character. Not
10491                   --  quite clear if this is right wrt wide character encoding
10492                   --  sequences, but it's only an error message.
10493
10494                   Error_Msg
10495                     ("literal out of range of type Standard.Character",
10496                      Source_Ptr (Int (Loc) + J));
10497                   return;
10498                end if;
10499             end loop;
10500
10501          --  For the case of Standard.Wide_String, or any other type whose
10502          --  component type is Standard.Wide_Character, we must make sure that
10503          --  there are no wide characters in the string, i.e. that it is
10504          --  entirely composed of characters in range of type Wide_Character.
10505
10506          --  If the string literal is the result of a static concatenation,
10507          --  the test has already been performed on the components, and need
10508          --  not be repeated.
10509
10510          elsif R_Typ = Standard_Wide_Character
10511            and then Nkind (Original_Node (N)) /= N_Op_Concat
10512          then
10513             for J in 1 .. Strlen loop
10514                if not In_Wide_Character_Range (Get_String_Char (Str, J)) then
10515
10516                   --  If we are out of range, post error. This is one of the
10517                   --  very few places that we place the flag in the middle of
10518                   --  a token, right under the offending wide character.
10519
10520                   --  This is not quite right, because characters in general
10521                   --  will take more than one character position ???
10522
10523                   Error_Msg
10524                     ("literal out of range of type Standard.Wide_Character",
10525                      Source_Ptr (Int (Loc) + J));
10526                   return;
10527                end if;
10528             end loop;
10529
10530          --  If the root type is not a standard character, then we will convert
10531          --  the string into an aggregate and will let the aggregate code do
10532          --  the checking. Standard Wide_Wide_Character is also OK here.
10533
10534          else
10535             null;
10536          end if;
10537
10538          --  See if the component type of the array corresponding to the string
10539          --  has compile time known bounds. If yes we can directly check
10540          --  whether the evaluation of the string will raise constraint error.
10541          --  Otherwise we need to transform the string literal into the
10542          --  corresponding character aggregate and let the aggregate code do
10543          --  the checking.
10544
10545          if Is_Standard_Character_Type (R_Typ) then
10546
10547             --  Check for the case of full range, where we are definitely OK
10548
10549             if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
10550                return;
10551             end if;
10552
10553             --  Here the range is not the complete base type range, so check
10554
10555             declare
10556                Comp_Typ_Lo : constant Node_Id :=
10557                                Type_Low_Bound (Component_Type (Typ));
10558                Comp_Typ_Hi : constant Node_Id :=
10559                                Type_High_Bound (Component_Type (Typ));
10560
10561                Char_Val : Uint;
10562
10563             begin
10564                if Compile_Time_Known_Value (Comp_Typ_Lo)
10565                  and then Compile_Time_Known_Value (Comp_Typ_Hi)
10566                then
10567                   for J in 1 .. Strlen loop
10568                      Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
10569
10570                      if Char_Val < Expr_Value (Comp_Typ_Lo)
10571                        or else Char_Val > Expr_Value (Comp_Typ_Hi)
10572                      then
10573                         Apply_Compile_Time_Constraint_Error
10574                           (N, "character out of range??",
10575                            CE_Range_Check_Failed,
10576                            Loc => Source_Ptr (Int (Loc) + J));
10577                      end if;
10578                   end loop;
10579
10580                   return;
10581                end if;
10582             end;
10583          end if;
10584       end if;
10585
10586       --  If we got here we meed to transform the string literal into the
10587       --  equivalent qualified positional array aggregate. This is rather
10588       --  heavy artillery for this situation, but it is hard work to avoid.
10589
10590       declare
10591          Lits : constant List_Id    := New_List;
10592          P    : Source_Ptr := Loc + 1;
10593          C    : Char_Code;
10594
10595       begin
10596          --  Build the character literals, we give them source locations that
10597          --  correspond to the string positions, which is a bit tricky given
10598          --  the possible presence of wide character escape sequences.
10599
10600          for J in 1 .. Strlen loop
10601             C := Get_String_Char (Str, J);
10602             Set_Character_Literal_Name (C);
10603
10604             Append_To (Lits,
10605               Make_Character_Literal (P,
10606                 Chars              => Name_Find,
10607                 Char_Literal_Value => UI_From_CC (C)));
10608
10609             if In_Character_Range (C) then
10610                P := P + 1;
10611
10612             --  Should we have a call to Skip_Wide here ???
10613
10614             --  ???     else
10615             --             Skip_Wide (P);
10616
10617             end if;
10618          end loop;
10619
10620          Rewrite (N,
10621            Make_Qualified_Expression (Loc,
10622              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
10623              Expression   =>
10624                Make_Aggregate (Loc, Expressions => Lits)));
10625
10626          Analyze_And_Resolve (N, Typ);
10627       end;
10628    end Resolve_String_Literal;
10629
10630    -----------------------------
10631    -- Resolve_Type_Conversion --
10632    -----------------------------
10633
10634    procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
10635       Conv_OK     : constant Boolean   := Conversion_OK (N);
10636       Operand     : constant Node_Id   := Expression (N);
10637       Operand_Typ : constant Entity_Id := Etype (Operand);
10638       Target_Typ  : constant Entity_Id := Etype (N);
10639       Rop         : Node_Id;
10640       Orig_N      : Node_Id;
10641       Orig_T      : Node_Id;
10642
10643       Test_Redundant : Boolean := Warn_On_Redundant_Constructs;
10644       --  Set to False to suppress cases where we want to suppress the test
10645       --  for redundancy to avoid possible false positives on this warning.
10646
10647    begin
10648       if not Conv_OK
10649         and then not Valid_Conversion (N, Target_Typ, Operand)
10650       then
10651          return;
10652       end if;
10653
10654       --  If the Operand Etype is Universal_Fixed, then the conversion is
10655       --  never redundant. We need this check because by the time we have
10656       --  finished the rather complex transformation, the conversion looks
10657       --  redundant when it is not.
10658
10659       if Operand_Typ = Universal_Fixed then
10660          Test_Redundant := False;
10661
10662       --  If the operand is marked as Any_Fixed, then special processing is
10663       --  required. This is also a case where we suppress the test for a
10664       --  redundant conversion, since most certainly it is not redundant.
10665
10666       elsif Operand_Typ = Any_Fixed then
10667          Test_Redundant := False;
10668
10669          --  Mixed-mode operation involving a literal. Context must be a fixed
10670          --  type which is applied to the literal subsequently.
10671
10672          if Is_Fixed_Point_Type (Typ) then
10673             Set_Etype (Operand, Universal_Real);
10674
10675          elsif Is_Numeric_Type (Typ)
10676            and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide)
10677            and then (Etype (Right_Opnd (Operand)) = Universal_Real
10678                        or else
10679                      Etype (Left_Opnd  (Operand)) = Universal_Real)
10680          then
10681             --  Return if expression is ambiguous
10682
10683             if Unique_Fixed_Point_Type (N) = Any_Type then
10684                return;
10685
10686             --  If nothing else, the available fixed type is Duration
10687
10688             else
10689                Set_Etype (Operand, Standard_Duration);
10690             end if;
10691
10692             --  Resolve the real operand with largest available precision
10693
10694             if Etype (Right_Opnd (Operand)) = Universal_Real then
10695                Rop := New_Copy_Tree (Right_Opnd (Operand));
10696             else
10697                Rop := New_Copy_Tree (Left_Opnd (Operand));
10698             end if;
10699
10700             Resolve (Rop, Universal_Real);
10701
10702             --  If the operand is a literal (it could be a non-static and
10703             --  illegal exponentiation) check whether the use of Duration
10704             --  is potentially inaccurate.
10705
10706             if Nkind (Rop) = N_Real_Literal
10707               and then Realval (Rop) /= Ureal_0
10708               and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
10709             then
10710                Error_Msg_N
10711                  ("??universal real operand can only "
10712                   & "be interpreted as Duration!", Rop);
10713                Error_Msg_N
10714                  ("\??precision will be lost in the conversion!", Rop);
10715             end if;
10716
10717          elsif Is_Numeric_Type (Typ)
10718            and then Nkind (Operand) in N_Op
10719            and then Unique_Fixed_Point_Type (N) /= Any_Type
10720          then
10721             Set_Etype (Operand, Standard_Duration);
10722
10723          else
10724             Error_Msg_N ("invalid context for mixed mode operation", N);
10725             Set_Etype (Operand, Any_Type);
10726             return;
10727          end if;
10728       end if;
10729
10730       Resolve (Operand);
10731
10732       --  In SPARK, a type conversion between array types should be restricted
10733       --  to types which have matching static bounds.
10734
10735       --  Protect call to Matching_Static_Array_Bounds to avoid costly
10736       --  operation if not needed.
10737
10738       if Restriction_Check_Required (SPARK_05)
10739         and then Is_Array_Type (Target_Typ)
10740         and then Is_Array_Type (Operand_Typ)
10741         and then Operand_Typ /= Any_Composite  --  or else Operand in error
10742         and then not Matching_Static_Array_Bounds (Target_Typ, Operand_Typ)
10743       then
10744          Check_SPARK_05_Restriction
10745            ("array types should have matching static bounds", N);
10746       end if;
10747
10748       --  In formal mode, the operand of an ancestor type conversion must be an
10749       --  object (not an expression).
10750
10751       if Is_Tagged_Type (Target_Typ)
10752         and then not Is_Class_Wide_Type (Target_Typ)
10753         and then Is_Tagged_Type (Operand_Typ)
10754         and then not Is_Class_Wide_Type (Operand_Typ)
10755         and then Is_Ancestor (Target_Typ, Operand_Typ)
10756         and then not Is_SPARK_05_Object_Reference (Operand)
10757       then
10758          Check_SPARK_05_Restriction ("object required", Operand);
10759       end if;
10760
10761       Analyze_Dimension (N);
10762
10763       --  Note: we do the Eval_Type_Conversion call before applying the
10764       --  required checks for a subtype conversion. This is important, since
10765       --  both are prepared under certain circumstances to change the type
10766       --  conversion to a constraint error node, but in the case of
10767       --  Eval_Type_Conversion this may reflect an illegality in the static
10768       --  case, and we would miss the illegality (getting only a warning
10769       --  message), if we applied the type conversion checks first.
10770
10771       Eval_Type_Conversion (N);
10772
10773       --  Even when evaluation is not possible, we may be able to simplify the
10774       --  conversion or its expression. This needs to be done before applying
10775       --  checks, since otherwise the checks may use the original expression
10776       --  and defeat the simplifications. This is specifically the case for
10777       --  elimination of the floating-point Truncation attribute in
10778       --  float-to-int conversions.
10779
10780       Simplify_Type_Conversion (N);
10781
10782       --  If after evaluation we still have a type conversion, then we may need
10783       --  to apply checks required for a subtype conversion.
10784
10785       --  Skip these type conversion checks if universal fixed operands
10786       --  operands involved, since range checks are handled separately for
10787       --  these cases (in the appropriate Expand routines in unit Exp_Fixd).
10788
10789       if Nkind (N) = N_Type_Conversion
10790         and then not Is_Generic_Type (Root_Type (Target_Typ))
10791         and then Target_Typ  /= Universal_Fixed
10792         and then Operand_Typ /= Universal_Fixed
10793       then
10794          Apply_Type_Conversion_Checks (N);
10795       end if;
10796
10797       --  Issue warning for conversion of simple object to its own type. We
10798       --  have to test the original nodes, since they may have been rewritten
10799       --  by various optimizations.
10800
10801       Orig_N := Original_Node (N);
10802
10803       --  Here we test for a redundant conversion if the warning mode is
10804       --  active (and was not locally reset), and we have a type conversion
10805       --  from source not appearing in a generic instance.
10806
10807       if Test_Redundant
10808         and then Nkind (Orig_N) = N_Type_Conversion
10809         and then Comes_From_Source (Orig_N)
10810         and then not In_Instance
10811       then
10812          Orig_N := Original_Node (Expression (Orig_N));
10813          Orig_T := Target_Typ;
10814
10815          --  If the node is part of a larger expression, the Target_Type
10816          --  may not be the original type of the node if the context is a
10817          --  condition. Recover original type to see if conversion is needed.
10818
10819          if Is_Boolean_Type (Orig_T)
10820           and then Nkind (Parent (N)) in N_Op
10821          then
10822             Orig_T := Etype (Parent (N));
10823          end if;
10824
10825          --  If we have an entity name, then give the warning if the entity
10826          --  is the right type, or if it is a loop parameter covered by the
10827          --  original type (that's needed because loop parameters have an
10828          --  odd subtype coming from the bounds).
10829
10830          if (Is_Entity_Name (Orig_N)
10831               and then
10832                 (Etype (Entity (Orig_N)) = Orig_T
10833                   or else
10834                     (Ekind (Entity (Orig_N)) = E_Loop_Parameter
10835                       and then Covers (Orig_T, Etype (Entity (Orig_N))))))
10836
10837            --  If not an entity, then type of expression must match
10838
10839            or else Etype (Orig_N) = Orig_T
10840          then
10841             --  One more check, do not give warning if the analyzed conversion
10842             --  has an expression with non-static bounds, and the bounds of the
10843             --  target are static. This avoids junk warnings in cases where the
10844             --  conversion is necessary to establish staticness, for example in
10845             --  a case statement.
10846
10847             if not Is_OK_Static_Subtype (Operand_Typ)
10848               and then Is_OK_Static_Subtype (Target_Typ)
10849             then
10850                null;
10851
10852             --  Finally, if this type conversion occurs in a context requiring
10853             --  a prefix, and the expression is a qualified expression then the
10854             --  type conversion is not redundant, since a qualified expression
10855             --  is not a prefix, whereas a type conversion is. For example, "X
10856             --  := T'(Funx(...)).Y;" is illegal because a selected component
10857             --  requires a prefix, but a type conversion makes it legal: "X :=
10858             --  T(T'(Funx(...))).Y;"
10859
10860             --  In Ada 2012, a qualified expression is a name, so this idiom is
10861             --  no longer needed, but we still suppress the warning because it
10862             --  seems unfriendly for warnings to pop up when you switch to the
10863             --  newer language version.
10864
10865             elsif Nkind (Orig_N) = N_Qualified_Expression
10866               and then Nkind_In (Parent (N), N_Attribute_Reference,
10867                                              N_Indexed_Component,
10868                                              N_Selected_Component,
10869                                              N_Slice,
10870                                              N_Explicit_Dereference)
10871             then
10872                null;
10873
10874             --  Never warn on conversion to Long_Long_Integer'Base since
10875             --  that is most likely an artifact of the extended overflow
10876             --  checking and comes from complex expanded code.
10877
10878             elsif Orig_T = Base_Type (Standard_Long_Long_Integer) then
10879                null;
10880
10881             --  Here we give the redundant conversion warning. If it is an
10882             --  entity, give the name of the entity in the message. If not,
10883             --  just mention the expression.
10884
10885             --  Shoudn't we test Warn_On_Redundant_Constructs here ???
10886
10887             else
10888                if Is_Entity_Name (Orig_N) then
10889                   Error_Msg_Node_2 := Orig_T;
10890                   Error_Msg_NE -- CODEFIX
10891                     ("??redundant conversion, & is of type &!",
10892                      N, Entity (Orig_N));
10893                else
10894                   Error_Msg_NE
10895                     ("??redundant conversion, expression is of type&!",
10896                      N, Orig_T);
10897                end if;
10898             end if;
10899          end if;
10900       end if;
10901
10902       --  Ada 2005 (AI-251): Handle class-wide interface type conversions.
10903       --  No need to perform any interface conversion if the type of the
10904       --  expression coincides with the target type.
10905
10906       if Ada_Version >= Ada_2005
10907         and then Expander_Active
10908         and then Operand_Typ /= Target_Typ
10909       then
10910          declare
10911             Opnd   : Entity_Id := Operand_Typ;
10912             Target : Entity_Id := Target_Typ;
10913
10914          begin
10915             --  If the type of the operand is a limited view, use nonlimited
10916             --  view when available. If it is a class-wide type, recover the
10917             --  class-wide type of the nonlimited view.
10918
10919             if From_Limited_With (Opnd)
10920               and then Has_Non_Limited_View (Opnd)
10921             then
10922                Opnd := Non_Limited_View (Opnd);
10923                Set_Etype (Expression (N), Opnd);
10924             end if;
10925
10926             if Is_Access_Type (Opnd) then
10927                Opnd := Designated_Type (Opnd);
10928             end if;
10929
10930             if Is_Access_Type (Target_Typ) then
10931                Target := Designated_Type (Target);
10932             end if;
10933
10934             if Opnd = Target then
10935                null;
10936
10937             --  Conversion from interface type
10938
10939             elsif Is_Interface (Opnd) then
10940
10941                --  Ada 2005 (AI-217): Handle entities from limited views
10942
10943                if From_Limited_With (Opnd) then
10944                   Error_Msg_Qual_Level := 99;
10945                   Error_Msg_NE -- CODEFIX
10946                     ("missing WITH clause on package &", N,
10947                     Cunit_Entity (Get_Source_Unit (Base_Type (Opnd))));
10948                   Error_Msg_N
10949                     ("type conversions require visibility of the full view",
10950                      N);
10951
10952                elsif From_Limited_With (Target)
10953                  and then not
10954                    (Is_Access_Type (Target_Typ)
10955                       and then Present (Non_Limited_View (Etype (Target))))
10956                then
10957                   Error_Msg_Qual_Level := 99;
10958                   Error_Msg_NE -- CODEFIX
10959                     ("missing WITH clause on package &", N,
10960                     Cunit_Entity (Get_Source_Unit (Base_Type (Target))));
10961                   Error_Msg_N
10962                     ("type conversions require visibility of the full view",
10963                      N);
10964
10965                else
10966                   Expand_Interface_Conversion (N);
10967                end if;
10968
10969             --  Conversion to interface type
10970
10971             elsif Is_Interface (Target) then
10972
10973                --  Handle subtypes
10974
10975                if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then
10976                   Opnd := Etype (Opnd);
10977                end if;
10978
10979                if Is_Class_Wide_Type (Opnd)
10980                  or else Interface_Present_In_Ancestor
10981                            (Typ   => Opnd,
10982                             Iface => Target)
10983                then
10984                   Expand_Interface_Conversion (N);
10985                else
10986                   Error_Msg_Name_1 := Chars (Etype (Target));
10987                   Error_Msg_Name_2 := Chars (Opnd);
10988                   Error_Msg_N
10989                     ("wrong interface conversion (% is not a progenitor "
10990                      & "of %)", N);
10991                end if;
10992             end if;
10993          end;
10994       end if;
10995
10996       --  Ada 2012: if target type has predicates, the result requires a
10997       --  predicate check. If the context is a call to another predicate
10998       --  check we must prevent infinite recursion.
10999
11000       if Has_Predicates (Target_Typ) then
11001          if Nkind (Parent (N)) = N_Function_Call
11002            and then Present (Name (Parent (N)))
11003            and then (Is_Predicate_Function (Entity (Name (Parent (N))))
11004                        or else
11005                      Is_Predicate_Function_M (Entity (Name (Parent (N)))))
11006          then
11007             null;
11008
11009          else
11010             Apply_Predicate_Check (N, Target_Typ);
11011          end if;
11012       end if;
11013
11014       --  If at this stage we have a real to integer conversion, make sure
11015       --  that the Do_Range_Check flag is set, because such conversions in
11016       --  general need a range check. We only need this if expansion is off
11017       --  or we are in GNATProve mode.
11018
11019       if Nkind (N) = N_Type_Conversion
11020         and then (GNATprove_Mode or not Expander_Active)
11021         and then Is_Integer_Type (Target_Typ)
11022         and then Is_Real_Type (Operand_Typ)
11023       then
11024          Set_Do_Range_Check (Operand);
11025       end if;
11026    end Resolve_Type_Conversion;
11027
11028    ----------------------
11029    -- Resolve_Unary_Op --
11030    ----------------------
11031
11032    procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
11033       B_Typ : constant Entity_Id := Base_Type (Typ);
11034       R     : constant Node_Id   := Right_Opnd (N);
11035       OK    : Boolean;
11036       Lo    : Uint;
11037       Hi    : Uint;
11038
11039    begin
11040       if Is_Modular_Integer_Type (Typ) and then Nkind (N) /= N_Op_Not then
11041          Error_Msg_Name_1 := Chars (Typ);
11042          Check_SPARK_05_Restriction
11043            ("unary operator not defined for modular type%", N);
11044       end if;
11045
11046       --  Deal with intrinsic unary operators
11047
11048       if Comes_From_Source (N)
11049         and then Ekind (Entity (N)) = E_Function
11050         and then Is_Imported (Entity (N))
11051         and then Is_Intrinsic_Subprogram (Entity (N))
11052       then
11053          Resolve_Intrinsic_Unary_Operator (N, Typ);
11054          return;
11055       end if;
11056
11057       --  Deal with universal cases
11058
11059       if Etype (R) = Universal_Integer
11060            or else
11061          Etype (R) = Universal_Real
11062       then
11063          Check_For_Visible_Operator (N, B_Typ);
11064       end if;
11065
11066       Set_Etype (N, B_Typ);
11067       Resolve (R, B_Typ);
11068
11069       --  Generate warning for expressions like abs (x mod 2)
11070
11071       if Warn_On_Redundant_Constructs
11072         and then Nkind (N) = N_Op_Abs
11073       then
11074          Determine_Range (Right_Opnd (N), OK, Lo, Hi);
11075
11076          if OK and then Hi >= Lo and then Lo >= 0 then
11077             Error_Msg_N -- CODEFIX
11078              ("?r?abs applied to known non-negative value has no effect", N);
11079          end if;
11080       end if;
11081
11082       --  Deal with reference generation
11083
11084       Check_Unset_Reference (R);
11085       Generate_Operator_Reference (N, B_Typ);
11086       Analyze_Dimension (N);
11087       Eval_Unary_Op (N);
11088
11089       --  Set overflow checking bit. Much cleverer code needed here eventually
11090       --  and perhaps the Resolve routines should be separated for the various
11091       --  arithmetic operations, since they will need different processing ???
11092
11093       if Nkind (N) in N_Op then
11094          if not Overflow_Checks_Suppressed (Etype (N)) then
11095             Enable_Overflow_Check (N);
11096          end if;
11097       end if;
11098
11099       --  Generate warning for expressions like -5 mod 3 for integers. No need
11100       --  to worry in the floating-point case, since parens do not affect the
11101       --  result so there is no point in giving in a warning.
11102
11103       declare
11104          Norig : constant Node_Id := Original_Node (N);
11105          Rorig : Node_Id;
11106          Val   : Uint;
11107          HB    : Uint;
11108          LB    : Uint;
11109          Lval  : Uint;
11110          Opnd  : Node_Id;
11111
11112       begin
11113          if Warn_On_Questionable_Missing_Parens
11114            and then Comes_From_Source (Norig)
11115            and then Is_Integer_Type (Typ)
11116            and then Nkind (Norig) = N_Op_Minus
11117          then
11118             Rorig := Original_Node (Right_Opnd (Norig));
11119
11120             --  We are looking for cases where the right operand is not
11121             --  parenthesized, and is a binary operator, multiply, divide, or
11122             --  mod. These are the cases where the grouping can affect results.
11123
11124             if Paren_Count (Rorig) = 0
11125               and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide)
11126             then
11127                --  For mod, we always give the warning, since the value is
11128                --  affected by the parenthesization (e.g. (-5) mod 315 /=
11129                --  -(5 mod 315)). But for the other cases, the only concern is
11130                --  overflow, e.g. for the case of 8 big signed (-(2 * 64)
11131                --  overflows, but (-2) * 64 does not). So we try to give the
11132                --  message only when overflow is possible.
11133
11134                if Nkind (Rorig) /= N_Op_Mod
11135                  and then Compile_Time_Known_Value (R)
11136                then
11137                   Val := Expr_Value (R);
11138
11139                   if Compile_Time_Known_Value (Type_High_Bound (Typ)) then
11140                      HB := Expr_Value (Type_High_Bound (Typ));
11141                   else
11142                      HB := Expr_Value (Type_High_Bound (Base_Type (Typ)));
11143                   end if;
11144
11145                   if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
11146                      LB := Expr_Value (Type_Low_Bound (Typ));
11147                   else
11148                      LB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
11149                   end if;
11150
11151                   --  Note that the test below is deliberately excluding the
11152                   --  largest negative number, since that is a potentially
11153                   --  troublesome case (e.g. -2 * x, where the result is the
11154                   --  largest negative integer has an overflow with 2 * x).
11155
11156                   if Val > LB and then Val <= HB then
11157                      return;
11158                   end if;
11159                end if;
11160
11161                --  For the multiplication case, the only case we have to worry
11162                --  about is when (-a)*b is exactly the largest negative number
11163                --  so that -(a*b) can cause overflow. This can only happen if
11164                --  a is a power of 2, and more generally if any operand is a
11165                --  constant that is not a power of 2, then the parentheses
11166                --  cannot affect whether overflow occurs. We only bother to
11167                --  test the left most operand
11168
11169                --  Loop looking at left operands for one that has known value
11170
11171                Opnd := Rorig;
11172                Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop
11173                   if Compile_Time_Known_Value (Left_Opnd (Opnd)) then
11174                      Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd)));
11175
11176                      --  Operand value of 0 or 1 skips warning
11177
11178                      if Lval <= 1 then
11179                         return;
11180
11181                      --  Otherwise check power of 2, if power of 2, warn, if
11182                      --  anything else, skip warning.
11183
11184                      else
11185                         while Lval /= 2 loop
11186                            if Lval mod 2 = 1 then
11187                               return;
11188                            else
11189                               Lval := Lval / 2;
11190                            end if;
11191                         end loop;
11192
11193                         exit Opnd_Loop;
11194                      end if;
11195                   end if;
11196
11197                   --  Keep looking at left operands
11198
11199                   Opnd := Left_Opnd (Opnd);
11200                end loop Opnd_Loop;
11201
11202                --  For rem or "/" we can only have a problematic situation
11203                --  if the divisor has a value of minus one or one. Otherwise
11204                --  overflow is impossible (divisor > 1) or we have a case of
11205                --  division by zero in any case.
11206
11207                if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem)
11208                  and then Compile_Time_Known_Value (Right_Opnd (Rorig))
11209                  and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
11210                then
11211                   return;
11212                end if;
11213
11214                --  If we fall through warning should be issued
11215
11216                --  Shouldn't we test Warn_On_Questionable_Missing_Parens ???
11217
11218                Error_Msg_N
11219                  ("??unary minus expression should be parenthesized here!", N);
11220             end if;
11221          end if;
11222       end;
11223    end Resolve_Unary_Op;
11224
11225    ----------------------------------
11226    -- Resolve_Unchecked_Expression --
11227    ----------------------------------
11228
11229    procedure Resolve_Unchecked_Expression
11230      (N   : Node_Id;
11231       Typ : Entity_Id)
11232    is
11233    begin
11234       Resolve (Expression (N), Typ, Suppress => All_Checks);
11235       Set_Etype (N, Typ);
11236    end Resolve_Unchecked_Expression;
11237
11238    ---------------------------------------
11239    -- Resolve_Unchecked_Type_Conversion --
11240    ---------------------------------------
11241
11242    procedure Resolve_Unchecked_Type_Conversion
11243      (N   : Node_Id;
11244       Typ : Entity_Id)
11245    is
11246       pragma Warnings (Off, Typ);
11247
11248       Operand   : constant Node_Id   := Expression (N);
11249       Opnd_Type : constant Entity_Id := Etype (Operand);
11250
11251    begin
11252       --  Resolve operand using its own type
11253
11254       Resolve (Operand, Opnd_Type);
11255
11256       --  In an inlined context, the unchecked conversion may be applied
11257       --  to a literal, in which case its type is the type of the context.
11258       --  (In other contexts conversions cannot apply to literals).
11259
11260       if In_Inlined_Body
11261         and then (Opnd_Type = Any_Character or else
11262                   Opnd_Type = Any_Integer   or else
11263                   Opnd_Type = Any_Real)
11264       then
11265          Set_Etype (Operand, Typ);
11266       end if;
11267
11268       Analyze_Dimension (N);
11269       Eval_Unchecked_Conversion (N);
11270    end Resolve_Unchecked_Type_Conversion;
11271
11272    ------------------------------
11273    -- Rewrite_Operator_As_Call --
11274    ------------------------------
11275
11276    procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
11277       Loc     : constant Source_Ptr := Sloc (N);
11278       Actuals : constant List_Id    := New_List;
11279       New_N   : Node_Id;
11280
11281    begin
11282       if Nkind (N) in N_Binary_Op then
11283          Append (Left_Opnd (N), Actuals);
11284       end if;
11285
11286       Append (Right_Opnd (N), Actuals);
11287
11288       New_N :=
11289         Make_Function_Call (Sloc => Loc,
11290           Name => New_Occurrence_Of (Nam, Loc),
11291           Parameter_Associations => Actuals);
11292
11293       Preserve_Comes_From_Source (New_N, N);
11294       Preserve_Comes_From_Source (Name (New_N), N);
11295       Rewrite (N, New_N);
11296       Set_Etype (N, Etype (Nam));
11297    end Rewrite_Operator_As_Call;
11298
11299    ------------------------------
11300    -- Rewrite_Renamed_Operator --
11301    ------------------------------
11302
11303    procedure Rewrite_Renamed_Operator
11304      (N   : Node_Id;
11305       Op  : Entity_Id;
11306       Typ : Entity_Id)
11307    is
11308       Nam       : constant Name_Id := Chars (Op);
11309       Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
11310       Op_Node   : Node_Id;
11311
11312    begin
11313       --  Do not perform this transformation within a pre/postcondition,
11314       --  because the expression will be re-analyzed, and the transformation
11315       --  might affect the visibility of the operator, e.g. in an instance.
11316
11317       if In_Assertion_Expr > 0 then
11318          return;
11319       end if;
11320
11321       --  Rewrite the operator node using the real operator, not its renaming.
11322       --  Exclude user-defined intrinsic operations of the same name, which are
11323       --  treated separately and rewritten as calls.
11324
11325       if Ekind (Op) /= E_Function or else Chars (N) /= Nam then
11326          Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
11327          Set_Chars      (Op_Node, Nam);
11328          Set_Etype      (Op_Node, Etype (N));
11329          Set_Entity     (Op_Node, Op);
11330          Set_Right_Opnd (Op_Node, Right_Opnd (N));
11331
11332          --  Indicate that both the original entity and its renaming are
11333          --  referenced at this point.
11334
11335          Generate_Reference (Entity (N), N);
11336          Generate_Reference (Op, N);
11337
11338          if Is_Binary then
11339             Set_Left_Opnd  (Op_Node, Left_Opnd  (N));
11340          end if;
11341
11342          Rewrite (N, Op_Node);
11343
11344          --  If the context type is private, add the appropriate conversions so
11345          --  that the operator is applied to the full view. This is done in the
11346          --  routines that resolve intrinsic operators.
11347
11348          if Is_Intrinsic_Subprogram (Op)
11349            and then Is_Private_Type (Typ)
11350          then
11351             case Nkind (N) is
11352                when N_Op_Add   | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
11353                     N_Op_Expon | N_Op_Mod      | N_Op_Rem      =>
11354                   Resolve_Intrinsic_Operator (N, Typ);
11355
11356                when N_Op_Plus  | N_Op_Minus    | N_Op_Abs      =>
11357                   Resolve_Intrinsic_Unary_Operator (N, Typ);
11358
11359                when others =>
11360                   Resolve (N, Typ);
11361             end case;
11362          end if;
11363
11364       elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then
11365
11366          --  Operator renames a user-defined operator of the same name. Use the
11367          --  original operator in the node, which is the one Gigi knows about.
11368
11369          Set_Entity (N, Op);
11370          Set_Is_Overloaded (N, False);
11371       end if;
11372    end Rewrite_Renamed_Operator;
11373
11374    -----------------------
11375    -- Set_Slice_Subtype --
11376    -----------------------
11377
11378    --  Build an implicit subtype declaration to represent the type delivered by
11379    --  the slice. This is an abbreviated version of an array subtype. We define
11380    --  an index subtype for the slice, using either the subtype name or the
11381    --  discrete range of the slice. To be consistent with index usage elsewhere
11382    --  we create a list header to hold the single index. This list is not
11383    --  otherwise attached to the syntax tree.
11384
11385    procedure Set_Slice_Subtype (N : Node_Id) is
11386       Loc           : constant Source_Ptr := Sloc (N);
11387       Index_List    : constant List_Id    := New_List;
11388       Index         : Node_Id;
11389       Index_Subtype : Entity_Id;
11390       Index_Type    : Entity_Id;
11391       Slice_Subtype : Entity_Id;
11392       Drange        : constant Node_Id := Discrete_Range (N);
11393
11394    begin
11395       Index_Type := Base_Type (Etype (Drange));
11396
11397       if Is_Entity_Name (Drange) then
11398          Index_Subtype := Entity (Drange);
11399
11400       else
11401          --  We force the evaluation of a range. This is definitely needed in
11402          --  the renamed case, and seems safer to do unconditionally. Note in
11403          --  any case that since we will create and insert an Itype referring
11404          --  to this range, we must make sure any side effect removal actions
11405          --  are inserted before the Itype definition.
11406
11407          if Nkind (Drange) = N_Range then
11408             Force_Evaluation (Low_Bound (Drange));
11409             Force_Evaluation (High_Bound (Drange));
11410
11411          --  If the discrete range is given by a subtype indication, the
11412          --  type of the slice is the base of the subtype mark.
11413
11414          elsif Nkind (Drange) = N_Subtype_Indication then
11415             declare
11416                R : constant Node_Id := Range_Expression (Constraint (Drange));
11417             begin
11418                Index_Type := Base_Type (Entity (Subtype_Mark (Drange)));
11419                Force_Evaluation (Low_Bound  (R));
11420                Force_Evaluation (High_Bound (R));
11421             end;
11422          end if;
11423
11424          Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
11425
11426          --  Take a new copy of Drange (where bounds have been rewritten to
11427          --  reference side-effect-free names). Using a separate tree ensures
11428          --  that further expansion (e.g. while rewriting a slice assignment
11429          --  into a FOR loop) does not attempt to remove side effects on the
11430          --  bounds again (which would cause the bounds in the index subtype
11431          --  definition to refer to temporaries before they are defined) (the
11432          --  reason is that some names are considered side effect free here
11433          --  for the subtype, but not in the context of a loop iteration
11434          --  scheme).
11435
11436          Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange));
11437          Set_Parent       (Scalar_Range (Index_Subtype), Index_Subtype);
11438          Set_Etype        (Index_Subtype, Index_Type);
11439          Set_Size_Info    (Index_Subtype, Index_Type);
11440          Set_RM_Size      (Index_Subtype, RM_Size (Index_Type));
11441       end if;
11442
11443       Slice_Subtype := Create_Itype (E_Array_Subtype, N);
11444
11445       Index := New_Occurrence_Of (Index_Subtype, Loc);
11446       Set_Etype (Index, Index_Subtype);
11447       Append (Index, Index_List);
11448
11449       Set_First_Index    (Slice_Subtype, Index);
11450       Set_Etype          (Slice_Subtype, Base_Type (Etype (N)));
11451       Set_Is_Constrained (Slice_Subtype, True);
11452
11453       Check_Compile_Time_Size (Slice_Subtype);
11454
11455       --  The Etype of the existing Slice node is reset to this slice subtype.
11456       --  Its bounds are obtained from its first index.
11457
11458       Set_Etype (N, Slice_Subtype);
11459
11460       --  For packed slice subtypes, freeze immediately (except in the case of
11461       --  being in a "spec expression" where we never freeze when we first see
11462       --  the expression).
11463
11464       if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
11465          Freeze_Itype (Slice_Subtype, N);
11466
11467       --  For all other cases insert an itype reference in the slice's actions
11468       --  so that the itype is frozen at the proper place in the tree (i.e. at
11469       --  the point where actions for the slice are analyzed). Note that this
11470       --  is different from freezing the itype immediately, which might be
11471       --  premature (e.g. if the slice is within a transient scope). This needs
11472       --  to be done only if expansion is enabled.
11473
11474       elsif Expander_Active then
11475          Ensure_Defined (Typ => Slice_Subtype, N => N);
11476       end if;
11477    end Set_Slice_Subtype;
11478
11479    --------------------------------
11480    -- Set_String_Literal_Subtype --
11481    --------------------------------
11482
11483    procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
11484       Loc        : constant Source_Ptr := Sloc (N);
11485       Low_Bound  : constant Node_Id :=
11486                      Type_Low_Bound (Etype (First_Index (Typ)));
11487       Subtype_Id : Entity_Id;
11488
11489    begin
11490       if Nkind (N) /= N_String_Literal then
11491          return;
11492       end if;
11493
11494       Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
11495       Set_String_Literal_Length (Subtype_Id, UI_From_Int
11496                                                (String_Length (Strval (N))));
11497       Set_Etype          (Subtype_Id, Base_Type (Typ));
11498       Set_Is_Constrained (Subtype_Id);
11499       Set_Etype          (N, Subtype_Id);
11500
11501       --  The low bound is set from the low bound of the corresponding index
11502       --  type. Note that we do not store the high bound in the string literal
11503       --  subtype, but it can be deduced if necessary from the length and the
11504       --  low bound.
11505
11506       if Is_OK_Static_Expression (Low_Bound) then
11507          Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound);
11508
11509       --  If the lower bound is not static we create a range for the string
11510       --  literal, using the index type and the known length of the literal.
11511       --  The index type is not necessarily Positive, so the upper bound is
11512       --  computed as T'Val (T'Pos (Low_Bound) + L - 1).
11513
11514       else
11515          declare
11516             Index_List : constant List_Id   := New_List;
11517             Index_Type : constant Entity_Id := Etype (First_Index (Typ));
11518             High_Bound : constant Node_Id   :=
11519                            Make_Attribute_Reference (Loc,
11520                              Attribute_Name => Name_Val,
11521                              Prefix         =>
11522                                New_Occurrence_Of (Index_Type, Loc),
11523                              Expressions    => New_List (
11524                                Make_Op_Add (Loc,
11525                                  Left_Opnd  =>
11526                                    Make_Attribute_Reference (Loc,
11527                                      Attribute_Name => Name_Pos,
11528                                      Prefix         =>
11529                                        New_Occurrence_Of (Index_Type, Loc),
11530                                      Expressions    =>
11531                                        New_List (New_Copy_Tree (Low_Bound))),
11532                                  Right_Opnd =>
11533                                    Make_Integer_Literal (Loc,
11534                                      String_Length (Strval (N)) - 1))));
11535
11536             Array_Subtype : Entity_Id;
11537             Drange        : Node_Id;
11538             Index         : Node_Id;
11539             Index_Subtype : Entity_Id;
11540
11541          begin
11542             if Is_Integer_Type (Index_Type) then
11543                Set_String_Literal_Low_Bound
11544                  (Subtype_Id, Make_Integer_Literal (Loc, 1));
11545
11546             else
11547                --  If the index type is an enumeration type, build bounds
11548                --  expression with attributes.
11549
11550                Set_String_Literal_Low_Bound
11551                  (Subtype_Id,
11552                   Make_Attribute_Reference (Loc,
11553                     Attribute_Name => Name_First,
11554                     Prefix         =>
11555                       New_Occurrence_Of (Base_Type (Index_Type), Loc)));
11556                Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type);
11557             end if;
11558
11559             Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id));
11560
11561             --  Build bona fide subtype for the string, and wrap it in an
11562             --  unchecked conversion, because the backend expects the
11563             --  String_Literal_Subtype to have a static lower bound.
11564
11565             Index_Subtype :=
11566               Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
11567             Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound);
11568             Set_Scalar_Range (Index_Subtype, Drange);
11569             Set_Parent (Drange, N);
11570             Analyze_And_Resolve (Drange, Index_Type);
11571
11572             --  In the context, the Index_Type may already have a constraint,
11573             --  so use common base type on string subtype. The base type may
11574             --  be used when generating attributes of the string, for example
11575             --  in the context of a slice assignment.
11576
11577             Set_Etype     (Index_Subtype, Base_Type (Index_Type));
11578             Set_Size_Info (Index_Subtype, Index_Type);
11579             Set_RM_Size   (Index_Subtype, RM_Size (Index_Type));
11580
11581             Array_Subtype := Create_Itype (E_Array_Subtype, N);
11582
11583             Index := New_Occurrence_Of (Index_Subtype, Loc);
11584             Set_Etype (Index, Index_Subtype);
11585             Append (Index, Index_List);
11586
11587             Set_First_Index    (Array_Subtype, Index);
11588             Set_Etype          (Array_Subtype, Base_Type (Typ));
11589             Set_Is_Constrained (Array_Subtype, True);
11590
11591             Rewrite (N,
11592               Make_Unchecked_Type_Conversion (Loc,
11593                 Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc),
11594                 Expression   => Relocate_Node (N)));
11595             Set_Etype (N, Array_Subtype);
11596          end;
11597       end if;
11598    end Set_String_Literal_Subtype;
11599
11600    ------------------------------
11601    -- Simplify_Type_Conversion --
11602    ------------------------------
11603
11604    procedure Simplify_Type_Conversion (N : Node_Id) is
11605    begin
11606       if Nkind (N) = N_Type_Conversion then
11607          declare
11608             Operand    : constant Node_Id   := Expression (N);
11609             Target_Typ : constant Entity_Id := Etype (N);
11610             Opnd_Typ   : constant Entity_Id := Etype (Operand);
11611
11612          begin
11613             --  Special processing if the conversion is the expression of a
11614             --  Rounding or Truncation attribute reference. In this case we
11615             --  replace:
11616
11617             --     ityp (ftyp'Rounding (x)) or ityp (ftyp'Truncation (x))
11618
11619             --  by
11620
11621             --     ityp (x)
11622
11623             --  with the Float_Truncate flag set to False or True respectively,
11624             --  which is more efficient.
11625
11626             if Is_Floating_Point_Type (Opnd_Typ)
11627               and then
11628                 (Is_Integer_Type (Target_Typ)
11629                   or else (Is_Fixed_Point_Type (Target_Typ)
11630                             and then Conversion_OK (N)))
11631               and then Nkind (Operand) = N_Attribute_Reference
11632               and then Nam_In (Attribute_Name (Operand), Name_Rounding,
11633                                                          Name_Truncation)
11634             then
11635                declare
11636                   Truncate : constant Boolean :=
11637                                Attribute_Name (Operand) = Name_Truncation;
11638                begin
11639                   Rewrite (Operand,
11640                     Relocate_Node (First (Expressions (Operand))));
11641                   Set_Float_Truncate (N, Truncate);
11642                end;
11643             end if;
11644          end;
11645       end if;
11646    end Simplify_Type_Conversion;
11647
11648    -----------------------------
11649    -- Unique_Fixed_Point_Type --
11650    -----------------------------
11651
11652    function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
11653       T1   : Entity_Id := Empty;
11654       T2   : Entity_Id;
11655       Item : Node_Id;
11656       Scop : Entity_Id;
11657
11658       procedure Fixed_Point_Error;
11659       --  Give error messages for true ambiguity. Messages are posted on node
11660       --  N, and entities T1, T2 are the possible interpretations.
11661
11662       -----------------------
11663       -- Fixed_Point_Error --
11664       -----------------------
11665
11666       procedure Fixed_Point_Error is
11667       begin
11668          Error_Msg_N ("ambiguous universal_fixed_expression", N);
11669          Error_Msg_NE ("\\possible interpretation as}", N, T1);
11670          Error_Msg_NE ("\\possible interpretation as}", N, T2);
11671       end Fixed_Point_Error;
11672
11673    --  Start of processing for Unique_Fixed_Point_Type
11674
11675    begin
11676       --  The operations on Duration are visible, so Duration is always a
11677       --  possible interpretation.
11678
11679       T1 := Standard_Duration;
11680
11681       --  Look for fixed-point types in enclosing scopes
11682
11683       Scop := Current_Scope;
11684       while Scop /= Standard_Standard loop
11685          T2 := First_Entity (Scop);
11686          while Present (T2) loop
11687             if Is_Fixed_Point_Type (T2)
11688               and then Current_Entity (T2) = T2
11689               and then Scope (Base_Type (T2)) = Scop
11690             then
11691                if Present (T1) then
11692                   Fixed_Point_Error;
11693                   return Any_Type;
11694                else
11695                   T1 := T2;
11696                end if;
11697             end if;
11698
11699             Next_Entity (T2);
11700          end loop;
11701
11702          Scop := Scope (Scop);
11703       end loop;
11704
11705       --  Look for visible fixed type declarations in the context
11706
11707       Item := First (Context_Items (Cunit (Current_Sem_Unit)));
11708       while Present (Item) loop
11709          if Nkind (Item) = N_With_Clause then
11710             Scop := Entity (Name (Item));
11711             T2 := First_Entity (Scop);
11712             while Present (T2) loop
11713                if Is_Fixed_Point_Type (T2)
11714                  and then Scope (Base_Type (T2)) = Scop
11715                  and then (Is_Potentially_Use_Visible (T2) or else In_Use (T2))
11716                then
11717                   if Present (T1) then
11718                      Fixed_Point_Error;
11719                      return Any_Type;
11720                   else
11721                      T1 := T2;
11722                   end if;
11723                end if;
11724
11725                Next_Entity (T2);
11726             end loop;
11727          end if;
11728
11729          Next (Item);
11730       end loop;
11731
11732       if Nkind (N) = N_Real_Literal then
11733          Error_Msg_NE
11734            ("??real literal interpreted as }!", N, T1);
11735       else
11736          Error_Msg_NE
11737            ("??universal_fixed expression interpreted as }!", N, T1);
11738       end if;
11739
11740       return T1;
11741    end Unique_Fixed_Point_Type;
11742
11743    ----------------------
11744    -- Valid_Conversion --
11745    ----------------------
11746
11747    function Valid_Conversion
11748      (N           : Node_Id;
11749       Target      : Entity_Id;
11750       Operand     : Node_Id;
11751       Report_Errs : Boolean := True) return Boolean
11752    is
11753       Target_Type  : constant Entity_Id := Base_Type (Target);
11754       Opnd_Type    : Entity_Id          := Etype (Operand);
11755       Inc_Ancestor : Entity_Id;
11756
11757       function Conversion_Check
11758         (Valid : Boolean;
11759          Msg   : String) return Boolean;
11760       --  Little routine to post Msg if Valid is False, returns Valid value
11761
11762       procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id);
11763       --  If Report_Errs, then calls Errout.Error_Msg_N with its arguments
11764
11765       procedure Conversion_Error_NE
11766         (Msg : String;
11767          N   : Node_Or_Entity_Id;
11768          E   : Node_Or_Entity_Id);
11769       --  If Report_Errs, then calls Errout.Error_Msg_NE with its arguments
11770
11771       function Valid_Tagged_Conversion
11772         (Target_Type : Entity_Id;
11773          Opnd_Type   : Entity_Id) return Boolean;
11774       --  Specifically test for validity of tagged conversions
11775
11776       function Valid_Array_Conversion return Boolean;
11777       --  Check index and component conformance, and accessibility levels if
11778       --  the component types are anonymous access types (Ada 2005).
11779
11780       ----------------------
11781       -- Conversion_Check --
11782       ----------------------
11783
11784       function Conversion_Check
11785         (Valid : Boolean;
11786          Msg   : String) return Boolean
11787       is
11788       begin
11789          if not Valid
11790
11791             --  A generic unit has already been analyzed and we have verified
11792             --  that a particular conversion is OK in that context. Since the
11793             --  instance is reanalyzed without relying on the relationships
11794             --  established during the analysis of the generic, it is possible
11795             --  to end up with inconsistent views of private types. Do not emit
11796             --  the error message in such cases. The rest of the machinery in
11797             --  Valid_Conversion still ensures the proper compatibility of
11798             --  target and operand types.
11799
11800            and then not In_Instance
11801          then
11802             Conversion_Error_N (Msg, Operand);
11803          end if;
11804
11805          return Valid;
11806       end Conversion_Check;
11807
11808       ------------------------
11809       -- Conversion_Error_N --
11810       ------------------------
11811
11812       procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id) is
11813       begin
11814          if Report_Errs then
11815             Error_Msg_N (Msg, N);
11816          end if;
11817       end Conversion_Error_N;
11818
11819       -------------------------
11820       -- Conversion_Error_NE --
11821       -------------------------
11822
11823       procedure Conversion_Error_NE
11824         (Msg : String;
11825          N   : Node_Or_Entity_Id;
11826          E   : Node_Or_Entity_Id)
11827       is
11828       begin
11829          if Report_Errs then
11830             Error_Msg_NE (Msg, N, E);
11831          end if;
11832       end Conversion_Error_NE;
11833
11834       ----------------------------
11835       -- Valid_Array_Conversion --
11836       ----------------------------
11837
11838       function Valid_Array_Conversion return Boolean
11839       is
11840          Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type);
11841          Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type);
11842
11843          Opnd_Index      : Node_Id;
11844          Opnd_Index_Type : Entity_Id;
11845
11846          Target_Comp_Type : constant Entity_Id :=
11847                               Component_Type (Target_Type);
11848          Target_Comp_Base : constant Entity_Id :=
11849                               Base_Type (Target_Comp_Type);
11850
11851          Target_Index      : Node_Id;
11852          Target_Index_Type : Entity_Id;
11853
11854       begin
11855          --  Error if wrong number of dimensions
11856
11857          if
11858            Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type)
11859          then
11860             Conversion_Error_N
11861               ("incompatible number of dimensions for conversion", Operand);
11862             return False;
11863
11864          --  Number of dimensions matches
11865
11866          else
11867             --  Loop through indexes of the two arrays
11868
11869             Target_Index := First_Index (Target_Type);
11870             Opnd_Index   := First_Index (Opnd_Type);
11871             while Present (Target_Index) and then Present (Opnd_Index) loop
11872                Target_Index_Type := Etype (Target_Index);
11873                Opnd_Index_Type   := Etype (Opnd_Index);
11874
11875                --  Error if index types are incompatible
11876
11877                if not (Is_Integer_Type (Target_Index_Type)
11878                        and then Is_Integer_Type (Opnd_Index_Type))
11879                  and then (Root_Type (Target_Index_Type)
11880                            /= Root_Type (Opnd_Index_Type))
11881                then
11882                   Conversion_Error_N
11883                     ("incompatible index types for array conversion",
11884                      Operand);
11885                   return False;
11886                end if;
11887
11888                Next_Index (Target_Index);
11889                Next_Index (Opnd_Index);
11890             end loop;
11891
11892             --  If component types have same base type, all set
11893
11894             if Target_Comp_Base  = Opnd_Comp_Base then
11895                null;
11896
11897                --  Here if base types of components are not the same. The only
11898                --  time this is allowed is if we have anonymous access types.
11899
11900                --  The conversion of arrays of anonymous access types can lead
11901                --  to dangling pointers. AI-392 formalizes the accessibility
11902                --  checks that must be applied to such conversions to prevent
11903                --  out-of-scope references.
11904
11905             elsif Ekind_In
11906                     (Target_Comp_Base, E_Anonymous_Access_Type,
11907                                        E_Anonymous_Access_Subprogram_Type)
11908               and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base)
11909               and then
11910                 Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
11911             then
11912                if Type_Access_Level (Target_Type) <
11913                     Deepest_Type_Access_Level (Opnd_Type)
11914                then
11915                   if In_Instance_Body then
11916                      Error_Msg_Warn := SPARK_Mode /= On;
11917                      Conversion_Error_N
11918                        ("source array type has deeper accessibility "
11919                         & "level than target<<", Operand);
11920                      Conversion_Error_N ("\Program_Error [<<", Operand);
11921                      Rewrite (N,
11922                        Make_Raise_Program_Error (Sloc (N),
11923                          Reason => PE_Accessibility_Check_Failed));
11924                      Set_Etype (N, Target_Type);
11925                      return False;
11926
11927                   --  Conversion not allowed because of accessibility levels
11928
11929                   else
11930                      Conversion_Error_N
11931                        ("source array type has deeper accessibility "
11932                         & "level than target", Operand);
11933                      return False;
11934                   end if;
11935
11936                else
11937                   null;
11938                end if;
11939
11940             --  All other cases where component base types do not match
11941
11942             else
11943                Conversion_Error_N
11944                  ("incompatible component types for array conversion",
11945                   Operand);
11946                return False;
11947             end if;
11948
11949             --  Check that component subtypes statically match. For numeric
11950             --  types this means that both must be either constrained or
11951             --  unconstrained. For enumeration types the bounds must match.
11952             --  All of this is checked in Subtypes_Statically_Match.
11953
11954             if not Subtypes_Statically_Match
11955                      (Target_Comp_Type, Opnd_Comp_Type)
11956             then
11957                Conversion_Error_N
11958                  ("component subtypes must statically match", Operand);
11959                return False;
11960             end if;
11961          end if;
11962
11963          return True;
11964       end Valid_Array_Conversion;
11965
11966       -----------------------------
11967       -- Valid_Tagged_Conversion --
11968       -----------------------------
11969
11970       function Valid_Tagged_Conversion
11971         (Target_Type : Entity_Id;
11972          Opnd_Type   : Entity_Id) return Boolean
11973       is
11974       begin
11975          --  Upward conversions are allowed (RM 4.6(22))
11976
11977          if Covers (Target_Type, Opnd_Type)
11978            or else Is_Ancestor (Target_Type, Opnd_Type)
11979          then
11980             return True;
11981
11982          --  Downward conversion are allowed if the operand is class-wide
11983          --  (RM 4.6(23)).
11984
11985          elsif Is_Class_Wide_Type (Opnd_Type)
11986            and then Covers (Opnd_Type, Target_Type)
11987          then
11988             return True;
11989
11990          elsif Covers (Opnd_Type, Target_Type)
11991            or else Is_Ancestor (Opnd_Type, Target_Type)
11992          then
11993             return
11994               Conversion_Check (False,
11995                 "downward conversion of tagged objects not allowed");
11996
11997          --  Ada 2005 (AI-251): The conversion to/from interface types is
11998          --  always valid
11999
12000          elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then
12001             return True;
12002
12003          --  If the operand is a class-wide type obtained through a limited_
12004          --  with clause, and the context includes the nonlimited view, use
12005          --  it to determine whether the conversion is legal.
12006
12007          elsif Is_Class_Wide_Type (Opnd_Type)
12008            and then From_Limited_With (Opnd_Type)
12009            and then Present (Non_Limited_View (Etype (Opnd_Type)))
12010            and then Is_Interface (Non_Limited_View (Etype (Opnd_Type)))
12011          then
12012             return True;
12013
12014          elsif Is_Access_Type (Opnd_Type)
12015            and then Is_Interface (Directly_Designated_Type (Opnd_Type))
12016          then
12017             return True;
12018
12019          else
12020             Conversion_Error_NE
12021               ("invalid tagged conversion, not compatible with}",
12022                N, First_Subtype (Opnd_Type));
12023             return False;
12024          end if;
12025       end Valid_Tagged_Conversion;
12026
12027    --  Start of processing for Valid_Conversion
12028
12029    begin
12030       Check_Parameterless_Call (Operand);
12031
12032       if Is_Overloaded (Operand) then
12033          declare
12034             I   : Interp_Index;
12035             I1  : Interp_Index;
12036             It  : Interp;
12037             It1 : Interp;
12038             N1  : Entity_Id;
12039             T1  : Entity_Id;
12040
12041          begin
12042             --  Remove procedure calls, which syntactically cannot appear in
12043             --  this context, but which cannot be removed by type checking,
12044             --  because the context does not impose a type.
12045
12046             --  The node may be labelled overloaded, but still contain only one
12047             --  interpretation because others were discarded earlier. If this
12048             --  is the case, retain the single interpretation if legal.
12049
12050             Get_First_Interp (Operand, I, It);
12051             Opnd_Type := It.Typ;
12052             Get_Next_Interp (I, It);
12053
12054             if Present (It.Typ)
12055               and then Opnd_Type /= Standard_Void_Type
12056             then
12057                --  More than one candidate interpretation is available
12058
12059                Get_First_Interp (Operand, I, It);
12060                while Present (It.Typ) loop
12061                   if It.Typ = Standard_Void_Type then
12062                      Remove_Interp (I);
12063                   end if;
12064
12065                   --  When compiling for a system where Address is of a visible
12066                   --  integer type, spurious ambiguities can be produced when
12067                   --  arithmetic operations have a literal operand and return
12068                   --  System.Address or a descendant of it. These ambiguities
12069                   --  are usually resolved by the context, but for conversions
12070                   --  there is no context type and the removal of the spurious
12071                   --  operations must be done explicitly here.
12072
12073                   if not Address_Is_Private
12074                     and then Is_Descendent_Of_Address (It.Typ)
12075                   then
12076                      Remove_Interp (I);
12077                   end if;
12078
12079                   Get_Next_Interp (I, It);
12080                end loop;
12081             end if;
12082
12083             Get_First_Interp (Operand, I, It);
12084             I1  := I;
12085             It1 := It;
12086
12087             if No (It.Typ) then
12088                Conversion_Error_N ("illegal operand in conversion", Operand);
12089                return False;
12090             end if;
12091
12092             Get_Next_Interp (I, It);
12093
12094             if Present (It.Typ) then
12095                N1  := It1.Nam;
12096                T1  := It1.Typ;
12097                It1 := Disambiguate (Operand, I1, I, Any_Type);
12098
12099                if It1 = No_Interp then
12100                   Conversion_Error_N
12101                     ("ambiguous operand in conversion", Operand);
12102
12103                   --  If the interpretation involves a standard operator, use
12104                   --  the location of the type, which may be user-defined.
12105
12106                   if Sloc (It.Nam) = Standard_Location then
12107                      Error_Msg_Sloc := Sloc (It.Typ);
12108                   else
12109                      Error_Msg_Sloc := Sloc (It.Nam);
12110                   end if;
12111
12112                   Conversion_Error_N -- CODEFIX
12113                     ("\\possible interpretation#!", Operand);
12114
12115                   if Sloc (N1) = Standard_Location then
12116                      Error_Msg_Sloc := Sloc (T1);
12117                   else
12118                      Error_Msg_Sloc := Sloc (N1);
12119                   end if;
12120
12121                   Conversion_Error_N -- CODEFIX
12122                     ("\\possible interpretation#!", Operand);
12123
12124                   return False;
12125                end if;
12126             end if;
12127
12128             Set_Etype (Operand, It1.Typ);
12129             Opnd_Type := It1.Typ;
12130          end;
12131       end if;
12132
12133       --  Deal with conversion of integer type to address if the pragma
12134       --  Allow_Integer_Address is in effect. We convert the conversion to
12135       --  an unchecked conversion in this case and we are all done.
12136
12137       if Address_Integer_Convert_OK (Opnd_Type, Target_Type) then
12138          Rewrite (N, Unchecked_Convert_To (Target_Type, Expression (N)));
12139          Analyze_And_Resolve (N, Target_Type);
12140          return True;
12141       end if;
12142
12143       --  If we are within a child unit, check whether the type of the
12144       --  expression has an ancestor in a parent unit, in which case it
12145       --  belongs to its derivation class even if the ancestor is private.
12146       --  See RM 7.3.1 (5.2/3).
12147
12148       Inc_Ancestor := Get_Incomplete_View_Of_Ancestor (Opnd_Type);
12149
12150       --  Numeric types
12151
12152       if Is_Numeric_Type (Target_Type) then
12153
12154          --  A universal fixed expression can be converted to any numeric type
12155
12156          if Opnd_Type = Universal_Fixed then
12157             return True;
12158
12159          --  Also no need to check when in an instance or inlined body, because
12160          --  the legality has been established when the template was analyzed.
12161          --  Furthermore, numeric conversions may occur where only a private
12162          --  view of the operand type is visible at the instantiation point.
12163          --  This results in a spurious error if we check that the operand type
12164          --  is a numeric type.
12165
12166          --  Note: in a previous version of this unit, the following tests were
12167          --  applied only for generated code (Comes_From_Source set to False),
12168          --  but in fact the test is required for source code as well, since
12169          --  this situation can arise in source code.
12170
12171          elsif In_Instance or else In_Inlined_Body then
12172             return True;
12173
12174          --  Otherwise we need the conversion check
12175
12176          else
12177             return Conversion_Check
12178                      (Is_Numeric_Type (Opnd_Type)
12179                        or else
12180                          (Present (Inc_Ancestor)
12181                            and then Is_Numeric_Type (Inc_Ancestor)),
12182                       "illegal operand for numeric conversion");
12183          end if;
12184
12185       --  Array types
12186
12187       elsif Is_Array_Type (Target_Type) then
12188          if not Is_Array_Type (Opnd_Type)
12189            or else Opnd_Type = Any_Composite
12190            or else Opnd_Type = Any_String
12191          then
12192             Conversion_Error_N
12193               ("illegal operand for array conversion", Operand);
12194             return False;
12195
12196          else
12197             return Valid_Array_Conversion;
12198          end if;
12199
12200       --  Ada 2005 (AI-251): Internally generated conversions of access to
12201       --  interface types added to force the displacement of the pointer to
12202       --  reference the corresponding dispatch table.
12203
12204       elsif not Comes_From_Source (N)
12205          and then Is_Access_Type (Target_Type)
12206          and then Is_Interface (Designated_Type (Target_Type))
12207       then
12208          return True;
12209
12210       --  Ada 2005 (AI-251): Anonymous access types where target references an
12211       --  interface type.
12212
12213       elsif Is_Access_Type (Opnd_Type)
12214         and then Ekind_In (Target_Type, E_General_Access_Type,
12215                                         E_Anonymous_Access_Type)
12216         and then Is_Interface (Directly_Designated_Type (Target_Type))
12217       then
12218          --  Check the static accessibility rule of 4.6(17). Note that the
12219          --  check is not enforced when within an instance body, since the
12220          --  RM requires such cases to be caught at run time.
12221
12222          --  If the operand is a rewriting of an allocator no check is needed
12223          --  because there are no accessibility issues.
12224
12225          if Nkind (Original_Node (N)) = N_Allocator then
12226             null;
12227
12228          elsif Ekind (Target_Type) /= E_Anonymous_Access_Type then
12229             if Type_Access_Level (Opnd_Type) >
12230                Deepest_Type_Access_Level (Target_Type)
12231             then
12232                --  In an instance, this is a run-time check, but one we know
12233                --  will fail, so generate an appropriate warning. The raise
12234                --  will be generated by Expand_N_Type_Conversion.
12235
12236                if In_Instance_Body then
12237                   Error_Msg_Warn := SPARK_Mode /= On;
12238                   Conversion_Error_N
12239                     ("cannot convert local pointer to non-local access type<<",
12240                      Operand);
12241                   Conversion_Error_N ("\Program_Error [<<", Operand);
12242
12243                else
12244                   Conversion_Error_N
12245                     ("cannot convert local pointer to non-local access type",
12246                      Operand);
12247                   return False;
12248                end if;
12249
12250             --  Special accessibility checks are needed in the case of access
12251             --  discriminants declared for a limited type.
12252
12253             elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
12254               and then not Is_Local_Anonymous_Access (Opnd_Type)
12255             then
12256                --  When the operand is a selected access discriminant the check
12257                --  needs to be made against the level of the object denoted by
12258                --  the prefix of the selected name (Object_Access_Level handles
12259                --  checking the prefix of the operand for this case).
12260
12261                if Nkind (Operand) = N_Selected_Component
12262                  and then Object_Access_Level (Operand) >
12263                    Deepest_Type_Access_Level (Target_Type)
12264                then
12265                   --  In an instance, this is a run-time check, but one we know
12266                   --  will fail, so generate an appropriate warning. The raise
12267                   --  will be generated by Expand_N_Type_Conversion.
12268
12269                   if In_Instance_Body then
12270                      Error_Msg_Warn := SPARK_Mode /= On;
12271                      Conversion_Error_N
12272                        ("cannot convert access discriminant to non-local "
12273                         & "access type<<", Operand);
12274                      Conversion_Error_N ("\Program_Error [<<", Operand);
12275
12276                   --  Real error if not in instance body
12277
12278                   else
12279                      Conversion_Error_N
12280                        ("cannot convert access discriminant to non-local "
12281                         & "access type", Operand);
12282                      return False;
12283                   end if;
12284                end if;
12285
12286                --  The case of a reference to an access discriminant from
12287                --  within a limited type declaration (which will appear as
12288                --  a discriminal) is always illegal because the level of the
12289                --  discriminant is considered to be deeper than any (nameable)
12290                --  access type.
12291
12292                if Is_Entity_Name (Operand)
12293                  and then not Is_Local_Anonymous_Access (Opnd_Type)
12294                  and then
12295                    Ekind_In (Entity (Operand), E_In_Parameter, E_Constant)
12296                  and then Present (Discriminal_Link (Entity (Operand)))
12297                then
12298                   Conversion_Error_N
12299                     ("discriminant has deeper accessibility level than target",
12300                      Operand);
12301                   return False;
12302                end if;
12303             end if;
12304          end if;
12305
12306          return True;
12307
12308       --  General and anonymous access types
12309
12310       elsif Ekind_In (Target_Type, E_General_Access_Type,
12311                                    E_Anonymous_Access_Type)
12312           and then
12313             Conversion_Check
12314               (Is_Access_Type (Opnd_Type)
12315                 and then not
12316                   Ekind_In (Opnd_Type, E_Access_Subprogram_Type,
12317                                        E_Access_Protected_Subprogram_Type),
12318                "must be an access-to-object type")
12319       then
12320          if Is_Access_Constant (Opnd_Type)
12321            and then not Is_Access_Constant (Target_Type)
12322          then
12323             Conversion_Error_N
12324               ("access-to-constant operand type not allowed", Operand);
12325             return False;
12326          end if;
12327
12328          --  Check the static accessibility rule of 4.6(17). Note that the
12329          --  check is not enforced when within an instance body, since the RM
12330          --  requires such cases to be caught at run time.
12331
12332          if Ekind (Target_Type) /= E_Anonymous_Access_Type
12333            or else Is_Local_Anonymous_Access (Target_Type)
12334            or else Nkind (Associated_Node_For_Itype (Target_Type)) =
12335                      N_Object_Declaration
12336          then
12337             --  Ada 2012 (AI05-0149): Perform legality checking on implicit
12338             --  conversions from an anonymous access type to a named general
12339             --  access type. Such conversions are not allowed in the case of
12340             --  access parameters and stand-alone objects of an anonymous
12341             --  access type. The implicit conversion case is recognized by
12342             --  testing that Comes_From_Source is False and that it's been
12343             --  rewritten. The Comes_From_Source test isn't sufficient because
12344             --  nodes in inlined calls to predefined library routines can have
12345             --  Comes_From_Source set to False. (Is there a better way to test
12346             --  for implicit conversions???)
12347
12348             if Ada_Version >= Ada_2012
12349               and then not Comes_From_Source (N)
12350               and then N /= Original_Node (N)
12351               and then Ekind (Target_Type) = E_General_Access_Type
12352               and then Ekind (Opnd_Type) = E_Anonymous_Access_Type
12353             then
12354                if Is_Itype (Opnd_Type) then
12355
12356                   --  Implicit conversions aren't allowed for objects of an
12357                   --  anonymous access type, since such objects have nonstatic
12358                   --  levels in Ada 2012.
12359
12360                   if Nkind (Associated_Node_For_Itype (Opnd_Type)) =
12361                        N_Object_Declaration
12362                   then
12363                      Conversion_Error_N
12364                        ("implicit conversion of stand-alone anonymous "
12365                         & "access object not allowed", Operand);
12366                      return False;
12367
12368                   --  Implicit conversions aren't allowed for anonymous access
12369                   --  parameters. The "not Is_Local_Anonymous_Access_Type" test
12370                   --  is done to exclude anonymous access results.
12371
12372                   elsif not Is_Local_Anonymous_Access (Opnd_Type)
12373                     and then Nkind_In (Associated_Node_For_Itype (Opnd_Type),
12374                                        N_Function_Specification,
12375                                        N_Procedure_Specification)
12376                   then
12377                      Conversion_Error_N
12378                        ("implicit conversion of anonymous access formal "
12379                         & "not allowed", Operand);
12380                      return False;
12381
12382                   --  This is a case where there's an enclosing object whose
12383                   --  to which the "statically deeper than" relationship does
12384                   --  not apply (such as an access discriminant selected from
12385                   --  a dereference of an access parameter).
12386
12387                   elsif Object_Access_Level (Operand)
12388                           = Scope_Depth (Standard_Standard)
12389                   then
12390                      Conversion_Error_N
12391                        ("implicit conversion of anonymous access value "
12392                         & "not allowed", Operand);
12393                      return False;
12394
12395                   --  In other cases, the level of the operand's type must be
12396                   --  statically less deep than that of the target type, else
12397                   --  implicit conversion is disallowed (by RM12-8.6(27.1/3)).
12398
12399                   elsif Type_Access_Level (Opnd_Type) >
12400                         Deepest_Type_Access_Level (Target_Type)
12401                   then
12402                      Conversion_Error_N
12403                        ("implicit conversion of anonymous access value "
12404                         & "violates accessibility", Operand);
12405                      return False;
12406                   end if;
12407                end if;
12408
12409             elsif Type_Access_Level (Opnd_Type) >
12410                     Deepest_Type_Access_Level (Target_Type)
12411             then
12412                --  In an instance, this is a run-time check, but one we know
12413                --  will fail, so generate an appropriate warning. The raise
12414                --  will be generated by Expand_N_Type_Conversion.
12415
12416                if In_Instance_Body then
12417                   Error_Msg_Warn := SPARK_Mode /= On;
12418                   Conversion_Error_N
12419                     ("cannot convert local pointer to non-local access type<<",
12420                      Operand);
12421                   Conversion_Error_N ("\Program_Error [<<", Operand);
12422
12423                --  If not in an instance body, this is a real error
12424
12425                else
12426                   --  Avoid generation of spurious error message
12427
12428                   if not Error_Posted (N) then
12429                      Conversion_Error_N
12430                       ("cannot convert local pointer to non-local access type",
12431                        Operand);
12432                   end if;
12433
12434                   return False;
12435                end if;
12436
12437             --  Special accessibility checks are needed in the case of access
12438             --  discriminants declared for a limited type.
12439
12440             elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
12441               and then not Is_Local_Anonymous_Access (Opnd_Type)
12442             then
12443                --  When the operand is a selected access discriminant the check
12444                --  needs to be made against the level of the object denoted by
12445                --  the prefix of the selected name (Object_Access_Level handles
12446                --  checking the prefix of the operand for this case).
12447
12448                if Nkind (Operand) = N_Selected_Component
12449                  and then Object_Access_Level (Operand) >
12450                           Deepest_Type_Access_Level (Target_Type)
12451                then
12452                   --  In an instance, this is a run-time check, but one we know
12453                   --  will fail, so generate an appropriate warning. The raise
12454                   --  will be generated by Expand_N_Type_Conversion.
12455
12456                   if In_Instance_Body then
12457                      Error_Msg_Warn := SPARK_Mode /= On;
12458                      Conversion_Error_N
12459                        ("cannot convert access discriminant to non-local "
12460                         & "access type<<", Operand);
12461                      Conversion_Error_N ("\Program_Error [<<", Operand);
12462
12463                   --  If not in an instance body, this is a real error
12464
12465                   else
12466                      Conversion_Error_N
12467                        ("cannot convert access discriminant to non-local "
12468                         & "access type", Operand);
12469                      return False;
12470                   end if;
12471                end if;
12472
12473                --  The case of a reference to an access discriminant from
12474                --  within a limited type declaration (which will appear as
12475                --  a discriminal) is always illegal because the level of the
12476                --  discriminant is considered to be deeper than any (nameable)
12477                --  access type.
12478
12479                if Is_Entity_Name (Operand)
12480                  and then
12481                    Ekind_In (Entity (Operand), E_In_Parameter, E_Constant)
12482                  and then Present (Discriminal_Link (Entity (Operand)))
12483                then
12484                   Conversion_Error_N
12485                     ("discriminant has deeper accessibility level than target",
12486                      Operand);
12487                   return False;
12488                end if;
12489             end if;
12490          end if;
12491
12492          --  In the presence of limited_with clauses we have to use nonlimited
12493          --  views, if available.
12494
12495          Check_Limited : declare
12496             function Full_Designated_Type (T : Entity_Id) return Entity_Id;
12497             --  Helper function to handle limited views
12498
12499             --------------------------
12500             -- Full_Designated_Type --
12501             --------------------------
12502
12503             function Full_Designated_Type (T : Entity_Id) return Entity_Id is
12504                Desig : constant Entity_Id := Designated_Type (T);
12505
12506             begin
12507                --  Handle the limited view of a type
12508
12509                if From_Limited_With (Desig)
12510                  and then Has_Non_Limited_View (Desig)
12511                then
12512                   return Available_View (Desig);
12513                else
12514                   return Desig;
12515                end if;
12516             end Full_Designated_Type;
12517
12518             --  Local Declarations
12519
12520             Target : constant Entity_Id := Full_Designated_Type (Target_Type);
12521             Opnd   : constant Entity_Id := Full_Designated_Type (Opnd_Type);
12522
12523             Same_Base : constant Boolean :=
12524                           Base_Type (Target) = Base_Type (Opnd);
12525
12526          --  Start of processing for Check_Limited
12527
12528          begin
12529             if Is_Tagged_Type (Target) then
12530                return Valid_Tagged_Conversion (Target, Opnd);
12531
12532             else
12533                if not Same_Base then
12534                   Conversion_Error_NE
12535                     ("target designated type not compatible with }",
12536                      N, Base_Type (Opnd));
12537                   return False;
12538
12539                --  Ada 2005 AI-384: legality rule is symmetric in both
12540                --  designated types. The conversion is legal (with possible
12541                --  constraint check) if either designated type is
12542                --  unconstrained.
12543
12544                elsif Subtypes_Statically_Match (Target, Opnd)
12545                  or else
12546                    (Has_Discriminants (Target)
12547                      and then
12548                       (not Is_Constrained (Opnd)
12549                         or else not Is_Constrained (Target)))
12550                then
12551                   --  Special case, if Value_Size has been used to make the
12552                   --  sizes different, the conversion is not allowed even
12553                   --  though the subtypes statically match.
12554
12555                   if Known_Static_RM_Size (Target)
12556                     and then Known_Static_RM_Size (Opnd)
12557                     and then RM_Size (Target) /= RM_Size (Opnd)
12558                   then
12559                      Conversion_Error_NE
12560                        ("target designated subtype not compatible with }",
12561                         N, Opnd);
12562                      Conversion_Error_NE
12563                        ("\because sizes of the two designated subtypes differ",
12564                         N, Opnd);
12565                      return False;
12566
12567                   --  Normal case where conversion is allowed
12568
12569                   else
12570                      return True;
12571                   end if;
12572
12573                else
12574                   Error_Msg_NE
12575                     ("target designated subtype not compatible with }",
12576                      N, Opnd);
12577                   return False;
12578                end if;
12579             end if;
12580          end Check_Limited;
12581
12582       --  Access to subprogram types. If the operand is an access parameter,
12583       --  the type has a deeper accessibility that any master, and cannot be
12584       --  assigned. We must make an exception if the conversion is part of an
12585       --  assignment and the target is the return object of an extended return
12586       --  statement, because in that case the accessibility check takes place
12587       --  after the return.
12588
12589       elsif Is_Access_Subprogram_Type (Target_Type)
12590
12591         --  Note: this test of Opnd_Type is there to prevent entering this
12592         --  branch in the case of a remote access to subprogram type, which
12593         --  is internally represented as an E_Record_Type.
12594
12595         and then Is_Access_Type (Opnd_Type)
12596       then
12597          if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type
12598            and then Is_Entity_Name (Operand)
12599            and then Ekind (Entity (Operand)) = E_In_Parameter
12600            and then
12601              (Nkind (Parent (N)) /= N_Assignment_Statement
12602                or else not Is_Entity_Name (Name (Parent (N)))
12603                or else not Is_Return_Object (Entity (Name (Parent (N)))))
12604          then
12605             Conversion_Error_N
12606               ("illegal attempt to store anonymous access to subprogram",
12607                Operand);
12608             Conversion_Error_N
12609               ("\value has deeper accessibility than any master "
12610                & "(RM 3.10.2 (13))",
12611                Operand);
12612
12613             Error_Msg_NE
12614              ("\use named access type for& instead of access parameter",
12615                Operand, Entity (Operand));
12616          end if;
12617
12618          --  Check that the designated types are subtype conformant
12619
12620          Check_Subtype_Conformant (New_Id  => Designated_Type (Target_Type),
12621                                    Old_Id  => Designated_Type (Opnd_Type),
12622                                    Err_Loc => N);
12623
12624          --  Check the static accessibility rule of 4.6(20)
12625
12626          if Type_Access_Level (Opnd_Type) >
12627             Deepest_Type_Access_Level (Target_Type)
12628          then
12629             Conversion_Error_N
12630               ("operand type has deeper accessibility level than target",
12631                Operand);
12632
12633          --  Check that if the operand type is declared in a generic body,
12634          --  then the target type must be declared within that same body
12635          --  (enforces last sentence of 4.6(20)).
12636
12637          elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
12638             declare
12639                O_Gen : constant Node_Id :=
12640                          Enclosing_Generic_Body (Opnd_Type);
12641
12642                T_Gen : Node_Id;
12643
12644             begin
12645                T_Gen := Enclosing_Generic_Body (Target_Type);
12646                while Present (T_Gen) and then T_Gen /= O_Gen loop
12647                   T_Gen := Enclosing_Generic_Body (T_Gen);
12648                end loop;
12649
12650                if T_Gen /= O_Gen then
12651                   Conversion_Error_N
12652                     ("target type must be declared in same generic body "
12653                      & "as operand type", N);
12654                end if;
12655             end;
12656          end if;
12657
12658          return True;
12659
12660       --  Remote access to subprogram types
12661
12662       elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
12663         and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
12664       then
12665          --  It is valid to convert from one RAS type to another provided
12666          --  that their specification statically match.
12667
12668          --  Note: at this point, remote access to subprogram types have been
12669          --  expanded to their E_Record_Type representation, and we need to
12670          --  go back to the original access type definition using the
12671          --  Corresponding_Remote_Type attribute in order to check that the
12672          --  designated profiles match.
12673
12674          pragma Assert (Ekind (Target_Type) = E_Record_Type);
12675          pragma Assert (Ekind (Opnd_Type) = E_Record_Type);
12676
12677          Check_Subtype_Conformant
12678            (New_Id  =>
12679               Designated_Type (Corresponding_Remote_Type (Target_Type)),
12680             Old_Id  =>
12681               Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
12682             Err_Loc =>
12683               N);
12684          return True;
12685
12686       --  If it was legal in the generic, it's legal in the instance
12687
12688       elsif In_Instance_Body then
12689          return True;
12690
12691       --  If both are tagged types, check legality of view conversions
12692
12693       elsif Is_Tagged_Type (Target_Type)
12694               and then
12695             Is_Tagged_Type (Opnd_Type)
12696       then
12697          return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
12698
12699       --  Types derived from the same root type are convertible
12700
12701       elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
12702          return True;
12703
12704       --  In an instance or an inlined body, there may be inconsistent views of
12705       --  the same type, or of types derived from a common root.
12706
12707       elsif (In_Instance or In_Inlined_Body)
12708         and then
12709           Root_Type (Underlying_Type (Target_Type)) =
12710           Root_Type (Underlying_Type (Opnd_Type))
12711       then
12712          return True;
12713
12714       --  Special check for common access type error case
12715
12716       elsif Ekind (Target_Type) = E_Access_Type
12717          and then Is_Access_Type (Opnd_Type)
12718       then
12719          Conversion_Error_N ("target type must be general access type!", N);
12720          Conversion_Error_NE -- CODEFIX
12721             ("add ALL to }!", N, Target_Type);
12722          return False;
12723
12724       --  Here we have a real conversion error
12725
12726       else
12727          Conversion_Error_NE
12728            ("invalid conversion, not compatible with }", N, Opnd_Type);
12729          return False;
12730       end if;
12731    end Valid_Conversion;
12732
12733 end Sem_Res;