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